Microsoft Office Forums - View Single Post - [Solved] How can I save all attachments in a folder with specific criteria?

gmayor · 11-12-2015, 06:55 AM

The following will save the attachments in a named folder which it will create if not present (it may not work with a network folder that has not been mapped to a Windows drive letter.).

You can either process an individual message already received or run the main 'SaveAttachments' process from a rule as the messages arrive.

The macro does not overwrite existing files of the same name (if you don't want that remove the line -

Code:

strFname = FileNameUnique(strSaveFldr, strFname, strExt)

and the associated functions. Though I recommend that you don't.

Code:

Option Explicit

Sub ProcessAttachment()
'An Outlook macro by Graham Mayor
Dim olMsg As MailItem
    On Error Resume Next
    Set olMsg = ActiveExplorer.Selection.Item(1)
    SaveAttachments olMsg
lbl_Exit:
    Exit Sub
End Sub

Private Sub SaveAttachments(olItem As MailItem)
'An Outlook macro by Graham Mayor
Dim olAttach As Attachment
Dim strFname As String
Dim strExt As String
Dim j As Long
Const strSaveFldr As String = "D:\Path\Reports\"

    CreateFolders strSaveFldr
    On Error GoTo CleanUp
    If olItem.Attachments.Count > 0 Then
        For j = olItem.Attachments.Count To 1 Step -1
            Set olAttach = olItem.Attachments(j)
            If Not olAttach.FileName Like "image*.*" Then
                strFname = olAttach.FileName
                strExt = Right(strFname, Len(strFname) - InStrRev(strFname, Chr(46)))
                strFname = FileNameUnique(strSaveFldr, strFname, strExt)
                olAttach.SaveAsFile strSaveFldr & strFname
                'olAttach.Delete        'delete the attachment
            End If
        Next j
        olItem.Save
    End If
CleanUp:
    Set olAttach = Nothing
    Set olItem = Nothing
lbl_Exit:
    Exit Sub
End Sub

Private Function FileNameUnique(strPath As String, _
                                strFileName As String, _
                                strExtension As String) As String
'An Outlook macro by Graham Mayor
Dim lngF As Long
Dim lngName As Long
    lngF = 1
    lngName = Len(strFileName) - (Len(strExtension) + 1)
    strFileName = Left(strFileName, lngName)
    Do While FileExists(strPath & strFileName & Chr(46) & strExtension) = True
        strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
        lngF = lngF + 1
    Loop
    FileNameUnique = strFileName & Chr(46) & strExtension
lbl_Exit:
    Exit Function
End Function

Private Function FileExists(filespec) As Boolean
'An Outlook macro by Graham Mayor
Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    If fso.FileExists(filespec) Then
        FileExists = True
    Else
        FileExists = False
    End If
lbl_Exit:
    Exit Function
End Function

Private Function FolderExists(fldr) As Boolean
'An Outlook macro by Graham Mayor
Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    If (fso.FolderExists(fldr)) Then
        FolderExists = True
    Else
        FolderExists = False
    End If
lbl_Exit:
    Exit Function
End Function

Private Function CreateFolders(strPath As String)
'An Outlook macro by Graham Mayor
Dim strTempPath As String
Dim lngPath As Long
Dim vPath As Variant
    vPath = Split(strPath, "\")
    strPath = vPath(0) & "\"
    For lngPath = 1 To UBound(vPath)
        strPath = strPath & vPath(lngPath) & "\"
        If Not FolderExists(strPath) Then MkDir strPath
    Next lngPath
lbl_Exit:
    Exit Function
End Function