VBA Script to extract outlook mail attachments and replace them with links

AttachmentExtractor.vbs

' 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