Save attachments in specified folder to hard drive

[davidman]

Hi

I need to save all attachments in one folder (called "Reports") to C:\Reports\ and then delete the email - does anyone have code to do this? I can only find code which does it for every email I have.

[gmayor]

The following will save the attachments from a selected message to C:\Reports\ (which must pre-exist) and delete the message. The additional functions are to ensure that existing files of the same name are not overwritten, but are appended with an incrementing number.

The If Not olAttach.Filename Like "image*.*" Then condition is intended to eliminate random graphics files that are not attachments, but are treated as such. If your wanted attachments have names beginning 'image' then omit that condition.

Option Explicit

Sub SaveAttachments()
Dim olItem As MailItem
Dim olAttach As Attachment
Dim strFname As String
Dim strExt As String

Const strSaveFldr As String = "C:\Reports\"        'Folder must exist!
    On Error GoTo CleanUp
    Set olItem = ActiveExplorer.Selection.Item(1)
    If olItem.Attachments.Count > 0 Then
        For Each olAttach In olItem.Attachments
            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
            End If
        Next olAttach
    End If
    olItem.Delete 'Deletes the message
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
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(ByVal Filename As String) As Boolean
Dim nAttr As Long
    On Error GoTo NoFile
    nAttr = GetAttr(Filename)
    If (nAttr And vbDirectory) <> vbDirectory Then
        FileExists = True
    End If
NoFile:
    Exit Function
End Function

[davidman]

The following will save the attachments from a selected message to C:\Reports\ (which must pre-exist) and delete the message. The additional functions are to ensure that existing files of the same name are not overwritten, but are appended with an incrementing number.

The If Not olAttach.Filename Like "image*.*" Then condition is intended to eliminate random graphics files that are not attachments, but are treated as such. If your wanted attachments have names beginning 'image' then omit that condition.

Thanks, but how does the macro know which folder to look in?

Edit: Got it, this will only do it for the selected one so my rule to move the reports into the report folder should also launch this code?

[gmayor]

You didn't mention anything about rules? If you want to run it from a rule it needs a small change to the main code sub

Private Sub SaveAttachments(olItem As MailItem)
Dim olAttach As Attachment
Dim strFname As String
Dim strExt As String
Const strSaveFldr As String = "C:\Reports\"
   
    On Error GoTo CleanUp
    If olItem.Attachments.Count > 0 Then
        For Each olAttach In olItem.Attachments
            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
            End If
        Next olAttach
    End If
    olItem.Delete
CleanUp:
    Set olAttach = Nothing
    Set olItem = Nothing
lbl_Exit:
    Exit Sub
End Sub

You can then run the script on the messages as they arrive using your rule to call the script.

[davidman]

What I originally was after was to have a macro loop through everything in my MyTime Reports folder and save the attachments to my hard drive, but something that works on rules is also fine.

Thank you for your help.

[gmayor]

Your message implied something different, though I may have misinterpreted "I can only find code which does it for every email I have."
The same code which can be used as a script called from a rule can be called from a macro to loop through your MyTime Reports folder and run the process. The following will allow you to select the folder. The attachment contains a progress bar userform as, with a lot of messages in the folder, the process can take a while to run. Extract the files from the zip and import to the Outlook VBA editor.

Sub ProcessFolder()
Dim olNS As Outlook.NameSpace
Dim olMailFolder As Outlook.MAPIFolder
Dim olItems As Outlook.Items
Dim olMailItem As Outlook.MailItem
Dim oFrm As New frmProgress
Dim PortionDone As Double
Dim i As Long

    On Error GoTo Err_Handler
    Set olNS = GetNamespace("MAPI")
    Set olMailFolder = olNS.PickFolder
    Set olItems = olMailFolder.Items
    oFrm.Show vbModeless
    i = 0
    For Each olMailItem In olItems
        i = i + 1
        PortionDone = i / olItems.Count
        oFrm.lblProgress.Width = oFrm.fmeProgress.Width * PortionDone
        SaveAttachments olMailItem
        DoEvents
    Next olMailItem
Err_Handler:
    Unload oFrm
    Set oFrm = Nothing
    Set olNS = Nothing
    Set olMailFolder = Nothing
    Set olItems = Nothing
    Set olMailItem = Nothing
lbl_Exit:
    Exit Sub
End Sub