Skip to content

Instantly share code, notes, and snippets.

@pravynandas
Created March 2, 2023 14:41
Show Gist options
  • Save pravynandas/918124a058ed5284eca3f2e6b8f08adb to your computer and use it in GitHub Desktop.
Save pravynandas/918124a058ed5284eca3f2e6b8f08adb to your computer and use it in GitHub Desktop.
Outlook VBA Macro - Save Email and Attachments to Disk
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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment