BrianMH
03-24-2011, 05:08 AM
Hi,
Is there any way to force garbage collection in vba?
I am having real trouble as I am downloading large numbers of attachments by iterating through selected mails. The server administrators have limited the numbers of items that can be open to 500. I used to get around this using cached exchange mode but this has now been disabled by our admin. I am trying to set all the objects to nothing but it still seems to fail. I even seperated the bit that does the attachments to a seperate sub hoping that losing scope would clean up the number of items open in the back ground. My code is listed below and if anyone can figure this out it would be greatly appreciated.
The error I get is
"Run-time error '-2147220731 (80040305)':
Cannot save the attachment. Your server administrator has limited the number of items you can open simultaneously. Try closing messages you have opened or removing attachments and images from unsent messages you are composing"
Option Explicit
Public AttachmentCount As Integer
Function Downloadattachments(strpath As String)
Dim myOlApp As New outlook.Application
Dim myOlExp As outlook.Explorer
Dim myOlSel As outlook.Selection
Set myOlExp = myOlApp.ActiveExplorer
Set myOlSel = myOlExp.Selection
Dim myMitem As MailItem
Dim myPitem As PostItem
Dim myItem
AttachmentCount = 0
For Each myItem In myOlSel
Call downloadmail(myItem, strpath)
Next
MsgBox ("downloaded " & AttachmentCount & " attachments from " & myOlSel.Count & " emails")
End Function
Sub downloadmail(myMailItem, strpath As String)
Dim strFileName As String
Dim strNewName As String
Dim strPre As String
Dim strExt As String
Dim myolAttachments As Attachments
Dim myolAtt As Attachment
Dim intExtlen As Integer
Dim w As Integer
Dim fs
Set fs = CreateObject("Scripting.FileSystemObject")
If myMailItem.Attachments.Count <> 0 Then
Set myolAttachments = myMailItem.Attachments
For Each myolAtt In myolAttachments
strFileName = myolAtt.DisplayName
'find out if the file exists in the download location already and if so rename
'to a filename including a number eg. file(1).xls
If fs.fileexists(strpath & "\" & strFileName) = True Then
strNewName = strFileName
'get the length of the extension including the .
intExtlen = Len(strFileName) - InStrRev(strFileName, ".") + 1
'check there is actually a file extension and if not set extension to blank
'and set strPre to the full file name
If InStrRev(strFileName, ".") > 0 Then
strExt = Right(strFileName, intExtlen)
strPre = Left(strFileName, Len(strFileName) - intExtlen)
Else
strExt = ""
strPre = strFileName
End If
'increase the file number (w) until the file name no longer exists file(1).ext to file(2).ext etc
'strpre = filename before extension strext = extension w=file number
While fs.fileexists(strpath & "\" & strNewName) = True
w = w + 1
strNewName = strPre & Chr(40) & w & Chr(41) & strExt
Wend
'set the new filename
strFileName = strNewName
w = 0
End If
myolAtt.SaveAsFile strpath & "\" & strFileName
AttachmentCount = AttachmentCount + 1
Set myolAtt = Nothing
Next
End If
myMailItem.UnRead = False
Set myolAttachments = Nothing
Set myMailItem = Nothing
End Sub
Is there any way to force garbage collection in vba?
I am having real trouble as I am downloading large numbers of attachments by iterating through selected mails. The server administrators have limited the numbers of items that can be open to 500. I used to get around this using cached exchange mode but this has now been disabled by our admin. I am trying to set all the objects to nothing but it still seems to fail. I even seperated the bit that does the attachments to a seperate sub hoping that losing scope would clean up the number of items open in the back ground. My code is listed below and if anyone can figure this out it would be greatly appreciated.
The error I get is
"Run-time error '-2147220731 (80040305)':
Cannot save the attachment. Your server administrator has limited the number of items you can open simultaneously. Try closing messages you have opened or removing attachments and images from unsent messages you are composing"
Option Explicit
Public AttachmentCount As Integer
Function Downloadattachments(strpath As String)
Dim myOlApp As New outlook.Application
Dim myOlExp As outlook.Explorer
Dim myOlSel As outlook.Selection
Set myOlExp = myOlApp.ActiveExplorer
Set myOlSel = myOlExp.Selection
Dim myMitem As MailItem
Dim myPitem As PostItem
Dim myItem
AttachmentCount = 0
For Each myItem In myOlSel
Call downloadmail(myItem, strpath)
Next
MsgBox ("downloaded " & AttachmentCount & " attachments from " & myOlSel.Count & " emails")
End Function
Sub downloadmail(myMailItem, strpath As String)
Dim strFileName As String
Dim strNewName As String
Dim strPre As String
Dim strExt As String
Dim myolAttachments As Attachments
Dim myolAtt As Attachment
Dim intExtlen As Integer
Dim w As Integer
Dim fs
Set fs = CreateObject("Scripting.FileSystemObject")
If myMailItem.Attachments.Count <> 0 Then
Set myolAttachments = myMailItem.Attachments
For Each myolAtt In myolAttachments
strFileName = myolAtt.DisplayName
'find out if the file exists in the download location already and if so rename
'to a filename including a number eg. file(1).xls
If fs.fileexists(strpath & "\" & strFileName) = True Then
strNewName = strFileName
'get the length of the extension including the .
intExtlen = Len(strFileName) - InStrRev(strFileName, ".") + 1
'check there is actually a file extension and if not set extension to blank
'and set strPre to the full file name
If InStrRev(strFileName, ".") > 0 Then
strExt = Right(strFileName, intExtlen)
strPre = Left(strFileName, Len(strFileName) - intExtlen)
Else
strExt = ""
strPre = strFileName
End If
'increase the file number (w) until the file name no longer exists file(1).ext to file(2).ext etc
'strpre = filename before extension strext = extension w=file number
While fs.fileexists(strpath & "\" & strNewName) = True
w = w + 1
strNewName = strPre & Chr(40) & w & Chr(41) & strExt
Wend
'set the new filename
strFileName = strNewName
w = 0
End If
myolAtt.SaveAsFile strpath & "\" & strFileName
AttachmentCount = AttachmentCount + 1
Set myolAtt = Nothing
Next
End If
myMailItem.UnRead = False
Set myolAttachments = Nothing
Set myMailItem = Nothing
End Sub