Блог

Мы только что перешли на Outlook 365, открытие которого занимает целую вечность. У меня есть программа, которая помещает события в календарь Outlook. Сначала он проверяет, открыт ли Outlook, и, если это не так, открывает его. Я хотел бы иметь песочные часы во время их открытия.

Я вставил это в свой код, но похоже, что он видит, что Outlook открыт, как только он начинает открываться, поэтому песочные часы исчезают.

Вот последняя модификация кода, которую я пробовал:

 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
 

И функции, которые идут с ним:

 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_MACHINESOFTWAREMicrosoftWindowsCurrentVersionApp Paths" amp; sExeName amp; "")
 
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." amp; vbCrLf amp; vbCrLf amp; _
               "Error Number: " amp; Err.Number amp; vbCrLf amp; _
               "Error Source: GetAppExePath" amp; vbCrLf amp; _
               "Error Description: " amp; Err.Description, _
               vbCritical, "An Error has Occurred!"
    End If
    Resume Error_Handler_Exit
End Function