I found numerous examples of VBA scripts to automatically move attachments to my hard drive. This one I've found online works when I run the macro in Outlook as is, but will not work when I set it to a rule.
When I run the macro without the "item as outlook.mailitem" parameter in the sub header and have the email containing the file I want saved selected, it will function properly.
However, as soon as I add that information so I can run it as a rule, outlook throws an error and it disables the rule.
Option Explicit
Public Sub moveAttachmentsAlpha(item As Outlook.MailItem)
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String
' Get the path to your My Documents folder
strFolderpath = "C:\DailyFlash\"
On Error Resume Next
' Instantiate an Outlook Application object.
Set objOL = CreateObject("Outlook.Application")
' Get the collection of selected objects.
Set objSelection = objOL.ActiveExplorer.Selection
' Check each selected item for attachments. If attachments exist,
' save them to the strFolderPath folder and strip them from the item.
For Each objMsg In objSelection
' This code only strips attachments from mail items.
' If objMsg.class=olMail Then
' Get the Attachments collection of the item.
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
strDeletedFiles = ""
If lngCount > 0 Then
' We need to use a count down loop for removing items
' from a collection. Otherwise, the loop counter gets
' confused and only every other item is removed.
For i = lngCount To 1 Step -1
' Save attachment before deleting from item.
' Get the file name.
strFile = objAttachments.item(i).FileName
' Combine with the path to the Temp folder.
strFile = strFolderpath & strFile
' Save the attachment as a file.
objAttachments.item(i).SaveAsFile strFile
'write the save as path to a string to add to the message
'check for html and use html tags in link
If objMsg.BodyFormat <> olFormatHTML Then
strDeletedFiles = strDeletedFiles & vbCrLf & "<file://" & strFile & ">"
Else
strDeletedFiles = strDeletedFiles & "<br>" & "<a href='file://" & _
strFile & "'>" & strFile & "</a>"
End If
'Use the MsgBox command to troubleshoot. Remove it from the final code.
'MsgBox strDeletedFiles
Next i
' Adds the filename string to the message body and save it
' Check for HTML body
If objMsg.BodyFormat <> olFormatHTML Then
objMsg.Body = vbCrLf & "The file(s) were saved to " & strDeletedFiles & vbCrLf & objMsg.Body
Else
objMsg.HTMLBody = "<p>" & "The file(s) were saved to " & strDeletedFiles & "</p>" & objMsg.HTMLBody
End If
objMsg.Save
End If
Next
ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub
Keep most of the script. Remove the reference to Outlook.Selection and the for loop associated to it. Then, in it's place, assign item to objMsg to allow the rest of the of the script to function as normal. After testing I have decided to steal it and use it myself as well.
Public Sub moveAttachmentsAlpha(item As Outlook.MailItem)
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String
' Get the path to your My Documents folder
strFolderpath = "C:\temp\"
On Error Resume Next
Set objMsg = item
' This code only strips attachments from mail items.
' If objMsg.class=olMail Then
' Get the Attachments collection of the item.
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
strDeletedFiles = ""
If lngCount > 0 Then
' We need to use a count down loop for removing items
' from a collection. Otherwise, the loop counter gets
' confused and only every other item is removed.
For i = lngCount To 1 Step -1
' Save attachment before deleting from item.
' Get the file name.
strFile = objAttachments.item(i).FileName
' Combine with the path to the Temp folder.
strFile = strFolderpath & strFile
' Save the attachment as a file.
objAttachments.item(i).SaveAsFile strFile
'write the save as path to a string to add to the message
'check for html and use html tags in link
If objMsg.BodyFormat <> olFormatHTML Then
strDeletedFiles = strDeletedFiles & vbCrLf & "<file://" & strFile & ">"
Else
strDeletedFiles = strDeletedFiles & "<br>" & "<a href='file://" & _
strFile & "'>" & strFile & "</a>"
End If
Next i
' Adds the filename string to the message body and save it
' Check for HTML body
If objMsg.BodyFormat <> olFormatHTML Then
objMsg.Body = vbCrLf & "The file(s) were saved to " & strDeletedFiles & vbCrLf & objMsg.Body
Else
objMsg.HTMLBody = "<p>" & "The file(s) were saved to " & strDeletedFiles & "</p>" & objMsg.HTMLBody
End If
objMsg.Save
End If
ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub
FYI: I changed nothing after the line ' This code only strips attachments from mail items. Except for a Next
Related
referring to the amazing script found here Save Outlook attachment to disk
I'd like to filter attachments on size. I am using the script for a while now, but the script also saves company logo's etc. This gives numerous 1kb files and changes the mail layout.
I would like the script to ignore files smaller than 10kb. Is there anyone who can help me implement this in the script below;
Public Sub SaveAttachments()
Dim objOL As Outlook.Application
Dim pobjMsg As Outlook.MailItem 'Object
Dim objSelection As Outlook.Selection
' Get the path to your My Documents folder
strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
On Error Resume Next
' Instantiate an Outlook Application object.
Set objOL = CreateObject("Outlook.Application")
' Get the collection of selected objects.
Set objSelection = objOL.ActiveExplorer.Selection
For Each pobjMsg In objSelection
SaveAttachments_Parameter pobjMsg
Next
ExitSub:
Set pobjMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub
Public Sub SaveAttachments_Parameter(objMsg As MailItem)
Dim objAttachments As Outlook.Attachments
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String
' Get the path to your My Documents folder
strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
On Error Resume Next
' Set the Attachment folder.
strFolderpath = "\\path\"
' Get the Attachments collection of the item.
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
If lngCount > 0 Then
' We need to use a count down loop for removing items
' from a collection. Otherwise, the loop counter gets
' confused and only every other item is removed.
For i = lngCount To 1 Step -1
' Save attachment before deleting from item.
' Get the file name.
strFile = objAttachments.Item(i).FileName
'=======================================================
tempstr = strFile 'strtoclean
charArray = Array("?", "/", "\", ":", "*", """", "<", ">", ",", "&", "#", "~", "%", "{", "}", "+", "_")
For Each tmpChar In charArray
Select Case tmpChar
Case "&"
changeTo = " and "
Case ":"
changeTo = "-"
Case Else
changeTo = " "
End Select
tempstr = Replace(tempstr, tmpChar, changeTo)
Next
strFile = tempstr
'==========================================================
' Combine with the path to the Temp folder.
strFile = strFolderpath & Format(objMsg.ReceivedTime, "yyyy-MM-dd h-mm-ss") & "." & strFile
' Save the attachment as a file.
objAttachments.Item(i).SaveAsFile strFile
' Delete the attachment.
objAttachments.Item(i).Delete
'write the save as path to a string to add to the message
'check for html and use html tags in link
If objMsg.BodyFormat <> olFormatHTML Then
strDeletedFiles = strDeletedFiles & vbCrLf & "<file://" & strFile & ">"
Else
strDeletedFiles = strDeletedFiles & "<br>" & "<a href='file://" & strFile & "'>" & strFile & "</a>"
End If
Next i
End If
' Adds the filename string to the message body and save it
' Check for HTML body
If objMsg.BodyFormat <> olFormatHTML Then
objMsg.Body = objMsg.Body & vbCrLf & _
"The file(s) were saved to " & strDeletedFiles
Else
objMsg.HTMLBody = objMsg.HTMLBody & "" & _
"The file(s) were saved to " & strDeletedFiles & ""
End If
objMsg.Save
ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objOL = Nothing
End Sub
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
End Sub
There is the Attachment.Size property which might help.
You can do
For i = lngCount To 1 Step -1
if objAttachments.Item(i).Size >= 10240 then
...
end if
Next i
I am working on a Outlook script that will automatically select an email, and download the attachments, from a specific sender.
Reports are generated on a database and emailed to a specified address.
The next step is to automatically download those reports to a specified folder. Currently if an email comes in from the specified sender the script downloads attachments from the currently selected email.
I need the script to run on the email that triggers the script.
Public Sub SaveAttachments(Item As Outlook.MailItem)
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String
'Get the path to the target folder
strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
On Error Resume Next
'Instantiate an Outlook Application Object
Set objOL = CreateObject("Outlook.Application")
'Get the collection of selected objects
Set objSelection = objOL.ActiveExplorer.Selection
'Set the Attachment folder
strFolderpath = strFolderpath & "\Attachments\"
'Check each selected item for attachements. If attachments exist, save them
'to the strFOlderPath folder and strip them from the item.
For Each objMsg In objSelection
'This code only strips attachments from mail items.
'If objMsg.class=olMail Then
'Get the Attachments collection of the item
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
strDeletedFile = ""
If lngCount > 0 Then
'A count down loop needs to be used for removing items
'from a collection. Otherwise the loop counter gets
'confused and only every other item is removed
For i = lngCount To 1 Step -1
'Save attachment before deleting from item.
'Get the file name
strFile = objAttachments.Item(i).FileName
'Combine with the path to the Temp folder.
strFile = strFolderpath & strFile
'Save the attachment as a file
objAttachments.Item(i).SaveAsFile strFile
'Delete the attachment
objAttachments.Item(i).Delete
'write the save as path to a string to add to the
'message check from html and use html tags in link
If objMsg.BodyFormat <> olFormatHTML Then
strDeletedFile = strDeletedFiles & vbCrLf & "<file://" & strFile & ">"
Else
strDeletedFiles = strDeletedFiles & "<br>" & "<a href='file://" & _
strFile & "'>" & strFile & "</a>"
End If
'use the MsgBox command to troubleshoot. Remove it from the final code.
'MsgBox strDeletedFiles
Next i
'Adds the filename string to the message body and save it
'Checks for HTML body
If objMsg.BodyFormat <> olFormatHTML Then
objMsg.Body = vbCrLf & "The File(s) were saved to " & strDeletedFiles & vbCrLf & objMsg.Body
Else
objMsg.HTMLBody = "<p>" & "The file(s) were saved to " & strDeletedFiles & "</p>" & objMsg.HTMLBody
End If
objMsg.Save
End If
Next
Exit Sub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub
I made some changes and this code does the intended purpose.
Public Sub SaveAttachments(Item As Outlook.MailItem)
Dim objOL As Outlook.Application
Dim objAttachments As Outlook.Attachments
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String
'Get the path to the target folder
strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
On Error Resume Next
'Instantiate an Outlook Application Object
Set objOL = CreateObject("Outlook.Application")
'Set the Attachment folder
strFolderpath = strFolderpath & "\Attachments\"
'Check each selected item for attachements. If attachments exist, save them
'to the strFOlderPath folder and strip them from the item.
For Each objAttachments In Item.Attachments
'This code only strips attachments from mail items.
'If objMsg.class=olMail Then
'Get the Attachments collection of the item
Set objAttachments = Item.Attachments
lngCount = objAttachments.Count
strDeletedFile = ""
If lngCount > 0 Then
'A count down loop needs to be used for removing items
'from a collection. Otherwise the loop counter gets
'confused and only every other item is removed
For i = lngCount To 1 Step -1
'Save attachment before deleting from item.
'Get the file name
strFile = objAttachments.Item(i).FileName
'Combine with the path to the Temp folder.
strFile = strFolderpath & strFile
'Save the attachment as a file
objAttachments.Item(i).SaveAsFile strFile
'Delete the attachment
objAttachments.Item(i).Delete
'write the save as path to a string to add to the
'message check from html and use html tags in link
If Item.BodyFormat <> olFormatHTML Then
strDeletedFile = strDeletedFiles & vbCrLf & "<file://" & strFile & ">"
Else
strDeletedFiles = strDeletedFiles & "<br>" & "<a href='file://" & _
strFile & "'>" & strFile & "</a>"
End If
'use the MsgBox command to troubleshoot. Remove it from the final code.
'MsgBox strDeletedFiles
Next i
'Adds the filename string to the message body and save it
'Checks for HTML body
If Item.BodyFormat <> olFormatHTML Then
Item.Body = vbCrLf & "The File(s) were saved to " & strDeletedFiles & vbCrLf & Item.Body
Else
Item.HTMLBody = "<p>" & "The file(s) were saved to " & strDeletedFiles & "</p>" & Item.HTMLBody
End If
Item.Save
End If
Next objAttachments
Exit Sub:
Set objAttachments = Nothing
Set objOL = Nothing
End Sub
To apply code to the item, do not select anything.
Instead use Item passed in (Item As MailItem).
In the question and the answer posted by the OP, if strFolderpath does not exist, the error when saving will be bypassed.
The attachments will be unrecoverably deleted without being saved.
This is due to improper use of On Error Resume Next.
"There are specific occasions when this is useful. Most of the time you should avoid using it."
https://excelmacromastery.com/vba-error-handling#On_Error_Resume_Next
Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
' If desperate declare as Variant
Private Sub test()
SaveAttachments ActiveInspector.currentItem
End Sub
Public Sub SaveAttachments(Item As MailItem)
'Check the Item passed in (Item As MailItem) for attachments.
'
'If attachments exist,
' save them to the strFolderpath folder and
' strip them from the item.
Dim objAttachment As Attachment
Dim objAttachments As Attachments
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String
'Get the path to the target folder
strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
Debug.Print strFolderpath
'Set the Attachment folder
strFolderpath = strFolderpath & "\Attachments\"
Debug.Print strFolderpath
'Get the Attachments collection of the item
Set objAttachments = Item.Attachments
lngCount = objAttachments.Count
'A count down loop for removing items, through move or delete, from a collection.
'Otherwise only every other item is removed.
For i = lngCount To 1 Step -1
'Save attachment before deleting from item.
'Get the file name
strFile = objAttachments(i).fileName
Debug.Print strFile
'Combine the path to the folder with file name.
strFile = strFolderpath & strFile
Debug.Print strFile
'Save the attachment as a file
'If strFolderpath does not exist there will be an error.
'This is good.
objAttachments.Item(i).SaveAsFile strFile
'Delete the attachment
' Uncomment after verifying attachments are being saved
'objAttachments.Item(i).Delete
'Write the save as path to a string to add to the message
'Check from html and use html tags in link
If Item.BodyFormat <> olFormatHTML Then
strDeletedFiles = strDeletedFiles & vbCrLf & "<file://" & strFile & ">"
Else
strDeletedFiles = strDeletedFiles & "<br>" & "<a href='file://" & _
strFile & "'>" & strFile & "</a>"
End If
Next
'Add the filename string to the message body and save it
'Check for HTML body
If Item.BodyFormat <> olFormatHTML Then
Item.body = vbCrLf & "The File(s) were saved to " & strDeletedFiles & vbCrLf & Item.body
Else
Item.HtmlBody = "<p>" & "The file(s) were saved to " & strDeletedFiles & "</p>" & Item.HtmlBody
End If
Item.Display 'Item.Save
End Sub
You pass the mailitem that triggers the script as a parameter.
If, for example, you pass Item then process Item.
Sub CustomMailMessageRule(Item As MailItem)
MsgBox "Mail message arrived: " & Item.Subject
End Sub
I am trying to save outlook attachments to a folder and where the filename already exists save the newer file under a different name so as not to save over the existing file....perhaps just give an extension "v2" or even "v3" if "v2" exists.
I came across this answer but am finding that the newer file is saved over the existing file
Save attachments to a folder and rename them
I have used the below code;
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String
' Get the path to your My Documents folder
strFolderpath = "C:\Users\Owner\my folder is here"
On Error Resume Next
' Instantiate an Outlook Application object.
Set objOL = CreateObject("Outlook.Application")
' Get the collection of selected objects.
Set objSelection = objOL.ActiveExplorer.Selection
' Set the Attachment folder.
strFolderpath = strFolderpath & "\my subfolder is here\"
' Check each selected item for attachments. If attachments exist,
' save them to the strFolderPath folder and strip them from the item.
For Each objMsg In objSelection
' This code only strips attachments from mail items.
' If objMsg.class=olMail Then
' Get the Attachments collection of the item.
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
strDeletedFiles = ""
If lngCount > 0 Then
' We need to use a count down loop for removing items
' from a collection. Otherwise, the loop counter gets
' confused and only every other item is removed.
For i = lngCount To 1 Step -1
' Save attachment before deleting from item.
' Get the file name.
strFile = objAttachments.Item(i).FileName
' Combine with the path to the Temp folder.
strFile = strFolderpath & strFile
' Save the attachment as a file.
objAttachments.Item(i).SaveAsFile strFile
' Delete the attachment.
objAttachments.Item(i).Delete
'write the save as path to a string to add to the message
'check for html and use html tags in link
If objMsg.BodyFormat <> olFormatHTML Then
strDeletedFiles = strDeletedFiles & vbCrLf & "<file://" & strFile & ">"
Else
strDeletedFiles = strDeletedFiles & "<br>" & "<a href='file://" & _
strFile & "'>" & strFile & "</a>"
End If
'Use the MsgBox command to troubleshoot. Remove it from the final code.
'MsgBox strDeletedFiles
Next i
' Adds the filename string to the message body and save it
' Check for HTML body
If objMsg.BodyFormat <> olFormatHTML Then
objMsg.Body = vbCrLf & "The file(s) were saved to " & strDeletedFiles & vbCrLf & objMsg.Body
Else
objMsg.HTMLBody = "<p>" & "The file(s) were saved to " & strDeletedFiles & "</p>" & objMsg.HTMLBody
End If
objMsg.Save
End If
Next
ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub
I am relatively new to vba so perhaps the solution is there but am not seeing it!
Take a look at my code below. It goes through all of the items in a specific Outlook folder (that you designate), goes through each attachment in each item, and saves the attachment in a specified file path.
'Establish path of folder you want to save to
Dim FilePath As Variant
FilePath = "C:\Users\Owner\my folder is here\my subfolder is here\"
Set FSOobj = CreateObject("Scripting.FilesystemObject")
'If path doesn't exist, create it. If it does, either do nothing or delete its contents
If FSOobj.FolderExists(FilePath) = False Then
FSOobj.CreateFolder FilePath
Else
' This code is if you want to delete the items in the existing folder first.
' It's not necessary for your case.
On Error Resume Next
Kill FilePath & "*.*"
On Error GoTo 0
End If
'Establish Outlook folders, attachments, and other items
Dim msOutlook As Outlook.NameSpace 'Establish Outlook NameSpace
Dim Folder As Outlook.MAPIFolder 'Establish Folder as a MAPIFolder
Dim messageAttachments As Outlook.Attachments
Set msOutlook = Application.GetNamespace("MAPI")
'Set the folder that contains the email with the attachment
Set Folder = msOutlook.GetDefaultFolder(olFolderInbox).Folders("FOLDER NAME HERE")
Set folderItems = Folder.Items
Dim folderItemsCount As Long
folderItemsCount = folderItems.Count
Dim number as Integer
number = 1
For i = 1 To folderItemsCount
'If you want to pull the attachments on some criteria, like the Subject of the email or
'the date received, you need to write an IF statement like:
'If InStr(Folder.Items(i).Subject, "SPECIFIC SUBJECT TEXT") Then
Set messageAttachments = folderItems.item(i).Attachments
lngCount = messageAttachments.Count 'This lets you pull more than one attachment per message
For thisAttachment = 1 To lngCount
messageAttachments.item(thisAttachment).SaveAsFile FilePath & "YOUR_CHOSEN_FILENAME" & number & ".xlsx"
number = number + 1
Next thisAttachment
Next i
EDIT
In order to delete the items after scraping the attachments, you would use the same code as above except you would also include folderItems.item(i).Delete. Also, since you are moving items, I switched to looping backwards in your for loop as to not mess up your iteration. I've written it below:
For i = folderItemsCount To 1 Step -1
'If you want to pull the attachments on some criteria, like the Subject of the email or
'the date received, you need to write an IF statement like:
'If InStr(Folder.Items(i).Subject, "SPECIFIC SUBJECT TEXT") Then
Set messageAttachments = folderItems.item(i).Attachments
lngCount = messageAttachments.Count 'This lets you pull more than one attachment per message
For thisAttachment = 1 To lngCount
messageAttachments.item(thisAttachment).SaveAsFile FilePath & "YOUR_CHOSEN_FILENAME" & number & ".xlsx"
number = number + 1
Next thisAttachment
folderItems.item(i).Delete
Next i
I hope this helps!
I'm trying to create a macro where I can save the attachments from an email. The problem I'm currently having is that I want the macro to add the ReceivedTime of the email on the file name it saves (i.e.: File TESTSHEET.xls was received on 2016-01-01 3:02AM. I want the saved file to show 201601010302AM-TESTSHEET.xls or something similar)
Here's my current code:
Public itm As Object
Public Sub saveAttachtoDisk()
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
saveFolder = "C:\Users\Username\Documents\TEST REPORTS"
For Each objAtt In itm.Attachments
objAtt.SaveAsFile objAtt.DisplayName
Next objAtt
End Sub
Public Sub SaveAttachments()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim objDate As String
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim StrDate As String
Dim strFolderpath As String
Dim strDeletedFiles As String
Set itm = Application.CreateItem(olMailItem)
Dim CurrentMsg As Outlook.MailItem
' Get the path to your My Documents folder
strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
On Error Resume Next
' Instantiate an Outlook Application object.
Set objOL = CreateObject("Outlook.Application")
' Get the collection of selected objects.
Set objSelection = objOL.ActiveExplorer.Selection
' Set the Attachment folder.
strFolderpath = strFolderpath & "\TEST REPORTS\"
' Check each selected item for attachments. If attachments exist,
' save them to the strFolderPath folder and strip them from the item.
For Each objMsg In objSelection
' This code only strips attachments from mail items.
' If objMsg.class=olMail Then
' Get the Attachments collection of the item.
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
strDeletedFiles = ""
If lngCount > 0 Then
' We need to use a count down loop for removing items
' from a collection. Otherwise, the loop counter gets
' confused and only every other item is removed.
For i = lngCount To 1 Step -1
' Save attachment before deleting from item.
' Get the file name.
strFile = objAttachments.Item(i).FileName
' Combine with the path to the Save folder.
StrDate = Format(itm.ReceivedTime, "yyyy-mm-dd Hmm ")
strFile = strFolderpath & StrDate & strFile
' Save the attachment as a file.
MsgBox strFile
objAttachments.Item(i).SaveAsFile strFile
' Delete the attachment.
objAttachments.Item(i).Delete
'write the save as path to a string to add to the message
'check for html and use html tags in link
If objMsg.BodyFormat <> olFormatHTML Then
strDeletedFiles = strDeletedFiles & vbCrLf & "<file://" & strFile & ">"
Else
strDeletedFiles = strDeletedFiles & "<br>" & "<a href='file://" & _
strFile & "'>" & strFile & "</a>"
End If
'Use the MsgBox command to troubleshoot. Remove it from the final code.
'MsgBox strDeletedFiles
Next i
' Adds the filename string to the message body and save it
' Check for HTML body
If objMsg.BodyFormat <> olFormatHTML Then
objMsg.Body = vbCrLf & "The file(s) were saved to " & strDeletedFiles & vbCrLf & objMsg.Body
Else
objMsg.HTMLBody = "<p>" & "The file(s) were saved to " & strDeletedFiles & "</p>" & objMsg.HTMLBody
End If
objMsg.Save
End If
Next
ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub
Thank you in advance for your help!!
Use objMsg not itm.
' StrDate = Format(itm.ReceivedTime, "yyyy-mm-dd Hmm ")
StrDate = Format(objMsg.ReceivedTime, "yyyy-mm-dd Hmm ")
Additionally drop other code with itm and as well objOL
' Set itm = Application.CreateItem(olMailItem)
' Dim CurrentMsg As Outlook.MailItem
' On Error Resume Next
' Instantiate an Outlook Application object.
' Set objOL = CreateObject("Outlook.Application")
Do not use On Error Resume Next until you know what you are doing.
I'm setting up a script in outlook that saves some PDF attachments as the date they were received. This will save the file to the desired location but it wont name it as the date received how would i add this in?
There is probably a lot of unused code in here as i got it from another website and have removed a few things i don't want such as deleting the attachment after its saved.
Public Sub SaveAttachments()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String
' Get the path to your My Documents folder
strFolderpath = "D:\Documents\"
On Error Resume Next
' Instantiate an Outlook Application object.
Set objOL = CreateObject("Outlook.Application")
' Get the collection of selected objects.
Set objSelection = objOL.ActiveExplorer.Selection
' Set the Attachment folder.
strFolderpath = strFolderpath
' Check each selected item for attachments. If attachments exist,
' save them to the strFolderPath folder and strip them from the item.
For Each objMsg In objSelection
' This code only strips attachments from mail items.
' If objMsg.class=olMail Then
' Get the Attachments collection of the item.
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
strDeletedFiles = ""
If lngCount > 0 Then
' We need to use a count down loop for removing items
' from a collection. Otherwise, the loop counter gets
' confused and only every other item is removed.
For i = lngCount To 1 Step -1
' Save attachment before deleting from item.
' Get the file name.
strFile = objAttachments.Item(i).FileName
' Combine with the path to the Temp folder.
strFile = strFolderpath & strFile
' Save the attachment as a file.
objAttachments.Item(i).SaveAsFile strFile
'write the save as path to a string to add to the message
'check for html and use html tags in link
If objMsg.BodyFormat <> olFormatHTML Then
strDeletedFiles = strDeletedFiles & vbCrLf & "<file://" & strFile & ">"
Else
strDeletedFiles = strDeletedFiles & "<br>" & "<a href='file://" & _
strFile & "'>" & strFile & "</a>"
End If
'Use the MsgBox command to troubleshoot. Remove it from the final code.
'MsgBox strDeletedFiles
Next i
' Adds the filename string to the message body and save it
' Check for HTML body
If objMsg.BodyFormat <> olFormatHTML Then
objMsg.Body = vbCrLf & "The file(s) were saved to " & strDeletedFiles & vbCrLf & objMsg.Body
Else
objMsg.HTMLBody = "<p>" & "The file(s) were saved to " & strDeletedFiles & "</p>" & objMsg.HTMLBody
End If
objMsg.Save
End If
Next
ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub
Anything you want to change with the filename would be in this modified snippet,
strFile = strFolderpath & objAttachments.Item(i).FileName 'Add the folder and filename
strFile = left(strfile, len(strFile)-4) 'Strip the .PDF
strFile = strFile & format(Date, "MMddYYYY") & ".PDF" 'Add the date and readd .PDF
objAttachments.Item(i).SaveAsFile strFile
For different date formatting to try out, check out this
add the following function to your code:
Function Dateiendung(vDateiname As String) As String
Dim Wortlaenge As Integer
Dim StellePunkt As Integer
Wortlaenge = Len(vDateiname) ' Anzahl Zeichen des Dateinamens
StellePunkt = InStrRev(vDateiname, ".") ' Anzahl Zeichen vor dem letzten Punkt
Dateiendung = Right(vDateiname, Wortlaenge - StellePunkt) ' Dateiendung wird extrahiert
End Function
add this line at the beginning of your code:
dim fileext as string
Instead of:
strFile = objAttachments.Item(i).FileName
you have to put:
fileext = Dateiendung(objMailSel.Attachments.item(i).FileName)
strfile = Mid(objMailSel.Attachments.item(i).FileName, 1, Len(objMailSel.Attachments.item(i).FileName) - Len(fileext) - 1) & " " & Format(Date, "MMddYYYY") & " ." & fileext