Runtime error when using SaveAsFile method to save Outlook attachm
Attached macro is used to save all attachments for selected e-mail items in a
particular outlook folder. Code works fine, however after 199 items are saved
in c:\attachments folder - a runtime error occurs (something about unable to
save the file). A bit confused why this is occurring and would appreciate
some guidance. Many thanks.
Public Sub SaveAttachmentsNew()
'Note, this assumes you are in the a folder with e-mail messages when you
run it.
'It does not have to be the inbox, simply any folder with e-mail messages
Dim App As New Outlook.Application
Dim Exp As Outlook.Explorer
Dim Sel As Outlook.Selection
Dim AttachmentCnt As Integer
Dim AttTotal As Integer
Dim MsgTotal As Integer
Dim i As Integer
Set Exp = App.ActiveExplorer
Set Sel = Exp.Selection
i = 1
'Loop thru each selected item in the inbox
For cnt = 1 To Sel.Count
'If the e-mail has attachments...
If Sel.Item(cnt).Attachments.Count 0 Then
MsgTotal = MsgTotal + 1
AttTotal = AttTotal + Sel.Item(cnt).Attachments.Count
'For each attachment on the message...
For AttachmentCnt = 1 To Sel.Item(cnt).Attachments.Count
'Get the attachment
Dim att As Attachment
Set att = Sel.Item(cnt).Attachments.Item(AttachmentCnt)
att.SaveAsFile ("C:\Attachments\" &
Format(Sel.Item(cnt).CreationTime, "yyyymmdd_hhnnss_") & Str(i) & "_" &
att.FileName & ".txt")
Set att = Nothing
i = i + 1
Next
End If
Next
'Clean up
Set Sel = Nothing
Set Exp = Nothing
Set App = Nothing
'Let user know we are done
Dim doneMsg As String
doneMsg = "Completed saving " + Format$(AttTotal, "#,0") + " attachments
in " + Format$(MsgTotal, "#,0") + " Messages."
MsgBox doneMsg, vbOKOnly, "Save Attachments"
Exit Sub
ErrorHandler:
Dim errMsg As String
errMsg = "An error has occurred. Error " + Err.Number + " " +
Err.Description
Dim errResult As VbMsgBoxResult
errResult = MsgBox(errMsg, vbAbortRetryIgnore, "Error in Save Attachments")
Select Case errResult
Case vbAbort
Exit Sub
Case vbRetry
Resume
Case vbIgnore
Resume Next
End Select
End Sub
|