Results 1 to 4 of 4

Thread: Saving Msg file attachments with same file names

  1. #1
    VBAX Newbie
    Sep 2015

    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
    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
    sSavePathFS = fsSaveFolder & msg.Attachments(1).FileName
    msg.Attachments(1).SaveAsFile sSavePathFS
    End If
    End If
    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 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

  3. #3
    VBAX Newbie
    Sep 2015
    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.

  4. #4
    MSG Attachment Extractor Tool is a cost-effective and efficient tool for extracting MSG attachments of all types, including PDF, DOC, XLS, etc. It can remove attachments from multiple MSG files at the same time. As a result, users would not have to repeat the steps for each MSG log. They can all be loaded at the same time for attachment extraction. Outlook MSG files (2021, 2019, 2016, 2013, 2007, 2003, 2002, etc.) Export Attachments from MSG Files Software utility is programmed in such a way that the user interface is highly user-friendly and simple to use for both technical and non-technical users. Download the free demo version of the software.

Posting Permissions

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