Здравствуйте!
Есть макрос (даже не макрос, а целый модуль), который вызывает диалоговое окно, а потом оно само гаснет. Можно задать время отображения.
Раньше модуль отлично работал, а тут стал выдавать ошибку. То ли из-за перехода с 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