Link to home
Start Free TrialLog in
Avatar of AndyH79
AndyH79Flag for United States of America

asked on

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")
      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

Avatar of Chris Bottomley
Chris Bottomley
Flag of United Kingdom of Great Britain and Northern Ireland image

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?

Avatar of AndyH79


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.
Avatar of TommySzalapski
Flag of United States of America image

Link to home
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
Avatar of AndyH79


I like the idea of using an add-in so I will be investigating how to implement one.
Avatar of AndyH79


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