Access vba - Hourglass while Outlook Opening - Outlook takes forever to open

We just moved to Outlook 365 which takes forever to open. I have a program that puts events into the Outlook calendar. It first checks to see if Outlook is open, and, if it's not, opens it. Because Outlook 365 takes forever to open, I would like to have an hour glass while it's opening. I put it in my code, but it looks like that it sees Outlook open as soon as it starts opening, so hour glass goes away, but I still have the Outlook opening box for it seems hours (lol). I can see potential issues of running the rest of my code if Outlook isn't fully open - like user is done with this event and goes to the next one - will it get confused as to what events to add/delete/modify in the calendar or does it keep a queue of what has to be done, especially because it looks like it's all done in Access. Any ideas? Here is the last code modification I tried. I did try to put the Hourglass before the if and after the endif, but that also didn't work.

 If IsAppRunning("Outlook.Application") = True Then    'Outlook was already running
        Set objApp = GetObject(, "Outlook.Application")    'Bind to existing instance of Outlook
    Else    'Could not get instance of Outlook, so create a new one
        sAPPPath = GetAppExePath("outlook.exe")    'determine outlook's installation path
        Shell (sAPPPath)    'start outlook
        Do While Not IsAppRunning("Outlook.Application")
            DoEvents
            DoCmd.Hourglass True  ' turn on Hourglass
        Loop
        If IsAppRunning("Outlook.Application") = True Then
            Set objApp = GetObject(, "Outlook.Application")    'Bind to existing instance of Outlook
            DoCmd.Hourglass False ' turn off hourglass
        End If
    End If

And here are the functions that go with it:

Function IsAppRunning(sApp As String) As Boolean
    On Error GoTo Error_Handler
    Dim oApp            As Object

    Set oApp = GetObject(, sApp)
    IsAppRunning = True

Error_Handler_Exit:
    On Error Resume Next
    Set oApp = Nothing
    Exit Function

Error_Handler:
    Resume Error_Handler_Exit
End Function
Function GetAppExePath(ByVal sExeName As String) As String
    On Error GoTo Error_Handler
    Dim WSHShell        As Object

    Set WSHShell = CreateObject("Wscript.Shell")
    GetAppExePath = WSHShell.RegRead("HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\" & sExeName & "\")

Error_Handler_Exit:
    On Error Resume Next
    Set WSHShell = Nothing
    Exit Function

Error_Handler:
    If Err.Number = -2147024894 Then
        'Cannot locate requested exe????
    Else
        MsgBox "The following error has occurred." & vbCrLf & vbCrLf & _
               "Error Number: " & Err.Number & vbCrLf & _
               "Error Source: GetAppExePath" & vbCrLf & _
               "Error Description: " & Err.Description, _
               vbCritical, "An Error has Occurred!"
    End If
    Resume Error_Handler_Exit
End Function

Not sure if I'm Tagging this correctly...