VBA Макросы: Самогаснущие диалоговые окна

Автор auto-teacher, 26 сентября 2017, 21:58

auto-teacher

Здравствуйте!
Есть макрос (даже не макрос, а целый модуль), который вызывает диалоговое окно, а потом оно само гаснет. Можно задать время отображения.
Раньше модуль отлично работал, а тут стал выдавать ошибку. То ли из-за перехода с 32-битной системы на 64-битную, то ли еще от чего.
Может быть, таймер по-другому надо вызывать. Я слабоват в этом деле.
Подскажите, пожалуйста, что надо исправить.
Код модуля такой:
Спойлер
' To display a timed Msgbox use the MsgboxOKDrop routine given below.

'API calls for Msgbox2. Must be placed in a standard module
Declare PtrSafe Function SetTimer Lib "user32" (ByVal Hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Declare PtrSafe Function KillTimer Lib "user32" (ByVal Hwnd As Long, ByVal nIDEvent As Long) As Long
Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal Hwnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As Any) As Long
Private zsMessageTitle As String, lTimerId As Long

Sub СамогаснущееОкно()
    Dim lRetVal As Long
    lRetVal = MsgboxOKDrop("Это окно исчезнет через 5 секунд.", vbOKOnly + vbInformation, "Самогаснущее окно", 5000)
End Sub

Function MsgboxOKDrop(Prompt As String, Buttons As VbMsgBoxStyle, Title As String, _
                        Optional DisplayTime As Long = 3000) As VbMsgBoxResult
    If DisplayTime > 0 Then
        'Enable the timer
        StartTimer DisplayTime
        zsMessageTitle = Title
    End If
    MsgboxOKDrop = MsgBox(Prompt, Buttons, Title)
    'Stop the timer
    EndTimer
End Function

Sub StartTimer(lInterval As Long)
    If lTimerId Then
        EndTimer
    End If
    lTimerId = SetTimer(0&, 0&, ByVal lInterval, AddressOf TimerRoutine)
End Sub

Function EndTimer() As Boolean
    If lTimerId Then
        lTimerId = KillTimer(0&, lTimerId)
        lTimerId = 0
        EndTimer = True
    End If
End Function

Private Sub TimerRoutine(ByVal lHwnd As Long, ByVal lMsg As Long, ByVal lIDEvent As Long, ByVal lTime As Long)
    Const WM_CLOSE = &H10
    Dim lHwndMsgbox As Long

    'Find the Msgbox
    lHwndMsgbox = FindWindow(vbNullString, zsMessageTitle)
    'Close Msgbox
    Call SendMessage(lHwndMsgbox, WM_CLOSE, 0, ByVal 0&)
End Sub
[свернуть]
При отладке ошибка выскакивает на строке, выделенной желтым.

[вложение удалено администратором]

Администратор

Да, для офиса 64 нужно изменять api-функции и ещё нужно в макросах регулировать типы данных у переменных и другого.

Версия для офиса 32 и 64, для офиса 2010+. Для офиса 2003 и 2007 наверное нужно делать два таких кода полностью, т.к. в офисе 2003 и 2007 нет LongPtr.
Макрос
' To display a timed Msgbox use the MsgboxOKDrop routine given below.

'API calls for Msgbox2. Must be placed in a standard module
#If VBA7 Then
    Declare PtrSafe Function SetTimer Lib "user32" (ByVal Hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Declare PtrSafe Function KillTimer Lib "user32" (ByVal Hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
    Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal Hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
#Else
    Declare Function SetTimer Lib "user32" (ByVal Hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Declare Function KillTimer Lib "user32" (ByVal Hwnd As Long, ByVal nIDEvent As Long) As Long
    Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal Hwnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As Any) As Long
#End If
Private zsMessageTitle As String, lTimerId As LongPtr

Sub СамогаснущееОкно()
    Dim lRetVal As LongPtr
    lRetVal = MsgboxOKDrop("Это окно исчезнет через 5 секунд.", vbOKOnly + vbInformation, "Самогаснущее окно", 5000)
End Sub

Function MsgboxOKDrop(Prompt As String, Buttons As VbMsgBoxStyle, Title As String, _
                        Optional DisplayTime As Long = 3000) As VbMsgBoxResult
    If DisplayTime > 0 Then
        'Enable the timer
        StartTimer DisplayTime
        zsMessageTitle = Title
    End If
    MsgboxOKDrop = MsgBox(Prompt, Buttons, Title)
    'Stop the timer
    EndTimer
End Function

Sub StartTimer(lInterval As Long)
    If lTimerId Then
        EndTimer
    End If
    lTimerId = SetTimer(0&, 0&, ByVal lInterval, AddressOf TimerRoutine)
End Sub

Function EndTimer() As Boolean
    If lTimerId Then
        lTimerId = KillTimer(0&, lTimerId)
        lTimerId = 0
        EndTimer = True
    End If
End Function

Private Sub TimerRoutine(ByVal lHwnd As LongPtr, ByVal lMsg As LongPtr, ByVal lIDEvent As LongPtr, _
                            ByVal lTime As LongPtr)
    Const WM_CLOSE = &H10
    Dim lHwndMsgbox As LongPtr

    'Find the Msgbox
    lHwndMsgbox = FindWindow(vbNullString, zsMessageTitle)
    'Close Msgbox
    Call SendMessage(lHwndMsgbox, WM_CLOSE, 0, ByVal 0&)
End Sub
[свернуть]

auto-teacher

Очень благодарен за ответ!
Сейчас пока вновь вернул 32-разрядный офис в 64-разрядный Win 10 Pro, а потом обязательно воспользуюсь Вашими исправлениями.
Главное, я понял, в чем была несостыковка.
Спасибо!