• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 287
  • Last Modified:

Processing attachments script needs improvements

I receive a couple hundred emails at the end of each month that contain Excel attachments that I use the posted script to: check for Excel attachments, then if present, check to see if the Excel attachment contains the worksheet that I want - if it does, saves the attachment to the specified folder as Sendername_G22.xls.  This script works, but for example, if there are say 100 emails in the Inbox when it is run, the first time it's run, it process maybe 50 - 60 of them, then when I rerun the script, it will process maybe 25 or so.  It seems to process fewer emails each time that it is run.  So, it seems that maybe its a memory issue or something.

I am hoping that someone can look at this and tell me how what is happening and how to improve it.  Any help will be appreciated.  Thanks.

Sub G22EmailNYC()
    'Declare Outlook objects
    
    Dim OlApp As New Outlook.Application
    Dim NS As Outlook.NameSpace
    Dim Inbox As Outlook.MAPIFolder
    Dim olfldDest As Outlook.MAPIFolder
    Dim olItems As Outlook.Items
    Dim olItem As Object
    Dim olAttachment As Outlook.Attachment
    Dim oRecip As Outlook.Recipient
    Dim nycInbox As MAPIFolder
       
    
    
    'Declare Excel and FSO objects
    Dim objFSO As Object
    Dim objTempFolder As Object
    Dim strRootFolderPath As String
    Dim strFilename As String
    Dim intCount As Integer
    Dim FileCount As Integer
    Dim excApp As Object
    Dim excBook As Object
    Dim excSheet As Object
    
    
    MsgBox "This procedure will scan the inbox of NYCReport, 1NYCReports, & 2NYCReports email accounts for Officer Stats workbooks and when found save the attached reports in the format 'SenderName_G22.xls' in \\Z02RSCNYC03\SHARE$\NYC Reports\G-22_Monthly_Stats\FY09\NYC\2_Email ", vbInformation, "Search for Stats Reports"
    'MsgBox "This procedure will scan the inbox of NYCReports email for Officer Stats workbooks and when found save the attached reports in the format 'SenderName_G22.xls' in \\Z02RSCNYC03\SHARE$\NYC Reports\G-22_Monthly_Stats\FY09\NYC\2_Email ", vbInformation, "Search for Stats Reports"
    'Set Outlook variables
    Set NS = OlApp.GetNamespace("MAPI")
    Set oRecip = NS.CreateRecipient("nycreport")
    If oRecip.Resolve() Then
    Set nycInbox = NS.GetSharedDefaultFolder(oRecip, olFolderInbox)
    Else
    MsgBox "nyc Report mailbox is not accessible"
    Exit Sub
    End If
    Set olItems = nycInbox.Items
    'Used to select Destination Folder for email manually
    'Set olfldDest = NS.PickFolder
    'We'll set the email destination for mail containing G22 workbooks to Inbox\G22_Stats_Temp
    Set olfldDest = nycInbox.Folders("G22_Stats_temp") ' Enter correct subfolder name.
    'Set FSO variables
  Set objFSO = CreateObject("Scripting.FileSystemObject")
  Set objTempFolder = objFSO.GetSpecialFolder(2)
    strRootFolderPath = "\\Z02RSCNYC03\SHARE$\NYC Reports\G-22_Monthly_Stats\FY09\NYC\2_Email\"
    FileCount = 0
    'Look through the Inbox mail
    For Each olItem In olItems
            'Look only at items with attachments
            If olItem.Attachments.Count > 0 Then
                    For Each olAttachment In olItem.Attachments
                        'This line sets the criteria to all files with the xls extension
                        If objFSO.GetExtensionName(LCase(olAttachment.FileName)) = "xls" Then
                                strFilename = olItem.SenderName
                                On Error Resume Next
                                olAttachment.SaveAsFile objTempFolder.Path & "\" & strFilename
                                On Error GoTo 0
                'Set Excel variables so we can manipulate Excel attachments
                Set excApp = CreateObject("Excel.Application")
                Set excBook = excApp.Workbooks.Open(objTempFolder.Path & "\" & strFilename)
                'Look for the Data-Review Sheet
                On Error Resume Next
                Set excSheet = excBook.Sheets("Data-Review")
                On Error GoTo RESET
                                If TypeName(excSheet) <> "Nothing" Then
                                        intCount = 0
                                        Do While True
                                   If objFSO.FileExists(strRootFolderPath & strFilename) Then
                            intCount = intCount + 1
                            strFilename = strFilename & "_Copy" & intCount & "_G22.xls"
                                                Else
                                                        Exit Do
                                                End If
                    Loop
                    olAttachment.SaveAsFile strRootFolderPath & strFilename & "_G22.xls"
                    FileCount = FileCount + 1
                    olItem.Move olfldDest
                    olItem.UnRead = False
                    olItem.Save
                End If
RESET:
                Set excSheet = Nothing
                excBook.Close False
                Set excBook = Nothing
                excApp.Quit
                Set excApp = Nothing
        End If
            Next
    End If
    Next
    MsgBox "Email check is complete,  " & FileCount & "  Stats Files have been saved."
    Set NS = Nothing
    Set Inbox = Nothing
    Set olItems = Nothing
    Set olfldDest = Nothing
    Set objFSO = Nothing
    Set olAttachment = Nothing
    Set objTempFolder = Nothing
 
End Sub

Open in new window

0
Michael Spellman
Asked:
Michael Spellman
  • 2
2 Solutions
 
Rory ArchibaldCommented:
Try looping backwards:
 

Sub G22EmailNYC()
    'Declare Outlook objects
    
    Dim OlApp As New Outlook.Application
    Dim NS As Outlook.NameSpace
    Dim Inbox As Outlook.MAPIFolder
    Dim olfldDest As Outlook.MAPIFolder
    Dim olItems As Outlook.Items
    Dim olItem As Object
    Dim olAttachment As Outlook.Attachment
    Dim oRecip As Outlook.Recipient
    Dim nycInbox As MAPIFolder
   Dim n as Long
       
    
    
    'Declare Excel and FSO objects
    Dim objFSO As Object
    Dim objTempFolder As Object
    Dim strRootFolderPath As String
    Dim strFilename As String
    Dim intCount As Integer
    Dim FileCount As Integer
    Dim excApp As Object
    Dim excBook As Object
    Dim excSheet As Object
    
    
    MsgBox "This procedure will scan the inbox of NYCReport, 1NYCReports, & 2NYCReports email accounts for Officer Stats workbooks and when found save the attached reports in the format 'SenderName_G22.xls' in \\Z02RSCNYC03\SHARE$\NYC Reports\G-22_Monthly_Stats\FY09\NYC\2_Email ", vbInformation, "Search for Stats Reports"
    'MsgBox "This procedure will scan the inbox of NYCReports email for Officer Stats workbooks and when found save the attached reports in the format 'SenderName_G22.xls' in \\Z02RSCNYC03\SHARE$\NYC Reports\G-22_Monthly_Stats\FY09\NYC\2_Email ", vbInformation, "Search for Stats Reports"
    'Set Outlook variables
    Set NS = OlApp.GetNamespace("MAPI")
    Set oRecip = NS.CreateRecipient("nycreport")
    If oRecip.Resolve() Then
    Set nycInbox = NS.GetSharedDefaultFolder(oRecip, olFolderInbox)
    Else
    MsgBox "nyc Report mailbox is not accessible"
    Exit Sub
    End If
    Set olItems = nycInbox.Items
    'Used to select Destination Folder for email manually
    'Set olfldDest = NS.PickFolder
    'We'll set the email destination for mail containing G22 workbooks to Inbox\G22_Stats_Temp
    Set olfldDest = nycInbox.Folders("G22_Stats_temp") ' Enter correct subfolder name.
    'Set FSO variables
  Set objFSO = CreateObject("Scripting.FileSystemObject")
  Set objTempFolder = objFSO.GetSpecialFolder(2)
    strRootFolderPath = "\\Z02RSCNYC03\SHARE$\NYC Reports\G-22_Monthly_Stats\FY09\NYC\2_Email\"
    FileCount = 0
    'Look through the Inbox mail
    For n = olItems.Count to 1 step -1
         set olitem = olitems(n)
            'Look only at items with attachments
            If olItem.Attachments.Count > 0 Then
                    For Each olAttachment In olItem.Attachments
                        'This line sets the criteria to all files with the xls extension
                        If objFSO.GetExtensionName(LCase(olAttachment.FileName)) = "xls" Then
                                strFilename = olItem.SenderName
                                On Error Resume Next
                                olAttachment.SaveAsFile objTempFolder.Path & "\" & strFilename
                                On Error GoTo 0
                'Set Excel variables so we can manipulate Excel attachments
                Set excApp = CreateObject("Excel.Application")
                Set excBook = excApp.Workbooks.Open(objTempFolder.Path & "\" & strFilename)
                'Look for the Data-Review Sheet
                On Error Resume Next
                Set excSheet = excBook.Sheets("Data-Review")
                On Error GoTo RESET
                                If TypeName(excSheet) <> "Nothing" Then
                                        intCount = 0
                                        Do While True
                                   If objFSO.FileExists(strRootFolderPath & strFilename) Then
                            intCount = intCount + 1
                            strFilename = strFilename & "_Copy" & intCount & "_G22.xls"
                                                Else
                                                        Exit Do
                                                End If
                    Loop
                    olAttachment.SaveAsFile strRootFolderPath & strFilename & "_G22.xls"
                    FileCount = FileCount + 1
                    olItem.Move olfldDest
                    olItem.UnRead = False
                    olItem.Save
                End If
RESET:
                Set excSheet = Nothing
                excBook.Close False
                Set excBook = Nothing
                excApp.Quit
                Set excApp = Nothing
        End If
            Next 
    End If
    Next n
    MsgBox "Email check is complete,  " & FileCount & "  Stats Files have been saved."
    Set NS = Nothing
    Set Inbox = Nothing
    Set olItems = Nothing
    Set olfldDest = Nothing
    Set objFSO = Nothing
    Set olAttachment = Nothing
    Set objTempFolder = Nothing
 
End Sub
 

Open in new window

0
 
Michael SpellmanSupervisory Operations Support SpecialistAuthor Commented:
If people submit multiple emails, I want to save their attachments from each, just incrementing the filename if the sendername already exists.  I thought that I had that covered, but it doesn't seem to be working.  Can you see what I've got wrong?
0
 
Michael SpellmanSupervisory Operations Support SpecialistAuthor Commented:
Looping backward doesn't appear to help.  Any other ideas on optimizing this process?
0

Featured Post

Get your Conversational Ransomware Defense e‑book

This e-book gives you an insight into the ransomware threat and reviews the fundamentals of top-notch ransomware preparedness and recovery. To help you protect yourself and your organization. The initial infection may be inevitable, so the best protection is to be fully prepared.

  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now