Solved

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

Posted on 2011-02-11
5
990 Views
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")
   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

0
Comment
Question by:AndyH79
  • 3
5 Comments
 
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?

Chris
0
 

Author Comment

by:AndyH79
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.
0
 
LVL 37

Accepted Solution

by:
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.
0
 

Author Closing Comment

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

Author Comment

by:AndyH79
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()
   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

Featured Post

Highfive + Dolby Voice = No More Audio Complaints!

Poor audio quality is one of the top reasons people don’t use video conferencing. Get the crispest, clearest audio powered by Dolby Voice in every meeting. Highfive and Dolby Voice deliver the best video conferencing and audio experience for every meeting and every room.

Join & Write a Comment

Email signatures have numerous marketing benefits. Here are 8 top reasons to turn your email signature into a marketing channel.
Sometimes Outlook might have problems sending a message. There may be various causes- corrupted PST, AV scanner etc. The message, instead of going to the Sent Items folder, sits in the Outbox indefinitely. To remove it you can use a free tool cal…
To add imagery to an HTML email signature, you have two options available to you. You can either add a logo/image by embedding it directly into the signature or hosting it externally and linking to it. The vast majority of email clients display l…
This video shows how to remove a single email address from the Outlook 2010 Auto Suggestion memory. NOTE: For Outlook 2016 and 2013 perform the exact same steps. Open a new email: Click the New email button in Outlook. Start typing the address: …

708 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

Need Help in Real-Time?

Connect with top rated Experts

11 Experts available now in Live!

Get 1:1 Help Now