Saving Msg file attachments with same file names

[TheFuzz]

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.

[gmayor]

This is not an area to exercise fledgling VBA programming skills, but take a look at http://www.vbaexpress.com/forum/showthread.php?51973-Outlook-download-attachments-Multi-Files-Specific-Name-Specific-types-VBA-macro which may offer some insights and a couple of functions that you can use to ensure files are not overwritten.

[TheFuzz]

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.