|
|
|
|
|
|
|
|
Dicas
|
|
|
Visual Basic (ActiveX/Controles/DLL)
|
|
 |
Título da Dica: MensageBox Temporizada
|
 |
|
|
|
Postada em 1/3/2007 por Edinei
neisjb@hotmail.com
' no form;
coloque um CommandButton no form não renomeie
Option Explicit
Private Sub cmdExit_Click()
End
End Sub
Private Sub Command1_Click()
Dim nei As String
Dim nei2 As VbMsgBoxResult
If Val(Text1) >= 1 Then
nei = " Digitar Alguma Coisa "
nei2 = MsgBoxEx(nei, Val(Text1), vbQuestion)
If nei2 = 0 Then
Else
End If
Else
nei = "Entre com um valor maior que Zero!."
MsgBox "Esta em Branco!"
End If
End Sub
Private Sub Form_Load()
End Sub
Private Sub Text1_Change()
End Sub
'Agora no Modulo ;
Option Explicit
Private Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String) As Long
Private Declare Function GetDlgCtrlID Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function EnumChildWindows Lib "user32" (ByVal hWndParent As Long, ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
Private Const WH_CBT = 5
Private Const HCBT_ACTIVATE = 5
Private Const WM_CLOSE = &H10
Private Const BN_CLICKED = 0
Private Const WM_COMMAND = &H111
Private m_lMsgHandle As Long
Private m_lNoHandle As Long
Private m_lhHook As Long
Private bTimedOut As Boolean
Private sMsgText As String
Private lCount As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Function EnumChildWindowsProc(ByVal hWnd As Long, ByVal lParam As Long) As Long
Dim lRet As Long
Dim sClassName As String
sClassName = Space(100)
lRet = GetClassName(hWnd, sClassName, 100)
sClassName = Left$(sClassName, lRet)
Debug.Print sClassName
If UCase$(sClassName) = UCase$("Button") Then
m_lNoHandle = hWnd
EnumChildWindowsProc = 0
Else
EnumChildWindowsProc = 1
End If
End Function
' *********************************************************************************************************
Private Function GetMessageBoxHandle(ByVal lMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
If lMsg = HCBT_ACTIVATE Then
'Release the CBT hook
m_lMsgHandle = wParam ' Msg Box Window Handle
UnhookWindowsHookEx m_lhHook
m_lhHook = 0
EnumChildWindows m_lMsgHandle, AddressOf EnumChildWindowsProc, 0
End If
GetMessageBoxHandle = False
End Function
Private Sub MessageBoxTimerUpdateEvent(hWnd As Long, uiMsg As Long, idEvent As Long, dwTime As Long)
Dim lRet As Long
Dim sStr As String
If m_lMsgHandle = 0 Then Exit Sub
lCount = lCount + 1
If sMsgText = "" Then
sStr = Space(255)
lRet = GetWindowText(m_lMsgHandle, sStr, 255)
sStr = Left$(sStr, lRet)
sMsgText = sStr
End If
sStr = sMsgText
SetWindowText m_lMsgHandle, sStr
End Sub
Private Sub MessageBoxTimerEvent(hWnd As Long, uiMsg As Long, idEvent As Long, dwTime As Long)
If m_lNoHandle = 0 Then
SendMessage m_lMsgHandle, WM_CLOSE, 0, 0
Else
Dim lButtonCommand
lButtonCommand = (BN_CLICKED * (2 ^ 16)) And &HFFFF
lButtonCommand = lButtonCommand Or GetDlgCtrlID(m_lNoHandle)
SendMessage m_lMsgHandle, WM_COMMAND, lButtonCommand, m_lNoHandle
End If
m_lMsgHandle = 0 ' Set handle to ZERO
m_lNoHandle = 0 ' Set handle to ZERO
bTimedOut = True ' Set flag to True
End Sub
Public Function MsgBoxEx(sMsgText As String, dwWait As Long, Optional Buttons As VbMsgBoxStyle = vbOKOnly, Optional sTitle As String = "Atenção") As VbMsgBoxResult
Dim lTimer As Long
Dim lTimerUpdate As Long
m_lhHook = SetWindowsHookEx(WH_CBT, AddressOf GetMessageBoxHandle, App.hInstance, GetCurrentThreadId())
lTimer = SetTimer(0, 0, dwWait * 1000, AddressOf MessageBoxTimerEvent) ' Set timer
lTimerUpdate = SetTimer(0, 0, 1 * 1000, AddressOf MessageBoxTimerUpdateEvent) ' Set timer
bTimedOut = False
MsgBoxEx = MsgBox(sMsgText, Buttons, sTitle)
Call KillTimer(0, lTimer)
Call KillTimer(0, lTimerUpdate)
sMsgText = ""
lCount = 0
If bTimedOut = True Then MsgBoxEx = 0
End Function
|
|
|
|
|
