将Outlook电子邮件另存为“ .msg”而不是“文件”

Question

我已经获得了这段代码，可以遍历Outlook中“今日”文件夹中的所有电子邮件，然后将所有电子邮件（.msg）保存到名为发件人名称的文件夹中。

有时文件以文件类型“ file”保存。

如何解决此问题，以确保将电子邮件另存为.msg文件？

Sub SaveAttachments()
'https://www.fontstuff.com/outlook/oltut01.htm
'Declare Variables
Dim ns As NameSpace
Dim Inbox As Outlook.MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim Savefolder As String
Dim i As Integer

Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox).Folders("Today")
i = 0

'Stop script if there are no emails 
If Inbox.Items.Count = 0 Then
    MsgBox "There are no messages in the Inbox.", vbInformation, "Nothing Found"
    Exit Sub
End If

'Display the number of emails
MsgBox Inbox.Items.Count, vbInformation, _
    "Number of Emails?"

'Go through each email
For Each Item In Inbox.Items
    'Create a path for the save folder
    Savefolder = "C:\Users\work\Desktop\22_11_18\Test\" & Item.SenderName
    'If the email has attachments, then create a folder
    If Item.Attachments.Count > 0 Then
        MkDir Savefolder
        'If the folder already exists, skip to the next statement
        On Error Resume Next
    'Save the email as a .msg file
    Item.SaveAs Savefolder & "\" & Item.Subject & ".msg"
    End If

Next Item
End Sub

Answer 1

如果主题中的字符全部有效，则可以使用主题。

Option Explicit

Private Sub SaveMail_ContainingAttachments_ValidSubject()

'Declare Variables
Dim ns As Namespace
Dim targetFolder As Folder
Dim itm As Object
Dim atmt As Attachment

Dim strSaveFolder As String
Dim validSubject As String

Set ns = GetNamespace("MAPI")
Set targetFolder = ns.GetDefaultFolder(olFolderInbox)
Set targetFolder = targetFolder.Folders("Today")

'Stop script if there are no emails
If targetFolder.Items.count = 0 Then
    MsgBox "There are no messages in " & targetFolder & ".", vbInformation, "Nothing Found"
    Exit Sub
End If

'Display the number of emails
MsgBox targetFolder.Items.count, vbInformation, "Number of Emails?"

'Go through each email
For Each itm In targetFolder.Items

    'If the email has attachments, then create a folder
    If itm.Attachments.count > 0 Then

        'Create a path for the save folder
        strSaveFolder = "C:\Users\work\Desktop\22_11_18\Test\" & itm.senderName

        ' Bypass error if the folder already exists
        On Error Resume Next
        MkDir strSaveFolder

        ' Discontinue error bypass as soon as the purpose is served
        ' Let unknown errors generate then fix them
        On Error GoTo 0

        ' Replace or remove invalid characters
        ' Possible options "_" or " " or "" ....
        validSubject = ReplaceIllegalChar(itm.subject, "_")
        If validSubject <> itm.subject Then
            Debug.Print itm.subject
            Debug.Print validSubject
        End If

        'Save the email as a .msg file
        itm.SaveAs strSaveFolder & "\" & validSubject & ".msg"

    End If

Next itm

End Sub

Private Function ReplaceIllegalChar(strInput, strReplace)

    Dim RegX As Object

    Set RegX = CreateObject("vbscript.regexp")

    RegX.Pattern = "[\" & Chr(34) & "\!\@\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\;\:\<\>\?\/\,]"
    RegX.IgnoreCase = True
    RegX.Global = True

    ' Replace with another string
    ReplaceIllegalChar = RegX.Replace(strInput, strReplace)

ExitFunction:

    Set RegX = Nothing

End Function