Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
VBA Script to extract outlook mail attachments and replace them with links
' Created this VB Script to extract the attachments.
' This is built on top of something I found in internet
' I couldn't locate that site again
Public Sub ReplaceAttachmentsToLink()
' Declarations
Dim olApp As Outlook.Application
Dim olSelection As Outlook.Selection
Dim olObject As Object
Dim olMail As Outlook.MailItem
Dim olMailProp As Outlook.UserProperty
Dim olAttachments As Outlook.Attachments
Dim olMailReceivedDate As String
Dim sFileSystem As Object
Dim sFileName As String
Dim sFullFileName As String
Dim sFolderPath As String
Dim sDeletedFiles As String
Dim i As Long
Dim j As Long
Dim iAttachmentsCount As Long
' Initialize all variables
Set olApp = CreateObject("Outlook.Application")
Set olSelection = olApp.ActiveExplorer.Selection
sFolderPath = "REPLACE_YOUR_TARGET_DIRECTORY"
Set sFileSystem = CreateObject("Scripting.FileSystemObject")
Debug.Print "===Started=="
' Precondition to fail quickly
If (Not (olApp.ActiveExplorer.CurrentFolder.FolderPath Like "*REPLACE_MAIL_FOLDER*")) Then
GoTo ExitSub
End If
For Each olObject In olSelection
If Not (olObject.Class = OlObjectClass.olMail) Then
GoTo NextMail
End If
Set olMail = olObject
olMailReceivedDate = Replace(Replace(olMail.ReceivedTime, "#", ""), ":", "")
Debug.Print "=>" & olMail.Subject
Set olAttachments = olMail.Attachments
iAttachmentsCount = olAttachments.Count
If iAttachmentsCount = 0 Then
GoTo NextMail
End If
' 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 = iAttachmentsCount To 1 Step -1
' Quick fail by attachment size.
' Save the attachment only if the size of attachment is more han 500k
If (olAttachments.Item(i).Size < 524288) Then
GoTo NextAttachment
End If
If Not (olAttachments.Item(i).Type = olByValue) Then
GoTo NextAttachment
End If
' Save attachment before deleting from item.
sFileName = olAttachments.Item(i).FileName
sFullFileName = sFolderPath & "\" & olMailReceivedDate & "-" & sFileName
If sFileSystem.fileExists(sFullFileName) Then
For j = 1 To 10 Step 1
sFullFileName = sFolderPath & "\" & olMailReceivedDate & "-" & j & "_" & sFileName
If Not (sFileSystem.fileExists(sFullFileName)) Then
Exit For
End If
Next
End If
Debug.Print "==>" & sFullFileName
olAttachments.Item(i).SaveAsFile sFullFileName
' Delete the attachment.
olAttachments.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 olMail.BodyFormat <> olFormatHTML Then
sDeletedFiles = sDeletedFiles & vbCrLf & "<file://" & sFullFileName & ">"
Else
sDeletedFiles = sDeletedFiles & "<br>" & "<a href='file://" & sFullFileName & "'>" & sFullFileName & "</a>"
End If
NextAttachment:
Next i
If (sDeletedFiles = vbNullString) Then
GoTo NextMail
End If
Set olMailProp = olMail.UserProperties.Find("AttachExtractScriptDt")
If (olMailProp Is Nothing) Then
Set olMailProp = olMail.UserProperties.Add("AttachExtractScriptDt", olText)
End If
olMailProp.Value = CStr(Now())
' Adds the filename string to the message body and save it Check for HTML body
If olMail.BodyFormat <> olFormatHTML Then
olMail.Body = olMail.Body & vbCrLf & "#### The file(s) were saved to " & sDeletedFiles & "####"
Else
olMail.HTMLBody = olMail.HTMLBody & "<p> ####" & "The file(s) were saved to " & sDeletedFiles & "#### </p>"
End If
olMail.Save
NextMail:
' Sets the attachment path to nothing before it moves on to the next message.
Set olMail = Nothing
olMailReceivedDate = vbNullString
Set olMailProp = Nothing
Set olAttachments = Nothing
sFileName = vbNullString
sFullFileName = vbNullString
iAttachmentsCount = 0
sDeletedFiles = vbNullString
Next 'olMail
ExitSub:
Set olSelection = Nothing
Set olApp = Nothing
Debug.Print "===Completed=="
End Sub
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.