How to save multiple pdf attachments in Outlook to hard drive by extracting mail items

Question

I have 25 mails which each have 25 pdf attachments inside of them within only one email - cascading each other. In other words, one email contains 25 outlook mail items which have 1 pdf attached per email. I have found a code to save all attachments but when I do that it will only save them as outlook mail item. I will need to extract pdfs from outlook mail item(s). Any known VBA code for this??? - Please keep in mind that I can't install software which requires admin pass because it is a work computer. So, if you would refer me third party software, I wouldn't be able to install them unless they are zipped or plug ins for Windows outlook like VBA code or something.

Example image

For more info refer this image

Answer 1

Once you have saved an Outlook item you can open it with OpenSharedItem

https://msdn.microsoft.com/EN-US/library/office/ff869733.aspx

then save the PDF attachment.

If you already have code to save mailitems then right after each mailitem is saved insert OpenSharedItem and as well code to save the PDF.

Here is example code demonstrating how to bring mail back from Windows to Outlook with OpenSharedItem. https://www.slipstick.com/developer/code-samples/move-messages-file-system-outlook/

Sub ImportMessagesInFolder()
    Dim fso As Scripting.FileSystemObject
    Dim SourceFolder As Scripting.Folder
    Dim SourceFolderName As String
    Dim FileItem As Scripting.File
    Dim strFile, strFileType As String
    Dim oMsg As Object
    Dim copiedMsg As MailItem
    Dim Savefolder As Outlook.Folder

    Set fso = New Scripting.FileSystemObject
'Source folder
    SourceFolderName = "C:\Users\drcp\Documents\Email\"
    Set SourceFolder = fso.GetFolder(SourceFolderName)

'Set the Outlook folder name
    ' Set Savefolder = Session.GetDefaultFolder(olFolderInbox).Folders("My Subfolder")
    Set Savefolder = Application.ActiveExplorer.CurrentFolder

    For Each FileItem In SourceFolder.Files

    Set oMsg = Session.OpenSharedItem(FileItem.Path)

    ' Do not bypass errors indiscriminately
    'On Error Resume Next

    Set copiedMsg = oMsg.Copy
    copiedMsg.Move Savefolder

    Set copiedMsg = Nothing
    oMsg.Delete
    Set oMsg = Nothing

    Next FileItem

    Set FileItem = Nothing
    Set SourceFolder = Nothing
    Set fso = Nothing

End Sub

Answer 2

You can do that using two free utilities.

First, Save Attached Outlook Items. Just create a temp folder in your Outlook (say, "Attached"), select these 25 messages in Outlook and run the mentioned tool using context menu specifying "Attached" folder as a target folder. Now you have all your attached emails (with PDFs) in the temp "Attached" folder.

Finally, use the Save Attachments utility, select the "Attached" folder and specify the target folder on your disk. This will save all PDFs to the specified folder.

Please note that I recommend these tools because I'm one of the developers, so feel free to ask any further questions.

Answer 3

Ok, I figured out. First you need to create a new folder in your inbox. Then, copy all the email items into your new folder(25 outlook email items which contains 25 pdfs) attached. And then highlight all the emails then run below script. This will allow you to save all of them.

Sub ImportMessagesInFolder()
Dim fso As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder
Dim SourceFolderName As String
Dim FileItem As Scripting.File
Dim strFile, strFileType As String
Dim oMsg As Object
Dim copiedMsg As MailItem
Dim Savefolder As Outlook.Folder

Set fso = New Scripting.FileSystemObject
'Source folder
SourceFolderName = "C:\Users\drcp\Documents\Email\"
Set SourceFolder = fso.GetFolder(SourceFolderName)

 'Set the Outlook folder name
' Set Savefolder = Session.GetDefaultFolder(olFolderInbox).Folders("My Subfolder")
Set Savefolder = Application.ActiveExplorer.CurrentFolder

For Each FileItem In SourceFolder.Files

Set oMsg = Session.OpenSharedItem(FileItem.Path)

' Do not bypass errors indiscriminately
'On Error Resume Next

Set copiedMsg = oMsg.Copy
copiedMsg.Move Savefolder

Set copiedMsg = Nothing
oMsg.Delete
Set oMsg = Nothing

Next FileItem

Set FileItem = Nothing
Set SourceFolder = Nothing
Set fso = Nothing

End Sub