Save Outlook attachment to a folder and Rename the file with date - vba

I'm trying to save the daily system generated report attached to the e-mail to a folder.
Then, append the attachment filename with the date (modified date in the file). I am able to get the file saved to a folder. However, the renaming piece doesn't seem to work for me.
Can someone please help why the renaming piece isn't working? Much Thanks!
Public Sub saveAttachtoBIFolder(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
Dim fso As Object
Dim oldName As Object
Dim file As String
Dim DateFormat As String
Dim newName As Object
saveFolder = "C:\BI Reports"
Set fso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
For Each objAtt In itm.Attachments
file = saveFolder & "\" & objAtt.DisplayName
objAtt.SaveAsFile file
Debug.Print "file="; file ' the full file path printed on immediate screen
Set oldName = fso.GetFile(file) ' issue seems to start from here
DateFormat = Format(oldName.DateLastModified, "yyyy-mm-dd ")
newName = DateFormat & objAtt.DisplayName
oldName.Name = newName
Debug.Print "DateFormat="; DateFormat 'the date format printed on the immediate screen
Set objAtt = Nothing
Next
Set fso = Nothing
End Sub

Your newName needs to be string NOT Object so Dim newName As String also I would assign objAtt.DisplayName to string variable
See Example
Set FSO = CreateObject("Scripting.FileSystemObject")
For Each objAtt In itm.Attachments
File = saveFolder & "\" & objAtt.DisplayName
objAtt.SaveAsFile File
Debug.Print File ' the full file path printed on immediate screen
Set oldName = FSO.GetFile(File) ' issue seems to start from here
Debug.Print oldName
Dim newName As String
Dim AtmtName As String
AtmtName = objAtt.DisplayName
Debug.Print AtmtName
DateFormat = Format(oldName.DateLastModified, "yyyy-mm-dd ")
Debug.Print DateFormat
newName = DateFormat & " " & AtmtName
oldName.Name = newName
Debug.Print newName 'the date format printed on the immediate screen
Next

Related

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 & "_"

VBA code update from Outlook 2016 to 2013

I wrote this code on an other PC which had Win10 and Office 2016. It is used in an outlook rule. It saves the xml files from the e-mail to a folder and change it to xlsx file in an other folder. In Outlook 2016 it runs properly. I copied it to an other notebook.
This notebook has Win10 and Office 2013 and this code run in Outlook 2013 without any error message but the xml files neither were saved into the given folder and nor were converted to xlsx.
What could be wrong in this code?
Option Explicit
Public Sub saveconvAttachtoDisk(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
Dim dateFormat As String
Dim convFormat As String
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
saveFolder = "C:\Users\tulaj\Documents\xml\"
convFolder = "C:\Users\tulaj\Documents\xls\"
dateFormat = Format(itm.ReceivedTime, "yyyy-mm-dd HH-mm-ss")
For Each objAtt In itm.Attachments
objAtt.SaveAsFile saveFolder & dateFormat & objAtt.FileName
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(saveFolder)
If UCase(Right(objAtt.FileName, Len(XML))) = UCase(XML) Then
NewFileName = convFolder & dateFormat & objAtt.FileName & "_conv.xlsx"
Set ConvertThis = Workbooks.Open(saveFolder & dateFormat & objAtt.FileName)
ConvertThis.SaveAs FileName:=NewFileName, FileFormat:= _
xlOpenXMLWorkbook
ConvertThis.Close
End If
Next
Set objAtt = Nothing
End Sub
In Tools-References are selected the falowings:
Visual Basic For Aplications
Microsoft Outlook 15.0 Object Library
OLE Automation
Microsoft Office 15.0 Object Library
Microsoft Excel 15.0 Object Library
Microsoft Scripting Runtime
This should work for you...
Option Explicit
Public Sub saveconvAttachtoDisk(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim SaveFolder As String
Dim convFolder As String
Dim DateFormat As String
Dim ConvFormat As String
Dim NewFileName As String
Dim ConvertThis As Object
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
SaveFolder = "C:\Temp\xml\"
convFolder = "C:\Temp\xls\"
DateFormat = Format(itm.ReceivedTime, "yyyy-mm-dd HH-mm-ss ")
For Each objAtt In itm.Attachments
Debug.Print objAtt.FileName
objAtt.SaveAsFile SaveFolder & DateFormat & objAtt.FileName
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(SaveFolder)
If UCase(Right$(objAtt.FileName, Len("XML"))) = UCase("XML") Then
NewFileName = convFolder & DateFormat & objAtt.FileName & "_conv.xlsx"
Set ConvertThis = Workbooks.Open(SaveFolder & DateFormat & objAtt.FileName)
ConvertThis.SaveAs FileName:=NewFileName, FileFormat:= _
xlOpenXMLWorkbook
ConvertThis.Close
End If
Next
Set objAtt = Nothing
End Sub
To Test it, select the Email and run the following code
Public Sub Test_Rule()
Dim Item As MailItem
Set Item = ActiveExplorer.Selection.Item(1)
saveconvAttachtoDisk Item
Set Item = Nothing
End Sub

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