Btukfyl

I've got this block of code to go through all the emails in my "Today" folder in Outlook, then save all the emails (.msg) to a folder named as the sender name. However, sometimes the .msg files aren't being saved and instead it's just saving a file, with the file type "file". How do I fix this to make sure the emails are saved as .msg files?

Screenshot of the "file" file type
Screenshot of its properties

Thanks,
PJ

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:UsersworkDesktop22_11_18Test" & 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

You can use subject if the characters in the subject are all valid.

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:UsersworkDesktop22_11_18Test" & 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