[AccessD] Automating Outlook - clsOfficeOutlook

[John Colby]

I use the class_initialize and class_Terminate events to initialize and
terminate objects wherever possible.  By using terminate this way I can
automatically release each and everything that gets initialized in one
place.  To be honest, I grabbed example code for much of this, and I am not
handling any events except one that Outlook uses to pass me an email object.

Private Sub mOLInboxItems_ItemAdd(ByVal item As Object)

is the event sink where I get the email.  All I do is check that the object
passed in is an email and then call a method of the email class, passing it
the email object.

  If TypeName(item) = "MailItem" Then
        'Result = MsgBox(MessageInfo, vbOKOnly, "New Message Received")
        mclsEmails.fEmailRcvd item
    End If

I apologize for the verboseness but I try to do error handlers as much as
possible, which can make it difficult to read.

Option Compare Database
Option Explicit
'
'************************
'Tools/DatabaseProperties/Conditional Compilation Arguments
'^^^^^^^^^^^^^^^^^^^^^^^^
'
https://www.add-in-express.com/creating-addins-blog/2013/06/03/outlook-mail-items-create-delete-access/
'https://www.rondebruin.nl/win/s1/outlook/openclose.htm
'https://bettersolutions.com/vba/debugging/conditional-compiling.htm
'
https://docs.microsoft.com/en-us/previous-versions/office/troubleshoot/office-developer/binding-type-available-to-automation-clients
'https://bettersolutions.com/outlook/mail/vba-code.htm
'https://www.msoutlook.info/question/check-for-new-email-frequency
'***
'Late binding allows us to work when we have not referenced the outlook
library
'This is used to allow the app to work with any version of the library
'however the library still must exist
'
'Early binding provides the developer tools such as Intellisense to see the
various properties and
'events of objects.  This is huge while developing but irrelevent in
production.
'
'However if you want to sink events, you must use early binding.
'Which makes it manditory for me.
'
'***
'

Private WithEvents mOLApp As Outlook.Application
Private WithEvents mOlNS As Outlook.NameSpace
Private WithEvents mOLMailItem As Outlook.MailItem
Private WithEvents mOLInboxItems As Outlook.Items
Private WithEvents mOLJunkMailItems As Outlook.Items
Event evNewMail()
Event evStartup()
Event evInitialOrder(lOLMailItem As Outlook.MailItem)
Event evRenewalOrder(lOLMailItem As Outlook.MailItem)

'
'***
'These constants replace built-in constants that could be used when early
binding
'
Const olMinimized As Long = 1
Const olMaximized As Long = 2
Const olFolderInbox As Long = 6

Dim mclsEmails As clsEmails 'This class actually processes the email

Private Sub Class_Terminate()
    Set mOLApp = Nothing
    Set mOlNS = Nothing
    Set mOLMailItem = Nothing
    Set mOLInboxItems = Nothing
    Set mOLJunkMailItems = Nothing
    Set mclsEmails = Nothing
End Sub
'
Private Sub Class_Initialize()
    On Error GoTo Class_Initialize_Error
    Set mOLApp = mOutlookApp()
    Set mOlNS = mOLApp.GetNamespace("MAPI")
    Set mOLInboxItems = mOlNS.GetDefaultFolder(olFolderInbox).Items
    Set mOLJunkMailItems = mOlNS.GetDefaultFolder(olFolderJunk).Items
    '
    'Get the email supervisor class
    '
    Set mclsEmails = New clsEmails

    'mOlNS.SendAndReceive cFW.SVAppCont("OLDisplayProgressBar")
    mOlNS.SendAndReceive True


Exit_Class_Initialize:
    On Error GoTo 0
    Exit Sub

Class_Initialize_Error:
Dim strErrMsg As String
    Select Case Err
    Case 0      'insert Errors you wish to ignore here
        Resume Next
    Case Else   'All other errors will trap
        strErrMsg = "Error " & Err.Number & " (" & Err.Description & ") in
procedure Advisor Notes Administration.clsOfficeOutlook.Class_Initialize,
line " & Erl & "."
        Beep
#If boolELE = 1 Then
        WriteErrorLog strErrMsg
#End If
        assDebugPrint strErrMsg
        Resume Exit_Class_Initialize
    End Select
    Resume Exit_Class_Initialize
    Resume 0    'FOR TROUBLESHOOTING
End Sub

'
' ----------------------------------------------------------------
' Procedure Name: OutlookApp
' Purpose: Discover whether Outlook is open.  If so grab a pointer
' Procedure Kind: Function
' Procedure Access: Public
' Parameter WindowState (Long):
' Parameter ReleaseIt (Boolean):
' Return Type: Object if late binding, Outlook.Application if early binding
' Author: John Colby
' Date: 7/5/2021
' ----------------------------------------------------------------

Public Function mOutlookApp( _
    Optional WindowState As Outlook.OlWindowState = olMinimized, _
    Optional ReleaseIt As Boolean _
) As Outlook.Application
On Error GoTo ErrHandler

    Select Case True
        '
        'This case is used when no existing instance is found,
        'i.e. Outlook is not opened yet
        '
        Case mOLApp Is Nothing, Len(mOLApp.Name) = 0
            Set mOLApp = GetObject(, "Outlook.Application")
            If mOLApp.Explorers.Count = 0 Then
InitOutlook:
                'Open inbox to prevent errors with security prompts
                mOLApp.Session.GetDefaultFolder(olFolderInbox).Display
                mOLApp.ActiveExplorer.WindowState = WindowState
            End If
        Case ReleaseIt
            Set mOLApp = Nothing
    End Select
    Set mOutlookApp = mOLApp

ExitProc:
    Exit Function
ErrHandler:
    Select Case Err.Number
        Case -2147352567
            'User cancelled setup, silently exit
            Set mOLApp = Nothing
        Case 429, 462
            '
            'Go to another function to try to open outlook
            'We do this because this process could generate an error
            'and we are already in an error handler.
            '
            Set mOLApp = mGetOutlookApp()
            If mOLApp Is Nothing Then
                Err.Raise 429, "mOutlookApp", "Outlook Application does not
appear to be installed."
            Else
                Resume InitOutlook
            End If
        Case Else
            MsgBox "Error " & Err.Number & ": " & Err.Description,
vbCritical, "Unexpected error"
    End Select
    Resume ExitProc
    Resume
End Function

'Private Sub mOLInboxItems_ItemAdd(ByVal item As Object)
' ----------------------------------------------------------------
' Procedure Name: mOLInboxItems_ItemAdd
' Purpose: Event handler for email item
' Procedure Kind: Sub
' Procedure Access: Private
' Parameter item (Object): The item passed in to the event handler
' Author: John Colby
' Date: 7/29/2021
' ----------------------------------------------------------------
Private Sub mOLInboxItems_ItemAdd(ByVal item As Object)
    On Error GoTo mOLInboxItems_ItemAdd_Error
    'Debug.Print "mOLInboxItems_ItemAdd"

    If TypeName(item) = "MailItem" Then
        'Result = MsgBox(MessageInfo, vbOKOnly, "New Message Received")
        mclsEmails.fEmailRcvd item
    End If


Exit_mOLInboxItems_ItemAdd:
    On Error GoTo 0
    Exit Sub

mOLInboxItems_ItemAdd_Error:
Dim strErrMsg As String
    Select Case Err
    Case 0      'insert Errors you wish to ignore here
        Resume Next
    Case Else   'All other errors will trap
        strErrMsg = "Error " & Err.Number & " (" & Err.Description & ") in
procedure Advisor Notes
Administration.clsOfficeOutlook.mOLInboxItems_ItemAdd, line " & Erl & "."
        Beep
#If boolELE = 1 Then
        WriteErrorLog strErrMsg
#End If
        assDebugPrint strErrMsg
        Resume Exit_mOLInboxItems_ItemAdd
    End Select
    Resume Exit_mOLInboxItems_ItemAdd
    Resume 0    'FOR TROUBLESHOOTING
End Sub
-- 
John W. Colby
Colby Consulting