Сохранение электронной почты 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