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

Posted on 2011-02-11
Last Modified: 2012-05-11
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")
      Call ns.SendAndReceive(True)
      Call Main.GetAttachments(ns)
      Call Main.SleepMinutes(15)
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 ""
            Set ArchiveFolder = folderxx2
            AttachmentDir = dirFlint
         Case ""
            Set ArchiveFolder = folderxx3
            AttachmentDir = dirProgress
         Case ""
            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
    End If
    'Return the TestFolder
    Set GetFolder = TestFolder
    Exit Function
    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
End Sub
End Module

Question by:AndyH79
  • 3
LVL 59

Expert Comment

by:Chris Bottomley
ID: 34877254
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?


Author Comment

ID: 34878910
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.
LVL 37

Accepted Solution

TommySzalapski earned 500 total points
ID: 34879447
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.

Author Closing Comment

ID: 34888451
I like the idea of using an add-in so I will be investigating how to implement one.

Author Comment

ID: 34974123
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()
End Sub

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

Private Sub mySync_SyncEnd()
End Sub

Featured Post

Free Tool: Postgres Monitoring System

A PHP and Perl based system to collect and display usage statistics from PostgreSQL databases.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Suggested Solutions

If you don't know how to downgrade, my instructions below should be helpful.
When you have clients or friends from around the world, it becomes a challenge to arrange a meeting or effectively manage your time. This is where Outlook's capability to show 2 time zones in one calendar comes in handy.
This Experts Exchange video Micro Tutorial shows how to tell Microsoft Office that a word is NOT spelled correctly. Microsoft Office has a built-in, main dictionary that is shared by Office apps, including Excel, Outlook, PowerPoint, and Word. When …
Many of my clients call in with monstrous Gmail overloading issues with Outlook. A quick tip is to turn off the All Mail and Important folders from synching. Here is a quick video I made to show you how to turn off these and other folders in Gmail s…

856 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question