I am trying to create a macro that can save my email attachments with a link to the attachment in the original email. I would also like the attachments have the date received in the file name, and if there are two files received on the same day then any duplicates could have a (2) at the end of the file name (or 3, 4, etc.).
Below is the code I am trying to work with
Sub SaveAllAttachments()
Const msoFileDialogFolderPicker = 4
Dim olkMsg As Object, intIdx As Integer, excApp As Object, strPath As String, strBuffer As String
Set excApp = CreateObject("Excel.Application")
With excApp.FileDialog(msoFileDialogFolderPicker)
.Show
For intIdx = 1 To .SelectedItems.count
strPath = .SelectedItems(intIdx)
Next
End With
If strPath <> "" Then
For Each olkMsg In Application.ActiveExplorer.Selection
For intIdx = olkMsg.Attachments.count To 1 Step -1
If Not IsHiddenAttachment(olkMsg.Attachments.Item(intIdx)) Then
olkMsg.Attachments.Item(intIdx).SaveAsFile strPath & "\" & olkMsg.Attachments.Item(intIdx).FILENAME
strBuffer = strBuffer & "<a href=""" & strPath & "\" & olkMsg.Attachments.Item(intIdx).FILENAME & """>" & olkMsg.Attachments.Item(intIdx).FILENAME & "</a>" & vbCrLf
End If
Next
Select Case olkMsg.BodyFormat
Case olFormatHTML
If Len(strBuffer) > 0 Then
strBuffer = Left(strBuffer, Len(strBuffer) - 1)
strBuffer = Replace(strBuffer, vbCrLf, "<br>")
olkMsg.HTMLBody = olkMsg.HTMLBody & "<p>Saved Attachments & <br><br>" & strBuffer & "</p>"
End If
Case Else
If Len(strBuffer) > 0 Then
strBuffer = Left(strBuffer, Len(strBuffer) - 1)
olkMsg.Body = olkMsg.Body & vbCrLf & vbCrLf & "Saved Attachments" & vbCrLf & vbCrLf & strBuffer
End If
End Select
olkMsg.Close olSave
Set olkMsg = Nothing
Next
End If
Set excApp = Nothing
End Sub
Private Function IsHiddenAttachment(olkAttachment As Outlook.Attachment) As Boolean
'Purpose: Determines if an attachment is embedded.'
'Written: 10/12/2010'
'Outlook: 2007'
Dim olkPA As Outlook.PropertyAccessor
On Error Resume Next
Set olkPA = olkAttachment.PropertyAccessor
IsHiddenAttachment = olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x7ffe000b")
On Error GoTo 0
Set olkPA = Nothing
End Function
Thank you for your time.
Bookmarks