Outlook VBA Macro - Save Email and Attachments to Disk

modSaveMail.bas

Option Explicit

Private Const gAttachmentSizeMin As Long = 10240 '10 KB

Public Sub Backup_Email(ByRef objMsg As Outlook.MailItem)
    Dim objOL As Outlook.Application
    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
    Dim objFSO As FileSystemObject
    Dim sMsgTimeStamp As String
    Dim sMsgSubject As String
    Dim sDataInputPath As String
    Dim sJobName As String
    Dim sName As String
    Dim sRemotePath As String
    Dim originalMsgPath As String
    
    log vbCrLf & "=================================== [" & objMsg.ReceivedTime & "] " & objMsg.Subject & " =============================================="
    
    Set objFSO = New FileSystemObject

    ' 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 = Application

    ' Get the collection of selected objects.
    Set objSelection = objOL.ActiveExplorer.Selection

    ' The attachment folder needs to exist
    ' You can change this to another folder name of your choice

    ' Set the Attachment folder.
    strFolderpath = strFolderpath & "\OLAttachments\"

    sMsgTimeStamp = SerializeDate(objMsg.ReceivedTime)
    sMsgSubject = ReplaceCharsForFileName(objMsg.Subject)

    ' Combine with the path to the Temp folder.
    strFolderpath = strFolderpath & sMsgTimeStamp & " " & sMsgSubject
    
    If Not objFSO.FolderExists(strFolderpath) Then
        objFSO.CreateFolder strFolderpath
        log "Folder [" & strFolderpath & "] created."
    Else
        log "Folder [" & strFolderpath & "] exists."
    End If
            
    originalMsgPath = strFolderpath & "\original.msg"
    If Not objFSO.FileExists(originalMsgPath) Then
        objMsg.SaveAs originalMsgPath, olMSG
        log "Original Msg [" & originalMsgPath & "] saved."
    Else
        log "Original Msg [" & originalMsgPath & "] exists."
    End If

    Set objAttachments = objMsg.Attachments
    lngCount = objAttachments.Count
        
    If lngCount > 0 Then
        
        log "Total Attachments: " & lngCount
        For i = lngCount To 1 Step -1
        
            'To filter files less than 10KB
            If objAttachments.Item(i).Size <= gAttachmentSizeMin Then
                log "Attachment Size is less than threshold (" & CInt((gAttachmentSizeMin / 1024)) & " KB). Ignoring"
            Else
            
                ' Get the file name.
                sName = objAttachments.Item(i).FileName
                
                'Add index of the attachment for random-ness
                If i < 10 Then
                    sName = "0" & i & " " & sName
                Else
                    sName = i & " " & sName
                End If
                
                strFile = strFolderpath & "\" & sName
                
                If Not objFSO.FileExists(strFile) Then
                    ' Save the attachment as a file.
                    objAttachments.Item(i).SaveAsFile strFile
                    log "File [" & strFile & "] saved."
                Else
                    log "File [" & strFile & "] exists."
                End If
                
            End If
        
        Next i
    End If
ExitSub:

    Set objAttachments = Nothing
    Set objMsg = Nothing
    Set objSelection = Nothing
    Set objOL = Nothing
End Sub


Private Function SerializeDate(dtDate As Variant) As String
    SerializeDate = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, vbUseSystem) & _
                Format(dtDate, "hhnnss", vbUseSystemDayOfWeek, vbUseSystem)
End Function

Private Function ReplaceCharsForFileName(ByVal sSubject As String, Optional sChr As String = "_") As String
  sSubject = Replace(sSubject, "Fwd: ", "")
  sSubject = Replace(sSubject, "FWD: ", "")
  sSubject = Replace(sSubject, "Fw: ", "")
  sSubject = Replace(sSubject, "FW: ", "")
  sSubject = Replace(sSubject, "Re: ", "")
  sSubject = Replace(sSubject, "RE: ", "")
  sSubject = Trim(sSubject)
  
  sSubject = Replace(sSubject, "'", sChr)
  sSubject = Replace(sSubject, "*", sChr)
  sSubject = Replace(sSubject, "/", sChr)
  sSubject = Replace(sSubject, "\", sChr)
  sSubject = Replace(sSubject, ":", sChr)
  sSubject = Replace(sSubject, "?", sChr)
  sSubject = Replace(sSubject, Chr(34), sChr)
  sSubject = Replace(sSubject, "<", "[")
  sSubject = Replace(sSubject, ">", "]")
  sSubject = Replace(sSubject, "|", sChr)
  
  ReplaceCharsForFileName = Trim(Left(sSubject, 70))
End Function


Private Function log(m As String)
    Debug.Print m
End Function