Consulting

Results 1 to 3 of 3

Thread: Saving Msg file attachments with same file names

  1. #1
    VBAX Newbie
    Joined
    Sep 2015
    Posts
    2
    Location

    Saving Msg file attachments with same file names

    MS Outlook 2010

    I receive emails weekly with a ton of .PDF file attachments and .MSG files containing additional .PDF files attached. I am trying to figure out how to extract the .PDF files from the .MSG attachments and save them with the rest of the .PDFs. I have no problem saving the regular .PDF attachments, it’s just the .MSG files that are the real hassle.

    Saves PDF:
    Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
    Dim objAtt As Outlook.Attachment
    Dim saveFolder As String
    saveFolder = "C:\Cases\"
    For Each objAtt In itm.Attachments
    MkDir saveFolder & "\" & objAtt.DisplayName
    objAtt.SaveAsFile saveFolder & "\" & objAtt.DisplayName & "\" & objAtt.DisplayName
    Set objAtt = Nothing
    Next
    End Sub
    I have found some code that saves attachments from .MSG files, but it deletes the original attachments in the email after saving it to the hard drive. I need these attachments to stay intact after running the script. Furthermore, the .PDFs attached to the .MSG files all have the same name, so the script below just continuously overwrites the last file.
    This is the only code I could find that saves .MSG file attachments:

    Sub SaveOlAttachments()
     
    Dim olFolder As Outlook.MAPIFolder
    Dim msg As Outlook.MailItem
    Dim msg2 As Outlook.MailItem
    Dim att As Outlook.Attachment
    Dim strFilePath As String
    Dim strTmpMsg As String
    Dim fsSaveFolder As String
     
    fsSaveFolder = "C:\temp\"
    strFilePath = "C:\temp\"
    strTmpMsg = "KillMe.msg"
     
    Set olFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
    Set olFolder = olFolder.Folders("test")
    If olFolder Is Nothing Then Exit Sub
     
    For Each msg In olFolder.Items
    If msg.Attachments.Count > 0 Then
    While msg.Attachments.Count > 0
    bflag = False
    If Right$(msg.Attachments(1).FileName, 3) = "msg" Then
    bflag = True
    msg.Attachments(1).SaveAsFile strFilePath & strTmpMsg
    Set msg2 = Application.CreateItemFromTemplate(strFilePath & strTmpMsg)
    End If
    If bflag Then
    sSavePathFS = fsSaveFolder & msg2.Attachments(1).FileName
    msg2.Attachments(1).SaveAsFile sSavePathFS & msg.Attachments.Count
    msg2.Delete
    Else
    sSavePathFS = fsSaveFolder & msg.Attachments(1).FileName
    msg.Attachments(1).SaveAsFile sSavePathFS
    End If
    msg.Attachments(1).Delete
    Wend
    msg.Delete
    End If
    Next
    End Sub
    Any help on this would be greatly appreciated as it would help me daily at work. Sorry, but my VBA skills are limited to very basic programming.

  2. #2
    This is not an area to exercise fledgling VBA programming skills, but take a look at http://www.vbaexpress.com/forum/show...ypes-VBA-macro which may offer some insights and a couple of functions that you can use to ensure files are not overwritten.
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  3. #3
    VBAX Newbie
    Joined
    Sep 2015
    Posts
    2
    Location
    OK, thank you. By the way this has now been solved. I used the code I posted above, but changed the location of the temporary directory and the save directory. I also put the count number in front of the file name so it wouldn't overwrite itself.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •