Runtime error when using SaveAsFile method to save Outlook attachm

  • Thread starter Thread starter confused2
  • Start date Start date
C

confused2

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
 
Is this against Exchange server? It sounds like you're running into the open
RPC channel limit when accessing Exchange data, usually set at about 255
open channels.

To avoid this explicitly instantiate objects for each dot operator you are
using and then set the objects to null for each pass through the loop. For
example, instead of using Sel.Count use this:

Dim Count As Long
lCount = Sel.Count
For cnt = 1 To lCount

Don't use Sel.Item(cnt), use myItem = Sel.Item(cnt) and then work with
myItem. Same for things like Sel.Item(cnt).Attachments.Count.

When you use dot operators Outlook internally creates variables for each dot
operator and doesn't release them until the procedure finishes. So you want
to minimize that and to explicitly release the objects each pass in the
loop.

Worst case you might have to limt things to say 100 passes of the loop and
to call the loop multiple times to process everything.

If this code is running inside the Outlook VBA project do not use Dim App As
New Outlook.Application, instead use the trusted, intrinsic Application
object which will be trusted and will automatically have an
Outlook.Application reference.
 
Hi Ken,

Many thanks for the really quick reply. Sorry I didn't specify earlier -
this macro operation is performed on data in a local PST file. Will try to
work through your suggestions slowly (am only a beginner when it comes to VBA
programming). Very much appreciate your assistance.

B/Rgds
 
Hi Ken,

Have amended the code as follows but the error still occurs on the 200th
attachment. Runtime error looks like;

===========================
Run-time error '-71286779 (fbc04005)':

Cannot save the attachment. Can't create file: ATT00001.txt. Right-click the
folder you want to create the file in, and then click Properties on the
shortcut menu to check your permissions for the folder.
===========================

I've tried this code on another colleagues PC (also no success) and ensured
basic items like sufficient disk space. Appreciate if you can think of
anything else I could try. Otherwise, I'll try to break up the loop to a
specific no. of items per your worst case suggestion. Many thanks again for
your help.

B/Rgds

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 Long
Dim AttTotal As Long
Dim MsgTotal As Long
Dim i As Long

Set Exp = Application.ActiveExplorer
Set Sel = Exp.Selection
Dim Count As Long
lCount = Sel.Count
i = 1

'Loop thru each selected item in the inbox
For cnt = 1 To lCount
'If the e-mail has attachments...
Dim myItem
Dim myAttCount As Long
Set myItem = Sel.Item(cnt)
myAttCount = Sel.Item(cnt).Attachments.Count

'If Sel.Item(cnt).Attachments.Count > 0 Then
If myAttCount > 0 Then
MsgTotal = MsgTotal + 1
'AttTotal = AttTotal + Sel.Item(cnt).Attachments.Count
AttTotal = AttTotal + myAttCount

'For each attachment on the message...
'For AttachmentCnt = 1 To Sel.Item(cnt).Attachments.Count

For AttachmentCnt = 1 To myAttCount
'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")
att.SaveAsFile ("C:\Attachments\" & Format(myItem.CreationTime,
"yyyymmdd_hhnnss_") & Str(i) & "_" & att.FileName & ".txt")
Set att = Nothing
i = i + 1
Next
End If

'Set myAttCount = Nothing
Set myItem = Nothing

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
 
The only other thing I can think of is that what you're doing it filling the
Outlook secure temp folder for some reason. Take a look there and see if
things work better if you delete the files in that folder. You can find it
by following the directions here: http://support.microsoft.com/kb/817878.
Make sure to substitute your version of Outlook for the "11.0". Outlook 2007
would be "12.0".
 
Hi Ken,

Have checked but that folder doesn't exist on the pc. The weird thing is
that the problem doesn't occur when the macro works on a bunch of e-mails
with only 1 attachment (I've tried with over 800+ attachments and not a
single macro crash). It might also have something to do with the ATT0001.txt
attachment filename so will try renaming the attachment later. Many thanks
again for all your assistance - very much appreciated.

B/Rgds
 
Back
Top