Want to protect your cyber security and still get fast solutions? Ask a secure question today.Go Premium


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

Posted on 2011-02-11
Medium Priority
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 "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
    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 1500 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

Keep up with what's happening at Experts Exchange!

Sign up to receive Decoded, a new monthly digest with product updates, feature release info, continuing education opportunities, and more.

Question has a verified solution.

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

Take a look at these 6 Outlook Email management tools which can augment the working and performance of Microsoft Outlook to give you a more rewarding emailing experience.
Mailbox Corruption is a nightmare every Exchange DBA wishes he never has. Recovering from it can be super-hectic if not entirely futile. And though techniques like the New-MailboxRepairRequest cmdlet have been designed to help with fixing minor corr…
CodeTwo Sync for iCloud (http://www.codetwo.com/sync-for-icloud?sts=6554) automatically synchronizes your Outlook 2016, 2013, 2010 or 2007 folders with iCloud folders available via iCloud Control Panel. This lets you automatically sync them with…
This is my first video review of Microsoft Bookings, I will be doing a part two with a bit more information, but wanted to get this out to you folks.
Suggested Courses

571 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