Save Outlook attachments

[admin]

Code: Select all

Option Explicit

Dim objOutlook, objSelection, objItem, objAttachment
Dim objFSO, strBaseFolder, strCleanSubject, strDatePrefix, strTargetFolder

' Define your main destination folder path (MUST end with a backslash)
strBaseFolder = "C:\Your\Folder\Path\Here\"

Set objFSO = CreateObject("Scripting.FileSystemObject")

' Create base folder if it doesn't exist
If Not objFSO.FolderExists(strBaseFolder) Then
    objFSO.CreateFolder(strBaseFolder)
End If

On Error Resume Next
' Connect to the currently running instance of Outlook
Set objOutlook = GetObject(, "Outlook.Application")
On Error GoTo 0

If objOutlook Is Nothing Then
    WScript.Echo "Error: Outlook must be running to use this script."
    WScript.Quit
End If

' Get the user's current selection in Outlook
Set objSelection = objOutlook.ActiveExplorer.Selection

If objSelection.Count = 0 Then
    WScript.Echo "No emails selected. Please select emails in Outlook first."
    WScript.Quit
End If

' Loop through all selected items
For Each objItem In objSelection
    ' TypeName checks if the item is a mail message (equivalent to TypeOf in VBA)
    If TypeName(objItem) = "MailItem" Then
        
        ' Process only if the email has attachments
        If objItem.Attachments.Count > 0 Then
            
            ' Format the date as YYYY-MM-DD using VBScript functions
            strDatePrefix = Year(objItem.ReceivedTime) & "-" & _
                            Right("0" & Month(objItem.ReceivedTime), 2) & "-" & _
                            Right("0" & Day(objItem.ReceivedTime), 2)
            
            strCleanSubject = objItem.Subject
            
            ' Clean forbidden characters from the subject to prevent folder errors
            strCleanSubject = Replace(strCleanSubject, "\", "_")
            strCleanSubject = Replace(strCleanSubject, "/", "_")
            strCleanSubject = Replace(strCleanSubject, ":", "_")
            strCleanSubject = Replace(strCleanSubject, "*", "_")
            strCleanSubject = Replace(strCleanSubject, "?", "_")
            strCleanSubject = Replace(strCleanSubject, """", "_")
            strCleanSubject = Replace(strCleanSubject, "<", "_")
            strCleanSubject = Replace(strCleanSubject, ">", "_")
            strCleanSubject = Replace(strCleanSubject, "|", "_")
            strCleanSubject = Trim(strCleanSubject)
            
            ' Limit subject length to avoid path errors
            If Len(strCleanSubject) > 100 Then
                strCleanSubject = Left(strCleanSubject, 100)
            End If
            
            ' Combine date and clean subject for the folder name
            strTargetFolder = strBaseFolder & strDatePrefix & " - " & strCleanSubject & "\"
            
            ' Create the unique folder if it doesn't exist
            If Not objFSO.FolderExists(strTargetFolder) Then
                objFSO.CreateFolder(strTargetFolder)
            End If
            
            ' Save each attachment in the new folder
            For Each objAttachment In objItem.Attachments
                objAttachment.SaveAsFile strTargetFolder & objAttachment.FileName
            Next
        End If
    End If
Next

WScript.Echo "Attachments organized and saved successfully!"

' Clean up memory
Set objFSO = Nothing
Set objOutlook = Nothing
Set objSelection = Nothing