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