How can I run macro after Send/Receive is complete?

I have a  batch of emails being received every 15 minutes which need to be processed to remove the attachments. The problem that I have is that once the SendAndReceive executes it immediately executes the GetAttachments call.  Unfortunately the SendAndReceive has not completed yet.  Is there a way to expose the number of emails incoming that are displayed in the status bar during this process so I can run a loop based timer until the SendAndReceive incoming count has been reduced to zero?

Alternately, a way to have a timer event that I could use to SendAndReceive, wait 5 minutes for event during which time emails would be received, get attachments, wait 10 minutes for event, repeat.

The way that it is set up now it is ok that no processing within outlook runs during Main.SleepMinutes(15) since this is a remote desktop login on the server which will be used exclusively for the Outlook instance to run.  

I've done some searching on how to add a timer to a form since this is recommended on in other posts.  Unfortunately I haven't found a description on how to implement this.  Also the standard windows timer is only good for 65 seconds and I haven't been able to find an extended timer control that I know will work in outlook.

Private Sub Application_Startup()
   Dim ns As NameSpace
   
   Set ns = Application.GetNamespace("MAPI")
   Do
      Call ns.SendAndReceive(True)
      Call Main.GetAttachments(ns)
      Call Main.SleepMinutes(15)
   Loop
End Sub


Module Main

Public RS As ADODB.Recordset
Public Cmd As ADODB.Command
Public Conn As ADODB.Connection
Public Sql As New C80_Sql_Transactions
Public Const Server As String = "IdrServer"
Public Const Database As String = "IntervalDataEC"
Public SendReceive As Boolean

Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub GetAttachments(ns As NameSpace)
   Dim Inbox As MAPIFolder
   Dim Item As Object
   Dim Atmt As Attachment
   Dim FileName As String
   Dim i As Integer
   
   Set ns = GetNamespace("MAPI")
   Set Inbox = ns.GetDefaultFolder(olFolderInbox)
   If Inbox.Items.Count > 0 Then
        HarvestAttachments (Inbox)
       
   End If
End Sub

Private Sub HarvestAttachments(ByRef MainFolder As Outlook.Folder)

   Dim ArchiveFolder As Outlook.Folder
   Dim AttachmentDir As String
   Dim Item As MailItem
   Dim File As Attachment
   Dim colAttachments As Attachments
   Dim dirJCPSC As String
   Dim dirFlint As String
   Dim dirProgress As String
   Dim dirXcel As String
   Dim folderJCPSC As Outlook.Folder
   Dim folderFlint As Outlook.Folder
   Dim folderProgress As OutlookFolder
   Dim folderXcel As OutlookFolder
   
   dirJCPSC = GetPath(43)
   dirFlint = GetPath(9)
   dirProgress = GetPath(16)
   dirXcel = GetPath(31)
   
   Set folderxx1 = GetFolder("\\Personal Folders\Inbox\xx1")
   Set folderxx2 = GetFolder("\\Personal Folders\Inbox\xx2")
   Set folderxx3 = GetFolder("\\Personal Folders\Inbox\xx3")
   Set folderxx4 = GetFolder("\\Personal Folders\Inbox\xx4")
   
   For Each Item In MainFolder.Items
      Select Case LCase(Item.To)
         Case "idr.xx1@xxxxxx.xxxt"
            Set ArchiveFolder = folderxx1
            AttachmentDir = dirJCPSC
         Case "ird.xx2@nxxxxxx.xxx"
            Set ArchiveFolder = folderxx2
            AttachmentDir = dirFlint
         Case "ird.xx3@xxxxxx.xxx"
            Set ArchiveFolder = folderxx3
            AttachmentDir = dirProgress
         Case "ird.xx4@xxxxxx.xxx"
            Set ArchiveFolder = folderxx4
            AttachmentDir = dirXcel
         Case Else
            Set ArchiveFolder = Nothing
            AttachmentDir = ""
      End Select
      If AttachmentDir <> "" Then
         Set colAttachments = Item.Attachments
         For Each File In colAttachments
            File.SaveAsFile AttachmentFolder & File.FileName
         Next File
         Item.Move ArchiveFolder
      End If
   Next Item
End Sub


Private Function GetPath(ByVal DataVendorKey As Integer) As String
   Dim col As New Collection
   Call Sql.Initialize(Database, Conn, Cmd, RS, Server)
   Cmd.CommandType = adCmdText
   Cmd.CommandText = "SELECT PendingDir " & _
                                      "FROM  DataVendors " & _
                                      "WHERE DataVendorKey = " & DataVendorKey
   Set RS = Cmd.Execute
   result = Sql.CheckForNull(RS, "PendingDir")
   Call Sql.Destroy(Conn, Cmd, RS)
   GetPath = result
End Function

Private Function GetFolder(ByVal FolderPath As String) As Outlook.Folder
    Dim TestFolder As Outlook.Folder
    Dim FoldersArray As Variant
    Dim i As Integer
       
    On Error GoTo GetFolder_Error
    If Left(FolderPath, 2) = "\\" Then
        FolderPath = Right(FolderPath, Len(FolderPath) - 2)
    End If
    'Convert folderpath to array
    FoldersArray = Split(FolderPath, "\")
    Set TestFolder = Application.Session.Folders.Item(FoldersArray(0))
    If Not TestFolder Is Nothing Then
        For i = 1 To UBound(FoldersArray, 1)
            Dim SubFolders As Outlook.Folders
            Set SubFolders = TestFolder.Folders
            Set TestFolder = SubFolders.Item(FoldersArray(i))
            If TestFolder Is Nothing Then
                Set GetFolder = Nothing
            End If
        Next
    End If
    'Return the TestFolder
    Set GetFolder = TestFolder
    Exit Function
       
GetFolder_Error:
    Set GetFolder = Nothing
    Exit Function
End Function

Sub SleepMinutes(ByVal NumberOfMinutes)
   Dim MinutesElapsed As Integer
   MinutesElapsed = 0
   Do Until MinutesElapsed = NumberOfMinutes
      Call Sleep(60000) 'sleep 60 seconds
      MinutesElapsed = MinutesElapsed + 1
   Loop
End Sub
End Module

AndyH79Asked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

 
Chris BottomleySoftware Quality Lead EngineerCommented:
For a moment, step back from what you do to what you want:

i.e. when each mail is received would a rule that strips the attachments at that point (using your macro - albeit modified) work?

Chris
0
 
AndyH79Author Commented:
That's how I originally had it set up using a rule to move the file to the appropriate folder and the ItemAdd event for the archive folder to trigger the stripping of the attachment.  Unfortunately, the process of bringing in the emails was slowed down too much and it wouldn't catch all of the emails causing some to be missed.  My testing showed that individually working the emails was taking more than double the amount of time as it took to pull in all the emails and then batch process the attachments. It would work fine for right now when I only have 100-200 emails to process every 15 minutes. This does need to be a scalable solution though since total emails being processed will be in the 3000-4000 range.
0
 
TommySzalapskiCommented:
In that case, a good approach would be to have a really short macro on NewMail that puts the message in a queue, then you could have another macro that runs on a timer (called from task scheduler or something) that reads the queue and process the mail in it every 5 minutes or something.

Another option would be to create an Add-In as they are more flexible and can catch more events.
0

Experts Exchange Solution brought to you by ConnectWise

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
 
AndyH79Author Commented:
I like the idea of using an add-in so I will be investigating how to implement one.
0
 
AndyH79Author Commented:
I discovered the correct way to automate this process.  I set my send/receive interval to 15 minutes and then added the following code to ThisOutlookSession. What this does is each time send/receive completes it triggers the mySync_SyncEnd event which executes my code.


Dim WithEvents mySync As Outlook.SyncObject

Private Sub Application_Startup()
   Initialize_handler
End Sub

Sub Initialize_handler()
   Set mySync = Application.Session.SyncObjects.Item(1)
End Sub

Private Sub mySync_SyncEnd()
   Main.RunAttachmentHarvest
End Sub
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.