killer
06-01-2017, 04:59 AM
I have the code below - which I obtained online and have slightly adapted - to save all attachments from an open Outlook email to a folder created fro the subject field of the email. This works fine except if there is a duplicate filename it's overwriting the existing file. I would like it to create a separate version.
I've searched and found various solutions, but I'm struggling to see how to implement them within 'my' code. Can anyone advise please?
It does occur to me I may need to ask a different question: "How do I get Windows (or VBA) to not overwrite existing files?" (I've read the FAQs befoe posting!).
And just one added complication, I will also want this same macro to rename files depending on their existing name, for example, if the filename begins "F1" rename it to "Front".
Any help greatly appreciated!
Thanks
Steve
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 = 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.
' the attachments folder hard-coded in as it does not correspond to the user's defaul Documents folder.
strFolderpath = "C:\Users\Costa\3. Pending Jobs_Surveys\"
'MsgBox strFolderpath
' Check each selected item for attachments.
' If attachments exist, save them to the Temp
' 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
'MsgBox 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
If Len(Dir(strFolderpath & objMsg.Subject, vbDirectory)) = 0 Then
MkDir strFolderpath & objMsg.Subject
End If
' Combine with the path to the folder.
strFile = strFolderpath & objMsg.Subject & "\" & 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
'MsgBox strDeletedFiles
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 & "<p>" & _
"The file(s) were saved to " & strDeletedFiles
End If
objMsg.Save
End If
Next
ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub ' SaveAttachments
I've searched and found various solutions, but I'm struggling to see how to implement them within 'my' code. Can anyone advise please?
It does occur to me I may need to ask a different question: "How do I get Windows (or VBA) to not overwrite existing files?" (I've read the FAQs befoe posting!).
And just one added complication, I will also want this same macro to rename files depending on their existing name, for example, if the filename begins "F1" rename it to "Front".
Any help greatly appreciated!
Thanks
Steve
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 = 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.
' the attachments folder hard-coded in as it does not correspond to the user's defaul Documents folder.
strFolderpath = "C:\Users\Costa\3. Pending Jobs_Surveys\"
'MsgBox strFolderpath
' Check each selected item for attachments.
' If attachments exist, save them to the Temp
' 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
'MsgBox 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
If Len(Dir(strFolderpath & objMsg.Subject, vbDirectory)) = 0 Then
MkDir strFolderpath & objMsg.Subject
End If
' Combine with the path to the folder.
strFile = strFolderpath & objMsg.Subject & "\" & 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
'MsgBox strDeletedFiles
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 & "<p>" & _
"The file(s) were saved to " & strDeletedFiles
End If
objMsg.Save
End If
Next
ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub ' SaveAttachments