Microsoft Office Forums - View Single Post

gmayor · 05-19-2016, 09:55 PM

This is fairly straightforward, and can be done with a script attached to a rule that identifies the incoming messages by sender, but your question raises an important issue.

You indicate that you are wanting to download a particular attachment. Will that attachment always have the same name? If it does (or if it has the same name as a file already in the target folder) what do you want to do about the name clash. Do you wish to overwrite the existing file or preserve it?

The following when run from the aforesaid rule will extract all attachments to the named folder which must exist, Existing files are retained.

Code:

Public 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
'The folder to save the attachments
'This folder must exist
Const strSaveFldr As String = "C:\Path\Reports\"

    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