使用文件名中的非法字符将消息保存到本地文件夹

Question

我有以下代码将Outlook中的电子邮件保存到桌面上的文件夹中。

我想用Outlook中的电子邮件主题来命名这些文件。我不想去掉任何字符。

我已经玩过这个宏，但我无法修复它。还想删除时间戳日期等

Option Explicit
Dim StrSavePath     As String
Sub SaveAllEmails_ProcessAllSubFolders()
Dim i               As Long
Dim j               As Long
Dim n               As Long
Dim StrSubject      As String
Dim StrName         As String
Dim StrFile         As String
Dim StrReceived     As String
Dim StrFolder       As String
Dim StrSaveFolder   As String
Dim StrFolderPath   As String
Dim iNameSpace      As NameSpace
Dim myOlApp         As Outlook.Application
Dim SubFolder       As MAPIFolder
Dim mItem           As MailItem
Dim FSO             As Object
Dim ChosenFolder    As Object
Dim Folders         As New Collection
Dim EntryID         As New Collection
Dim StoreID         As New Collection
Set FSO = CreateObject("Scripting.FileSystemObject")
Set myOlApp = Outlook.Application
Set iNameSpace = myOlApp.GetNamespace("MAPI")
Set ChosenFolder = iNameSpace.PickFolder
If ChosenFolder Is Nothing Then
'GoTo ExitSub:
End If
BrowseForFolder StrSavePath
Call GetFolder(Folders, EntryID, StoreID, ChosenFolder)
For i = 1 To Folders.Count
StrFolder = StripIllegalChar(Folders(i))
n = InStr(3, StrFolder, "") + 1
StrFolder = Mid(StrFolder, n, 256)
StrFolderPath = StrSavePath & "" & StrFolder & ""
StrSaveFolder = Left(StrFolderPath, Len(StrFolderPath) - 1) & ""
If Not FSO.FolderExists(StrFolderPath) Then
FSO.CreateFolder (StrFolderPath)
End If
Set SubFolder = myOlApp.Session.GetFolderFromID(EntryID(i), StoreID(i))
On Error Resume Next
For j = 1 To SubFolder.Items.Count
Set mItem = SubFolder.Items(j)
StrReceived = Format(mItem.ReceivedTime, "YYYYMMDD-hhmm")
StrSubject = mItem.Subject
StrName = StripIllegalChar(StrSubject)
StrFile = StrSaveFolder & StrReceived & "_" & StrName & ".msg"
StrFile = Left(StrFile, 256)
mItem.SaveAs StrFile, 3
Next j
On Error GoTo 0
Next i
ExitSub:
End Sub
Function StripIllegalChar(StrInput)
Dim RegX            As Object
Set RegX = CreateObject("vbscript.regexp")
RegX.Pattern = "[" & Chr(34) & "!@#$%^&*()=+|[]{}`';:<>?/,]"
RegX.IgnoreCase = True
RegX.Global = True
StripIllegalChar = RegX.Replace(StrInput, "")
ExitFunction:
Set RegX = Nothing
End Function

Sub GetFolder(Folders As Collection, EntryID As Collection, _
StoreID As Collection, Fld As MAPIFolder)
Dim SubFolder       As MAPIFolder
Folders.Add Fld.FolderPath
EntryID.Add Fld.EntryID
StoreID.Add Fld.StoreID
For Each SubFolder In Fld.Folders
GetFolder Folders, EntryID, StoreID, SubFolder
Next SubFolder
ExitSub:
Set SubFolder = Nothing
End Sub

Function BrowseForFolder(StrSavePath As String, _
Optional OpenAt As String) As String
Dim objShell As Object
Dim objFolder '  As Folder
Dim enviro
enviro = CStr(Environ("USERPROFILE"))
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, "Please choose a folder", _
0, enviro & "C:TempFolders")
StrSavePath = objFolder.self.Path
On Error Resume Next
On Error GoTo 0
ExitFunction:
Set objShell = Nothing
End Function

Answer 1

如果您绝对希望保持原始电子邮件不变，另一种方法是将原始电子邮件保存为附件，为自己创建一封新的电子邮件。将新电子邮件保存为已更正的主题，以避免出现窗口命名错误，它将保留未更改的原始电子邮件的链接。这是一些额外的步骤，但如果你坚持保持原始电子邮件不变，你应该能够自动化这些步骤。

Answer 2

就像Tim说的那样，这是个坏主意，但如果这是你想要做的，那么就把你的j循环修改成这样。。。

For j = 1 To SubFolder.Items.Count
Set mItem = SubFolder.Items(j)
StrSubject = mItem.Subject
StrSubject = StrSaveFolder & StrSubject & ".msg"
mItem.SaveAs StrSubject, 3
Next j

祝你好运。。。