OOM - timing issues, general advice appreciated. 1

[1DMF]

Hi,

I have an email wrapper class I use for my applications.

Most of the time it works fine, however, I am having some timing issues between the drafts , outbox and sent items folders.

I have found that even if the user clicks 'send' on an email in Outlook, as it can take time to move from drafts to the outbox, sometimes my code is catching the email still in drafts even though the email was sent causing my code to think the email hadn't been sent.

I have also found that if the email goes to the outbox, and then my code looks for the email, if it hasn't started to send yet, grabbing the email via OOM VBA, seems to stop the email ever transmitting.

I'm looking for advice on how I can manage accurately the transition between drafts / outbox / sent items without interrupting the process or my code incorrectly identifying emails in folders they aren't (well they were at the time it checked but for a Nano-second).

The incidents are seldom and random and possibly relate to network speeds, PC speeds, A/V scanning glitches, exchange loads etc..

I have added a generic 'sleep' command between operations, which for many users (including remote), this does work 99% of the time, but as the speed of email creation to transmission is random throughout the day, it's not an idea solution, it doesn't work 100% of the time and I'm reluctant to add yet more hardcoded 'slow down' into the application.

The current main 'slow down' is in the method 'ResetStatus' which is called by a few methods, you will see it has a 'DoEvents' to try to let the OS do it's stuff (Outlook) and a 'Sleep 2000' - This doesn't however appear to be enough some of the time?

Perhaps it is not the code but the A/V (McAfee) causing the problems?

Your advice is appreciated.

Here is the current class...

Option Explicit

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

' Instance attribute emailwrapper components
Private sSubject As String
Private cTO As New Collection
Private cBCC As New Collection
Private cCC As New Collection
Private sBody As String
Private cFiles As New Collection
Private cItems As New Collection
Private cItemTypes As New Collection
Private sDraftsID As String
Private iTimeOut As Integer
Private bShowProgress As Boolean
Private sEmailRef As String
Private oProgress As Object
Private cProgressMsg As New Collection
Private bSave As Boolean
Private iMaxSentItems As Integer
Private iTimeOutCnt As Integer
Private sSender As String

' Errors / Status
Private oErrors As Object
Private oStatus As Object

' Outlook object
Private oApp As Object
Private oMsg As Object

' Constants
Const olMailItem As Integer = 0
Const olTO As Integer = 1
Const olCC As Integer = 2
Const olBCC As Integer = 3
Const olEmailMsg As Integer = 3
Const olOutbox As Integer = 4
Const olSentItems As Integer = 5
Const olText As Integer = 1

Const PR_ATTACH_MIME_TAG = "[URL unfurl="true"]http://schemas.microsoft.com/mapi/proptag/0x370E001E"[/URL]
Const PR_ATTACH_CONTENT_ID = "[URL unfurl="true"]http://schemas.microsoft.com/mapi/proptag/0x3712001E"[/URL]
Const PR_ATTACHMENT_HIDDEN = "[URL unfurl="true"]http://schemas.microsoft.com/mapi/proptag/0x7FFE000B"[/URL]

Private Sub Class_Initialize()

    ' Initialise vars
    sDraftsID = "" ' Email ID
    sEmailRef = "" ' Email Reference
    iMaxSentItems = 10 ' Sent items history range default
    iTimeOut = 30 ' Timeout default
    iTimeOutCnt = 0 ' Current timeout counter
    sSender = "" ' Sender email
    
    ' Internal error codes
    Set oErrors = CreateObject("Scripting.Dictionary")
    oErrors.Add 0, "No errors"
    oErrors.Add 1, "Can't open Outlook, process aborted!"
    oErrors.Add 2, "Failed to create email."
    oErrors.Add 3, "Failed to display email."
    oErrors.Add 4, "Failed to send email."
    oErrors.Add 5, "Failed to save email."
    oErrors.Add 6, "Failed to delete email from drafts."
    oErrors.Add 7, "Failed to get email from drafts."
    oErrors.Add 8, "Can't save email, no email reference is available."
    oErrors.Add 9, "Can't save email, email is still in drafts."
    oErrors.Add 10, "Can't save email, timeout reached!"
    oErrors.Add 11, "Can't save email, file path doesn't exist!"
    oErrors.Add 12, "Invalid drive letter for saving email"
    oErrors.Add 13, "No email recipients set, process aborted!"
    oErrors.Add 14, "Error trying to retrieve sent email!"
    oErrors.Add 99, "Internal system error, seek support!"
        
    ' Status
    Set oStatus = CreateObject("Scripting.Dictionary")
    oStatus.Add "OK", True
    oStatus.Add "Error", 0
    oStatus.Add "Msg", ""
    
    ' Progress window
    bShowProgress = True
    Set oProgress = CreateObject("Scripting.Dictionary")
    oProgress.Add "Msg", cProgressMsg
    Call InitProgress("Progress_Info", "Progress", False, True)
    
End Sub

Private Sub Class_Terminate()

On Error Resume Next
    
    Call AddProgress("Email processing complete.")
    
    ' Close progress window
    If oProgress.Item("Close") Then
        DoCmd.Close acForm, oProgress.Item("Frm")
    End If

End Sub

' GETTER ACCESSOR METHODS

' Get internal error description
Public Property Get ErrorDesc() As String
    ErrorDesc = oErrors.Item(oStatus.Item("Error"))
End Property

' Get error code
Public Property Get ErrorCode() As Integer
    ErrorCode = oStatus.Item("Error")
End Property

' Get OK status
Public Property Get OK() As Boolean
    OK = oStatus.Item("OK")
End Property

' Get status messgage
Public Property Get StatusMsg() As String
    If Nz(oStatus.Item("Msg"), "") = "" Then
        StatusMsg = Me.ErrorDesc
    Else
        StatusMsg = oStatus.Item("Msg")
    End If
End Property

' Get show progress
Public Property Get ShowProgress() As Boolean
    ShowProgress = bShowProgress
End Property

' Get progress messages
Public Property Get ProgressMsg() As Collection
    Set ProgressMsg = oProgress.Item("Msg")
End Property

' Get email body
Public Property Get Body() As String
    Body = sBody
End Property

' Get timeout
Public Property Get Timeout() As Integer
    Timeout = iTimeOut
End Property

' Get email subject
Public Property Get Subject() As String
    Subject = sSubject
End Property

' Get email reference
Public Property Get EmailRef() As String
    EmailRef = sEmailRef
End Property

' Get draft email ID
Public Property Get DraftsID() As String
    DraftsID = sDraftsID
End Property

' Get sent items range
Public Property Get MaxSentItems() As Integer
    MaxSentItems = iMaxSentItems
End Property

' Get Sender Property
Public Property Get Sender() As String
    Sender = sSender
End Property


' SETTER ACCESSOR METHODS

' Set email subject
Public Property Let Subject(ByVal aValue As String)
    sSubject = aValue
End Property

' Set timeout (in seconds)
Public Property Let Timeout(ByVal aValue As Integer)
    iTimeOut = aValue
End Property

' Set email body
Public Property Let Body(ByVal aValue As String)
    sBody = aValue
End Property

' Set email reference
Public Property Let EmailRef(ByVal aValue As String)
    sEmailRef = aValue
End Property

' Set sent items range
Public Property Let MaxSentItems(ByVal aValue As Integer)
    iMaxSentItems = aValue
End Property

' Set Sender Property
Public Property Let Sender(ByVal aValue As String)
    sSender = aValue
End Property

' Set show progress
Public Property Let ShowProgress(ByVal aValue As Boolean)
    bShowProgress = aValue
End Property

' Add TO recipient
Public Sub AddTO(ByVal sRecip As String)
    cTO.Add (sRecip)
End Sub

' Add BCC recipient
Public Sub AddBCC(ByVal sRecip As String)
    cBCC.Add (sRecip)
End Sub

' Add CC recipient
Public Sub AddCC(ByVal sRecip As String)
    cCC.Add (sRecip)
End Sub

' Add file attachment
Public Sub AddAttachment(ByVal file As String)
    cFiles.Add (file)
End Sub

' Add inline attachment item and type
Public Sub AddInline(ByVal i As String, ByVal t As String)
    cItems.Add (i)
    cItemTypes.Add (t)
End Sub

' Clear progress messages
Public Sub ClearProgress()
    Set oProgress.Item("Msg") = New Collection
End Sub

' Clear TO recipients
Public Sub ClearTO()
    Set cTO = New Collection
End Sub

' Clear CC recipients
Public Sub ClearCC()
    Set cCC = New Collection
End Sub

' Clear BCC recipients
Public Sub ClearBCC()
    Set cBCC = New Collection
End Sub

' Clear TO recipients
Public Sub ClearRecips()
    Me.ClearTO
    Me.ClearCC
    Me.ClearBCC
End Sub

' CLASS PUBLIC METHODS

' Create email routine
Public Sub Create()
    
On Error GoTo Create_Email_Error
    
    Dim olAttach As Object
    Dim oAttach As Object
    Dim iCnt As Integer
    Dim oRecip As Object
    Dim oPA As Object
    Dim vEml As Variant
    Dim vAtt As Variant
    
    ' Reset status
    Call ResetStatus
    
    ' Clear save flag
    bSave = False
    
    ' Check outlook open and create outlook object
    If CheckOutlook And CreateOutlook Then
    
        ' Create new mail item
        Set oMsg = oApp.CreateItem(olMailItem)
        
        Call AddProgress("Creating email, please wait.")
        
        With oMsg
            
            ' Add TO recipients
            If cTO.Count > 0 Then
                Call AddProgress("Adding TO recipients.")
                For Each vEml In cTO
                    Set oRecip = .Recipients.Add(vEml)
                    oRecip.Type = olTO
                Next
            End If
            
            ' Add CC recipients
            If cCC.Count > 0 Then
                Call AddProgress("Adding CC recipients.")
                For Each vEml In cCC
                    Set oRecip = .Recipients.Add(vEml)
                    oRecip.Type = olCC
                Next
            End If
            
            ' Add BCC recipients
            If cBCC.Count > 0 Then
                Call AddProgress("Adding BCC recipients.")
                For Each vEml In cBCC
                    Set oRecip = .Recipients.Add(vEml)
                    oRecip.Type = olBCC
                Next
            End If
            
            ' Set email subject
            Call AddProgress("Adding email description / subject.")
            .Subject = Nz(sSubject, "")
            
            ' Set body HTML
            Call AddProgress("Adding email body.")
            .HTMLBody = Nz(sBody, "")
            
            ' add email reference
            If sEmailRef <> "" Then
                Call AddProgress("Adding email reference.")
                .UserProperties.Add "EmailRef", olText
                .UserProperties.Item("EmailRef").Value = sEmailRef
                bSave = True
            Else
                bSave = False
            End If
            
            ' check for sender address
            If Sender <> "" Then
                .SentOnBehalfOfName = Sender
            End If
            
        End With
        
        ' Clear recipient object
        Set oRecip = Nothing
            
        ' Check items for mime encoding
        If cItems.Count > 0 Then
            Call AddProgress("Adding inline attachments.")
            ' Attach items
            Set olAttach = oMsg.Attachments
            For iCnt = 1 To cItems.Count
                Set oAttach = olAttach.Add(cItems.Item(iCnt))
                Set oPA = oAttach.PropertyAccessor
                oPA.SetProperty PR_ATTACH_MIME_TAG, cItemTypes.Item(iCnt)
                oPA.SetProperty PR_ATTACH_CONTENT_ID, "item" & iCnt
                oPA.SetProperty PR_ATTACHMENT_HIDDEN, True
            Next
                       
        End If
            
        ' Add normal file attachments
        If cFiles.Count > 0 Then
            Call AddProgress("Adding standard attachments.")
            For Each vAtt In cFiles
                oMsg.Attachments.Add (vAtt)
            Next
        End If
        
        ' Save email
        Call AddProgress("Saving email to drafts.", True)
        oMsg.Save
        
        sDraftsID = oMsg.EntryID
        
    End If
    
Exit_Create_Email:

    ' clean up objects
    Set oAttach = Nothing
    Set oPA = Nothing
    Set olAttach = Nothing
    Set vEml = Nothing
    Set vAtt = Nothing
    Set oMsg = Nothing
    Set oApp = Nothing
    
    Exit Sub
    
Create_Email_Error:

    If err.Number = 287 Then
        ' Can't open Outlook
        Call AddError(1)
        
    Else
        
        If err.Number = 440 Then
            ' no email recipients set
            Call AddError(13)
        Else
            ' Failed to create email
            Call AddError(2, err.Description)
        End If
    End If
    
    ' Clean up Outlook email
    If Not oMsg Is Nothing Then
        On Error Resume Next
        oMsg.Delete
        Set oMsg = Nothing
    End If
    
    Resume Exit_Create_Email
    
End Sub

' Display email routine
Public Sub Display()

On Error GoTo Display_Email_Error

    ' Get email
    If GetEmail Then

        ' Add progress
        Call AddProgress("Displaying email.", True)
        
        ' Display email
        oMsg.Display
        
        ' activate to try and bring to foreground
        oMsg.Activate
        
        DoEvents
        
    End If
    
Exit_Display_Email:
    
    ' Clear Outlook email objects
    Call ClearOutlook
    
    Exit Sub
    
Display_Email_Error:
    
    Call AddError(3, err.Description)
    Resume Exit_Display_Email

End Sub

' Send email routine
Public Sub Send()

On Error GoTo Send_Email_Error

    ' Reset status
    Call ResetStatus
    
    ' Get email
    If GetEmail Then
    
        ' Add progress
        Call AddProgress("Sending email, please wait.")
    
        ' Send email
        oMsg.Send
        
    End If
    
Exit_Send_Email:

    ' Clear Outlook email objects
    Call ClearOutlook
    
    Exit Sub
    
Send_Email_Error:

    Call AddError(4, err.Description)
    Resume Exit_Send_Email

End Sub

' Delete email routine
Public Sub Delete()

On Error GoTo Delete_Email_Error

    ' Get email
    If GetEmail Then
    
        ' Delete email
        oMsg.Delete
    
        ' Add progress
        Call AddProgress("Email has been deleted.")
        
    End If
    
Exit_Delete_Email:

    ' Clear Outlook email objects
    Call ClearOutlook
    Exit Sub
    
Delete_Email_Error:

    Call AddError(6, err.Description)
    Resume Exit_Delete_Email

End Sub

' Save email routine
Public Sub Save(ByVal sDestPath As String, ByVal sFilename As String, Optional bCreate As Boolean = False)

On Error GoTo Save_Email_Error

    Dim sDest As String

    ' Reset timeout counter
    iTimeOutCnt = 0
    
    ' Reset status
    Call ResetStatus
    
    ' Check if save possible
    If Not bSave Or Nz(sEmailRef, "") = "" Then
        Call AddError(8)
    Else

        ' Check email in drafts - can't save
        If Me.OK And GetEmail Then
            Call AddError(9)
        Else
        
            ' So far so good - reset status and continue
            Call ResetStatus
        
            ' Check outbox and see if email is still sending
            Do While CheckOutbox And iTimeOutCnt <= iTimeOut
                Call AddProgress("Still sending email, please wait.")
                iTimeOutCnt = iTimeOutCnt + 3
                Sleep 3000
            Loop
                        
            ' Try to get email from sent items
            Do While Me.OK And iTimeOutCnt <= iTimeOut And Not GetSentEmail
                Call AddProgress("Trying to retrieve email, please wait.")
                iTimeOutCnt = iTimeOutCnt + 1
                Sleep 1000
            Loop
            
            ' Check if timed out
            If iTimeOutCnt >= iTimeOut Then
                Call AddError(10)
            End If
                                    
            ' Continue if no errors
            If Me.OK Then
                             
                ' Check if path exists / cannot be created
                If Not CheckPath(sDestPath, bCreate) Then
                    Call AddError(11)
                Else
                    Call AddProgress("Saving email, please wait.")
                    
                    ' Save email
                    sDest = sDestPath & "\" & Replace(sFilename, ".msg", "", , , vbTextCompare) & ".msg"
                    oMsg.SaveAs sDest, olEmailMsg
                    
                    Call AddProgress("Emailed saved successfully.")
                    
                End If
            
            End If
            
        End If
        
    End If
    
Exit_Save_Email:

    ' Clear Outlook email objects
    Call ClearOutlook
    Exit Sub
    
Save_Email_Error:

    ' Failed to save email
    Call AddError(5, err.Description)
    Resume Exit_Save_Email
    
End Sub

' Initialise progress window
Public Sub InitProgress(ByVal sFormName As String, ByVal sTextCtrl As String, ByVal bHide As Boolean, ByVal bClose As Boolean, Optional ByVal sSubFormName As String = "")

On Error Resume Next

    Dim cTextBox As Access.TextBox
    
    ' Open form if not open
    If Not CurrentProject.AllForms(sFormName).IsLoaded Then
        DoCmd.OpenForm sFormName, acNormal
    End If
    
    ' Hide form
    If bHide Then
        Forms(sFormName).Visible = False
    End If
    
    ' Set textbox control
    If sSubFormName <> "" Then
        Set cTextBox = Forms(sFormName).Controls(sSubFormName).Form.Controls(sTextCtrl)
    Else
        Set cTextBox = Forms(sFormName).Controls(sTextCtrl)
    End If
       
    ' Set progress vars
    oProgress.Add "Frm", sFormName
    oProgress.Add "Ctrl", cTextBox
    oProgress.Add "Close", bClose
    oProgress.Add "Hide", bHide
    
End Sub

' CLASS HELPER PRIVATE METHODS
    
' Check Outlook helper
Private Function CheckOutlook() As Boolean

On Error GoTo Outlook_Error
    
    CheckOutlook = True
    
    Dim olApp As Object
        
    ' Check outlook
    Call AddProgress("Checking Outlook is open.")
    
    Set olApp = GetObject(, "Outlook.Application")
    
    Set olApp = Nothing
    
    Exit Function
    
Outlook_Error:

    ' Outlook not open
    If err.Number = 429 Then
        Call AddProgress("Trying to open Outlook.")
        Call Shell("Outlook.exe")
        Sleep 1000
        Resume Next
    Else
        CheckOutlook = False
        Call AddError(99, err.Description)
    End If
    
End Function

' Add errors helper
Private Sub AddError(ByVal iErr As Integer, Optional ByVal sMSG As String = "")

    oStatus.Item("OK") = False
    oStatus.Item("Error") = iErr

    If sMSG <> "" Then
        oStatus.Item("Msg") = sMSG
    End If

End Sub

' Add progress helper
Public Sub AddProgress(ByVal sMSG As String, Optional bHide As Boolean = False)

    oProgress.Item("Msg").Add (sMSG)
    
    If bShowProgress Then
        Call ShowProgressMsg(bHide)
    End If

End Sub

' Reset status helper
Private Sub ResetStatus()

    ' let OS do stuff
    DoEvents
    
    ' reset flags
    oStatus.Item("OK") = True
    oStatus.Item("Error") = 0
    oStatus.Item("Msg") = ""
    
    ' pause just to let things initiate
    Sleep 2000
    
End Sub

' Show progress message
Private Sub ShowProgressMsg(ByVal bHide As Boolean)
    
    ' Check if form open
    If Not CurrentProject.AllForms(oProgress.Item("Frm")).IsLoaded Then
        DoCmd.OpenForm oProgress.Item("Frm"), acNormal
    End If
    
    ' Check if form visible
    If Not Forms(oProgress.Item("Frm")).Visible Then
        Forms(oProgress.Item("Frm")).Visible = True
    End If
    
    ' Update message window
    oProgress.Item("Ctrl").Value = Nz(oProgress.Item("Ctrl").Value, "") & oProgress.Item("Msg").Item(oProgress.Item("Msg").Count) & vbCrLf
    
    ' Move cursor
    oProgress.Item("Ctrl").SelStart = Len(oProgress.Item("Ctrl").Value)
    
    ' Hide message window if required
    If bHide And oProgress.Item("Hide") Then
        Forms(oProgress.Item("Frm")).Visible = False
    End If
    
    ' Ensure screen is refreshed
    DoEvents
    
End Sub

' Get draft email helper
Public Function GetEmail() As Boolean

On Error GoTo Error_GetEmail

    GetEmail = False
    
    ' Reset status
    Call ResetStatus
    
    ' Check Outlook open
    If CheckOutlook And CreateOutlook Then

        ' Get email from drafts
        Set oMsg = oApp.GetNamespace("MAPI").GetItemFromID(sDraftsID)

        ' Got email
        GetEmail = True
        
    End If
    
Exit_GetEmail:
    
    Exit Function
    
Error_GetEmail:

    If err.Number = 440 Then
        ' Email not in drafts
        Call AddError(7)
    Else
        ' All other errors
        Call AddError(99, err.Description)
    End If
    
    ' Clear Outlook email objects
    Call ClearOutlook
    
    Resume Exit_GetEmail
    
End Function

' Clear Outlook object helper
Private Sub ClearOutlook()

    Set oMsg = Nothing
    Set oApp = Nothing
    
End Sub

' Create Outlook helper
Private Function CreateOutlook() As Boolean

On Error GoTo Error_CreateOutlook

    CreateOutlook = True

    ' Create Outlook object
    Set oApp = CreateObject("Outlook.Application")
    
Exit_CreateOutlook:

    Exit Function
    
Error_CreateOutlook:

    CreateOutlook = False
    
    If err.Number = 287 Then
        ' Can't open Outlook
        Call AddError(1)
    Else
        ' All other errors
        Call AddError(99, err.Description)
    End If
    
    Resume Exit_CreateOutlook
    
End Function


' Check outbox for email
Public Function CheckOutbox() As Boolean

On Error GoTo Error_CheckOutbox

    Dim oItems As Object
    Dim bFound As Boolean
    Dim bSending As Boolean
    Dim oOutbox As Object
    Dim bSent As Boolean
    
    ' Set vars
    bFound = False
    bSending = False
    
    ' Get outlook outbox items
    If CreateOutlook Then
    
        Set oItems = oApp.GetNamespace("MAPI").GetDefaultFolder(olOutbox).Items

        ' Get first item
        Set oOutbox = oItems.GetFirst

        ' Check if matches
        If (oOutbox.UserProperties.Item("EmailRef") Is Nothing) Then
            bFound = False
        Else
            bFound = (oOutbox.UserProperties.Item("EmailRef").Value = sEmailRef)
        End If

        ' Loop rest of outbox items
        Do While (Not (oMsg Is Nothing)) And (Not bFound) And (Not bSent)
            
            ' Get next item
            Set oOutbox = oItems.GetNext
            
            ' Check if matches
            If (oOutbox.UserProperties.Item("EmailRef") Is Nothing) Then
                bFound = False
            Else
                bFound = (oOutbox.UserProperties.Item("EmailRef").Value = sEmailRef)
            End If
            
        Loop
        
    End If
    
Exit_CheckOutbox:
    
    Set oItems = Nothing
    Set oOutbox = Nothing
    Call ClearOutlook
    CheckOutbox = bFound Or (bSending And (Not bSent))
    Exit Function
    
Error_CheckOutbox:
    
    If err.Number = -2147221228 Then
        bSending = True
        bSent = GetSentEmail
        Resume Next
    Else
        Resume Exit_CheckOutbox
    End If
    
End Function

' Check sent items for email
Private Function GetSentEmail() As Boolean

On Error GoTo Error_GetSentEmail

    Dim oItems As Object
    Dim bFound As Boolean
    Dim iCnt As Integer
    bFound = False
    iCnt = 1
    
    ' Get outlook sent items
    If CreateOutlook Then

        Set oItems = oApp.GetNamespace("MAPI").GetDefaultFolder(olSentItems).Items

        ' Get last item
        Set oMsg = oItems.GetLast
        
        ' Check if matched
        If (oMsg.UserProperties.Item("EmailRef") Is Nothing) Then
            bFound = False
        Else
            bFound = (oMsg.UserProperties.Item("EmailRef").Value = sEmailRef)
        End If

        ' Loop rest of sent items based on max sent items range
        Do While (Not bFound) And (iCnt <= iMaxSentItems) And (Not (oMsg Is Nothing))

            ' Get next mail item
            Set oMsg = oItems.GetPrevious
            
            iCnt = iCnt + 1

            ' Check if matches
            If (oMsg.UserProperties.Item("EmailRef") Is Nothing) Then
                bFound = False
            Else
                bFound = (oMsg.UserProperties.Item("EmailRef").Value = sEmailRef)
            End If
            
        Loop
        
    End If
       
Exit_GetSentEmail:
    
    Set oItems = Nothing
    GetSentEmail = bFound
    Exit Function
    
Error_GetSentEmail:

    Call AddError(14)
    Call ClearOutlook
    Resume Exit_GetSentEmail
    
End Function

' Check path helper
Private Function CheckPath(ByVal sPath As String, ByVal bCreate As Boolean) As Boolean

On Error GoTo Error_CheckPath

    Dim vDrive As Variant
    Dim vPath As Variant
    CheckPath = False
    Dim sDir As String
    Dim i As Integer
    sDir = ""

    If Len(Trim(Dir(sPath, vbDirectory))) = 0 Then
    
        If bCreate Then
        
            ' Get drive
            vDrive = Split(sPath, ":", , vbTextCompare)
        
            If UBound(vDrive) <> 1 Then
                Call AddError(12)
            Else
            
                ' Split out path
                vPath = Split(vDrive(1), "\", , vbTextCompare)
                sDir = vDrive(0) & ":"
                
                ' Loop and create
                For i = 0 To UBound(vPath)
                    sDir = sDir & vPath(i) & "\"
                    If Len(Trim(Dir(sDir, vbDirectory))) = 0 Then
                        MkDir sDir
                    End If
                Next i
                
            End If

            If Len(Trim(Dir(sPath, vbDirectory))) > 0 Then
                CheckPath = True
            End If
                
        End If
        
    Else
        CheckPath = True
    End If
    
Exit_CheckPath:

    Exit Function
    
Error_CheckPath:

    CheckPath = False
    Call AddError(99, err.Description)
    Resume Exit_CheckPath
    
End Function

"In complete darkness we are all the same, it is only our knowledge and wisdom that separates us, don't let your eyes deceive you."

"If a shortcut was meant to be easy, it wouldn't be a shortcut, it would be the way!"
Free Electronic Dance Music

 

[1DMF]

Well I decided to come at it from a different angle.

Rather than risk interrupting the flow of email transition from Drafts->Outbox->SentItems and rather than trying to be clever with my progress messages (oh it's in drafts, oh it's in the outbox, oh it's in the sent items)

What I really care about is when the email is finally in the sent items.

So I altered my GetSentEmail routine to a private helper method, and added a public CheckSentItems that uses the existing internal timeout loop counter and GetSentEmail.

' Check sent items for email (public method that wraps GetSentEmail with timeout loop counter)
Public Function CheckSentItems() As Boolean

On Error GoTo Error_CheckSentItems

    Dim oItems As Object
    CheckSentItems = False
    
    ' clear counters
    Call ResetStatus
    
    ' Try to get email from sent items
    Do While Me.OK And iTimeOutCnt <= iTimeOut And Not GetSentEmail
        Call AddProgress("Checking sent items, please wait...")
        iTimeOutCnt = iTimeOutCnt + 1
        Sleep 1000
    Loop
    
    ' Check if timed out
    If iTimeOutCnt >= iTimeOut Or Not Me.OK Then
        Call AddError(15)
    Else
        CheckSentItems = GetSentEmail
    End If
       
Exit_CheckSentItems:
    
    Set oItems = Nothing
    Exit Function
    
Error_CheckSentItems:

    Call AddError(15)
    Call ClearOutlook
    Resume Exit_CheckSentItems
    
End Function

This then means I altered my Save code as follows....

' Save email routine
Public Sub Save(ByVal sDestPath As String, ByVal sFilename As String, Optional bCreate As Boolean = False)

On Error GoTo Save_Email_Error

    Dim sDest As String
    Dim bOK As Boolean
    
    ' Check if save possible
    If Not bSave Or Nz(sEmailRef, "") = "" Then
        Call AddError(8)
    Else
            
        [b]        
        ' Try to get email from sent items
        bOK = CheckSentItems
        
        ' Check if timed out
        If iTimeOutCnt >= iTimeOut Then
            Call AddError(10)
        End If[/b]
                                
        ' Continue if no errors
        If Me.OK And bOK Then
                         
            ' Check if path exists / cannot be created
            If Not CheckPath(sDestPath, bCreate) Then
                Call AddError(11)
            Else
                Call AddProgress("Saving email, please wait.")
                
                ' Save email
                sDest = sDestPath & "\" & Replace(sFilename, ".msg", "", , , vbTextCompare) & ".msg"
                oMsg.SaveAs sDest, olEmailMsg
                
                Call AddProgress("Emailed saved successfully.")
                
            End If
        
        End If
        
    End If
    
Exit_Save_Email:

    ' Clear Outlook email objects
    Call ClearOutlook
    Exit Sub
    
Save_Email_Error:

    ' Failed to save email
    Call AddError(5, err.Description)
    Resume Exit_Save_Email
    
End Sub

Where I have done away with trying to check the outbox and also use the new CheckSentItems which meant I could remove the timeout loop in the Save method (though I still alter the last error if it times out ) so in theory I will only call the 'Save' method if the email has reached SentItems....

I have in my form code that uses the emailwrapper... (abstraction extraction)

...            sMSG = sMSG & vbCrLf & vbCrLf & "Are you sure you want to continue?" & vbCrLf & vbCrLf
            sMSG = sMSG & ">>> NOTE <<<" & vbCrLf & vbCrLf
            sMSG = sMSG & "Do NOT continue by clicking 'Yes' until you have sent the email, if you fail to send the email the system will notify for you of this, but will NOT sent it on your behalf!" & vbCrLf & vbCrLf
            sMSG = sMSG & "Clicking 'No' will delete the email and abort the process!"
             
            If vbYes = MsgBox(sMSG, vbYesNo) Then
                
                ' loop until sent email is found or user quits
                bQuit = False
                Do While Not bQuit And Not oEmail.CheckSentItems
                    If vbNo = MsgBox("I was unable to find the email in your sent items, did you send it?" & vbCrLf & vbCrLf & "Please check email is in your sent items and click 'Yes' to try again." & vbCrLf & vbCrLf & "Selecting 'No' will attempt to delete the email from your drafts and abort the email process.", vbYesNo) Then
                        bOK = False
                        bQuit = True
                        Exit Do
                    End If
                Loop
                
                ' check ok to continue with saving email
                If bOK Then ...

So now instead of tracking the emails transition and trying to send the email on their behalf if they fail to send it, it loops till it finds the email in the sent items or timeout is reached, if found , continue with save, otherwise prompt the user to check the email was sent ok, and allow them to abort the process if desired.

This so far has eliminated the issues we have been experiencing, but will need a good week or so in use before I can say for sure!




"In complete darkness we are all the same, it is only our knowledge and wisdom that separates us, don't let your eyes deceive you."

"If a shortcut was meant to be easy, it wouldn't be a shortcut, it would be the way!"
Free Electronic Dance Music

 

[strongm]

Perhaps you could outline what it is that your code is supposed to achieve, as there may well be (I rather suspect) a much more elegant way of doing it ...

 

[1DMF]

Well it's a class wrapper for the Outlook Object Model OOM.

It enables me to easily build, display, send and save emails through a simple class object. I'm sure you of all people could have worked that out from the code!

So I dynamically build an HTML email, add recipients (TO/CC/BCC), attachments, signatory etc. all through the EmaillWrapperII protocol.

It then displays the email, so the checkers and spell check , add stuff etc..

Once they send the email, the system then needs to save the email to a mapped network drive location.

All this includes a nice progress window for the user so they can see what stage the process is at. (oh the wrapper also ensures outlook is open!).

The problem is such that if you try to grab an email using VBA that has had send issued via the Outlook GUI, it sometimes stops the email sending, or it sends two copies, because my original code was looking for the email in drafts too quickly, thinking they forgot to send the email and so sent it again. I have also found that if you grab an email the second it hits the outbox, before it actually starts transmitting, it can halt the email from ever transmitting (until another send/receive is issued), which is why if you try to grab an email via VBA when it is actually transmitting, it will throw an error!

All this was causing a lot of problems, and so I decided to remove the drafts / outbox checking and just look for the email in sent items.... So far all the problems have now gone away.

It had a lot to do with the version of Office being used as well as the speed of the machine running the app as not all users were affected...

The only user on Office 2007, had issues with duplicate emails being sent by them / received by the recipient, but only one email was appearing in the Outlook sent items, it was only when this user was upgraded to Office 2013, did the duplicate emails appear in the sent items, tracking this down was a pain as this was the main user causing duplication emails, but only one could be seen, upgrading Office didn't resolve the problem, it simply highlighted the issue was else where!

Then there is the nightmare that is McAfee, everyone is still on crappy IE9 because the virus update process uses IE and it doesn't work with >IE9, so the OOMG was going crazy, plus I'm sure the McAfee Email Outlook COM VirusScan plugin was interrupting the flow, causing issues.

The changes I have just implemented, so far...touch wood... have resolved these issues, but I'm sure you will be able to help tart it up... I mean make it more elegant ;-)

my OOP has come a long way, but the journey isn't over!



"In complete darkness we are all the same, it is only our knowledge and wisdom that separates us, don't let your eyes deceive you."

"If a shortcut was meant to be easy, it wouldn't be a shortcut, it would be the way!"
Free Electronic Dance Music

 

[strongm]

>I'm sure you of all people could have worked that out from the code!

Oh, I can see what each element in your class supposedly does - just not how you are actually using the class.

Not quite sure why you need to grab an email, nor why you need to track it through the various folders. And cannot tell from the code why you'd want to put the mail into drafts first.

You already have a reference to the MailItem (oMsg, although oddly you decide to throw it away and use EntryID instead), and the Parent of a MailItem contains the name of the folder it is currently in, and the Sent property indicates whether it has been sent or not. A MailItem also has a Send event, as does the Outlook Application.

With that knowledge, you should be able to reduce all your folder searching to instead responding to a Send event which is issued just before the MailItem moves from it's current folder to Sent, and then perhaps polling the Sent property. Still, seems a pity to have to resort to polling when we have all these events. Maybe there's a better approach.

As it happens Outlook folder collections (Outlook.Folders) have something events, one of which is FolderChange ...

 

[strongm]

Here's some example code, which may help you to cut yours down a bit. For it to work you simply need to call App_Initialize. After that, any email entering the Sent Items folder is acted on (and note that this happens after the item is moved into the folder)

[blue]Option Explicit

Public WithEvents oFolders As Outlook.Folders

Public Sub App_Initialize()
    Set oFolders = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderSentMail).Parent.Folders
End Sub

Private Sub oFolders_FolderChange(ByVal Folder As MAPIFolder)
    Dim oMsg As Object
    If Folder.Name = "Sent Items" Then
        Set oMsg = Folder.Items(1) ' should be most recent item
        oMsg.SaveAs "c:\downloads\example.msg", olMSG
    End If
End Sub[/blue]

 

[1DMF]

Not quite sure why you need to grab an email, nor why you need to track it through the various folders. And cannot tell from the code why you'd want to put the mail into drafts first.

I need to grab the email to save it, the email being sent might not be the one I created through the app.

The checkers may have an open email generated from the system, which they are editing, but also reply to other emails in-between. Watching sent items for most recent is not going to work in this scenario. I also find there is no UID across mail folders, so I actually use a UDP (User Defined Property) to uniquely identify the email...

            ' add email reference
            If sEmailRef <> "" Then
                Call AddProgress("Adding email reference.")
                .UserProperties.Add "EmailRef", olText
                .UserProperties.Item("EmailRef").value = sEmailRef
                bSave = True
            Else
                bSave = False
            End If

I am not putting an email in drafts, that's where Outlook puts any email currently being created. I simply generate the base content of the email and then display it. The email resides in drafts, not put in drafts. The checkers edit the email, then send it.

I am intrigued with the sent property or any event I can use to track the email better, OK I trash the originating mail item oMSG object, and have helpers to get the email again, but as you say, keep polling the sent property in effect is no different than keep checking the sent items as I currently have it.

I could use the event you mention as a trigger to check the sent items for the email, but the code still needs to pause as currently it is a nasty piece of procedural click event on a form to kick of the entire process (and there is a lot going on besides generating the email).

I have a lot of refactoring to do to wrap some of this up in a transaction with rollback functionality, which might make adding this event watching a little easier moving forward.

I've cleaned the code up considerably when I developed this email wrapper object, but still a way to go yet.

Though not sure how this folder watching / event listening will work, when I need to wait for the checker to send the email, and then continue with updating DB records, sending internal emails depending on certain criteria etc..

How else could this be achieved rather than the current ...

sMSG = sMSG & vbCrLf & vbCrLf & "Are you sure you want to continue?" & vbCrLf & vbCrLf
            sMSG = sMSG & ">>> NOTE <<<" & vbCrLf & vbCrLf
            sMSG = sMSG & "Do NOT continue by clicking 'Yes' until you have sent the email, if you fail to send the email the system will notify for you of this, but will NOT sent it on your behalf!" & vbCrLf & vbCrLf
            sMSG = sMSG & "Clicking 'No' will delete the email and abort the process!"
             
            If vbYes = MsgBox(sMSG, vbYesNo) Then
                
                ' loop until sent email is found or user quits
                bQuit = False
                Do While Not bQuit And Not oEmail.CheckSentItems
                    If vbNo = MsgBox("I was unable to find the email in your sent items, did you send it?" & vbCrLf & vbCrLf & "Please check email is in your sent items and click 'Yes' to try again." & vbCrLf & vbCrLf & "Selecting 'No' will attempt to delete the email from your drafts and abort the email process.", vbYesNo) Then
                        bOK = False
                        bQuit = True
                        Exit Do
                    End If
                Loop

I create the email, then have to pause and wait for them to confirm they have sent the email, then look for it and if found continue with a tonne of other processing.

I could change this to simply check the sent property and parent folder attribute for being in 'Sent Items', it means refactoring my EmailWrapper to not trash the oMSG object once created, but doesn't then save much else does it?

And what happens if I have a drafts mailitem object in memory (oMSG) and the user deletes the email, do I still have the email in oMSG, so I have no idea the email was deleted? Or I need to check other attributes / properties to find out what happened to the email?

"In complete darkness we are all the same, it is only our knowledge and wisdom that separates us, don't let your eyes deceive you."

"If a shortcut was meant to be easy, it wouldn't be a shortcut, it would be the way!"
Free Electronic Dance Music

 

[strongm]

>I am not putting an email in drafts, that's where Outlook puts any email currently being created

Typically, it doesn't actually.

if you stick a

Debug.? Folder.Name

in my function you'll see all the folders that a new email goes through (Outbox then Sent Items, typically). It is certainly the case if you save email before sending it that it Outlook puts it into Drafts by default, but not otherwise - and that was what I was questioning: why do you need to save it? Which you've now addressed. But you can perhaps see now why I asked what your code was doing, since pretty much none of what you have just explained can be deduced from the code itself.

 

[1DMF]

Oh, I didn't realise that only if you save it goes into drafts, though I was working on an email, that I didn't click save on, and it is in drafts currently.

So I think there is some timed 'auto-save' going on somewhere, which gave me the impression all emails start in drafts, as you 'draft' them.

This is also the behaviour of most webmail apps, they instantly save any email you are drafting in drafts, well my Gmail via Virgin seems to behave that way, which I think is a hand feature should things go pear shaped.

But you can perhaps see now why I asked what your code was doing, since pretty much none of what you have just explained can be deduced from the code itself.

For sure, so I take it from my wider overview, there isn't really many other ways to handle this, especially as they need the flexibility to mess with the email prior to continuing with other processing.

This is partly why my wrapper gets the email in question when needed and lets go of it otherwise.

Create email, save in drafts...let go of it.

Want the email displayed, find it and display it... let go of it.

Want the email sent, find it, send it... let go of it.

Want the emailed saved to disk, find it, save it... let go of it.

This way outlook can mess about, do stuff, send other emails, etc.. etc.. without me having hold of an email object and hoping it stays in scope.

I took the decision that I would only have hold of the email item at the point I needed to do something with it, otherwise leave it alone.

Do you feel this is not a good approach then, or now you have a better overview of the situation, it's an acceptable solution?










"In complete darkness we are all the same, it is only our knowledge and wisdom that separates us, don't let your eyes deceive you."

"If a shortcut was meant to be easy, it wouldn't be a shortcut, it would be the way!"
Free Electronic Dance Music

 

[strongm]

>Watching sent items for most recent is not going to work in this scenario

OK, fair enough

>I also find there is no UID across mail folders

Correct

>so I actually use a UDP

Yep, fine

Even so, I think you can still work with events - and additionally not enumerate through a folder looking for a matching email. It is possible to directly search against a UserProperty simply by telling the parent folder that such a property exists. Here is a slight reworking of my original code (and remember it is just illustrative) to take into account the obeservations that you made:

[blue]Option Explicit

Public WithEvents oFolders As Outlook.Folders
Public WithEvents oMsg As MailItem
Public sEntryID As String

' Grabbing a reference to folders root and to our message, both of which can raise events
' You may do this in some other way.
Private Sub Application_ItemLoad(ByVal Item As Object)
    Set oFolders = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderSentMail).Parent.Folders
    Set oMsg = Item
End Sub

' Just a shim for this example that give us the opportunity to grab an EntryID and save it in our custom property
Private Sub oMsg_PropertyChange(ByVal Name As String)
    If sEntryID = "" Then
        oMsg.Save
        sEntryID = oMsg.EntryID
        oMsg.UserProperties.Add("MyID", olText) = sEntryID
    End If
End Sub

Private Sub oFolders_FolderChange(ByVal Folder As MAPIFolder)
    If Folder.Name = "Sent Items" Then
        Application.GetNamespace("MAPI").GetDefaultFolder(olFolderSentMail).UserDefinedProperties.Add "MyID", olText ' so we can 'Find' against it
        With Folder.Items.Find("[MyID] = '" & sEntryID & "'")
            .SaveAs "c:\downloads\mike.msg", olMSG
            sEntryID = ""  ' All finished with this message, so throw away our ID
        End With
    End If
End Sub[/blue]

 

[1DMF]

Interesting, I will be working on this next week, so will look how I may be able to incorporate event monitoring.

My only issue is the fact that I have to wait for the email to be sent before continuing with other processing and not just the saving the email bit!

This needs to be reworked so the change event triggers the continuation... hmm will need some thought for sure!

As I mentioned previously, some of this is being wrapped up in a transaction, so it will make things a little easier to work with.

As always, your input has been very much appreciated.

"In complete darkness we are all the same, it is only our knowledge and wisdom that separates us, don't let your eyes deceive you."

"If a shortcut was meant to be easy, it wouldn't be a shortcut, it would be the way!"
Free Electronic Dance Music