Extract msg attachments from outlook email - vba

I have the following vba code that saves attachments in an email.
This works fine for .docx, .jpg etc but I need to use it to extract multiple .msg attachments which doesn't work.
The code is
Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
saveFolder = "C:\Test\"
For Each objAtt In itm.Attachments
stFileName = saveFolder & "\" & objAtt.DisplayName
i = 0
JumpHere:
If Dir(stFileName) = "" Then
objAtt.SaveAsFile stFileName
Else
i = i + 1
stFileName = saveFolder & "\" & i & " - " & objAtt.DisplayName
GoTo JumpHere
End If
Set objAtt = Nothing
Next
End Sub
The error concerns the line - If Dir(stFileName) = "" Then


Following our chat, here is the final code :
Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
Dim i As Integer
saveFolder = "C:\Test\"
For Each objAtt In itm.Attachments
stFileName = saveFolder & objAtt.FileName
i = 0
'Loop to find the first available filename
Do While Dir(stFileName) <> ""
i = i + 1
stFileName = saveFolder & i & " - " & objAtt.FileName
Loop
objAtt.SaveAsFile stFileName
Next
End Sub
Regards,
Max

Related

How to run code, that normally runs in a rule, on a selected item?

I have code to save all attachments in a specific folder.
When I run it on a selected email, I get an error due to Outlook.MailItem being empty.
Does this need a modification to work with selected items instead of an email fetched by a rule?
Public Sub saveAttachtoDisk2(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
Set Totalmsg = itm.ReceivedTime
saveFolder = "C:\path\to\file"
For Each objAtt In itm.Attachments
objAtt.SaveAsFile saveFolder & "\" & Totalmsg & "." & objAtt.DisplayName
Set objAtt = Nothing
Next
End Sub

Try this:
For Each objAtt In itm.Attachments
If Not objAtt Is Nothing Then
objAtt.SaveAsFile saveFolder & "\" & Totalmsg & "." & objAtt.DisplayName
End If
Next
Note: There's no need to Set objAtt = Nothing for objAtt will be assigned a new value in the next loop and/or released at all when exiting sub.

You can initialize the itm variable by setting it to Application.ActiveExplorer.Selection.Item(1) (error checking omitted)

Auto Download Attachments and Rename using Sender's Name

I have the following code that auto save the attachments from any incoming mail and renames the attachment with the date and time so as not to overwrite.
Public Sub AutoSaveAttachment(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
Dim dateFormat
saveFolder = "C:\temp"
dateFormat = Format(Now, "mm.dd.yyyy (Hh.Nn)")
For Each objAtt In itm.Attachments
If InStr(objAtt.DisplayName, ".pdf") Then
objAtt.SaveAsFile saveFolder & "\" & "Attch " & dateFormat & "." & "pdf"
End If
Set objAtt = Nothing
Next
End Sub
I want to add the sender's name before the date/time. I tried this code below which doesn't work. Run-time error.
Sub AttachmentDownloader(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
Dim senderName As String
Dim dateFormat
dateFormat = Format(Now, "mmddyyyy_(Hh.Nn)")
senderName = objAtt.senderName & "_"
saveFolder = "C:\temp"
For Each objAtt In itm.Attachments
If InStr(objAtt.DisplayName, ".pdf") _
Or InStr(objAtt.DisplayName, ".xlsx") _
Or InStr(objAtt.DisplayName, ".xlsm") _
Or InStr(objAtt.DisplayName, ".doc") _
Or InStr(objAtt.DisplayName, ".docx") Then
objAtt.SaveAsFile saveFolder & "\" & senderName & dateFormat & objAtt.DisplayName
End If
Set objAtt = Nothing
Next
End Sub
Any help would be greatly appreciated.

Runtime error "424: Object Required" because you haven't assigned to the objAtt variable yet. You've got an instantiated, but unassigned object variable.
Which is presumably an Attachment object, but that will raise a "Method or data member not found" error, because the attachment object doesn't have a senderName property, that belongs to the MailItem class.
So, try:
senderName = itm.senderName & "_"

Save specific file type as attachment with received date time

save only images to a folder i.e .jpg .jpeg .gif .png
Include the received date
rename all saved image filetypes to ".jpg"
I have most of it down. It is saving files like this: test.jpeg.jpg and test.jpg.jpg
Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
Dim dateFormat As String
Dim strFileExtension As String
saveFolder = "C:\emails\"
dateFormat = Format(itm.ReceivedTime, "yyyy-mm-dd Hmm ")
strFileExtension = ".jpg"
For Each objAtt In itm.Attachments
objAtt.SaveAsFile saveFolder & "\" & dateFormat & objAtt.DisplayName & strFileExtension
Set objAtt = Nothing
Next
End Sub

Something like the following would work:
Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
Dim dateFormat As String
Dim strFileExtension As String
Dim strSaveFileName as string
saveFolder = "C:\emails\"
dateFormat = Format(itm.ReceivedTime, "yyyy-mm-dd Hmm ")
strFileExtension = ".jpg"
For Each objAtt In itm.Attachments
if lcase(right(objAtt.FileName, 4)) = "jpeg" or lcase(right(obtAtt.FileName, 3) = "jpg") then
strSaveFileName = mid(objAtt.FileName, instr(1, objAtt.FileName, ".", length(objAtt.FileName) - instr(1, obtAtt.FileName)) & strFileExtension
objAtt.SaveAsFile saveFolder & "\" & dateFormat & strSaveFileName
Set objAtt = Nothing
End if
Next
End Sub
This has an added if statement to test for the file extension being JPG or JPEG. If it is, then it uses some string functions to grab the bits of the filename before the extension and uses that in the final saveasfile.

91 object variable or with block variable not set

I am trying to download the attachment from a subject specified e-mail.
If Msg.Subject = "CALENDAR-EVENT" Then
'Download the attachment
Dim itmAttach As Outlook.MailItem
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
saveFolder = "C:\events\"
Dim dateFormat As String
dateFormat = Format(itmAttach.ReceivedTime, "yyyy-mm-dd Hmm ")
For Each objAtt In itmAttach.Attachments
objAtt.SaveAsFile saveFolder & "\" & dateFormat & objAtt.DisplayName
Next
End if
I get the error:
91 object variable or with block variable not set
Maybe there is some error with the line:
Dim itmAttach As Outlook.MailItem
It also would be nice to get the downloaded file's name.

I did not use the outlook APIs before, neither did I touch VBA for years, but by the looks of it you meant this:
If Msg.Subject = "CALENDAR-EVENT" Then
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
saveFolder = "C:\events"
Dim dateFormat As String
dateFormat = Format(Msg.ReceivedTime, "yyyy-mm-dd Hmm ")
For Each objAtt In Msg.Attachments
objAtt.SaveAsFile saveFolder & "\" & dateFormat & objAtt.DisplayName
Next
End if
Error 91 seems to be VBA's NullReferenceException.

How do I save an attachment from an Outlook email retaining the date time stamp of the attachment

I am trying to use a script and rule in Outlook to automatically file an attachment. It works but instead of using the attachment's date time, it uses the current datetime.
Here is my script:
Public Sub saveFedhealthstatement(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
Dim dateFormat
dateFormat = Format(Now, "yyyy-mm-dd H-mm")
Dim subject
subject = itm.subject
saveFolder = "f:\filing\fedhealth"
For Each objAtt In itm.Attachments
objAtt.SaveAsFile saveFolder & "\" & subject & objAtt.DisplayName
Set objAtt = Nothing
Next
End Sub