Supportnet / Forum / Datenbanken
!!! Zeitgesteuerte MsgBox !!! Leider bisher nur Formularabhängig
Frage
Hallo Zusammen da bestimmt viele daran interessiert sind hier ein kleiner Beitrag von mir als Dankeschön an die viele Hilfe die mir schon geleistet wurde:
Viele Sachen die ich bisher gefunden habe liefen entweder gar nicht oder nur so halb oder waren schwer implementierbar, deswegen diese Arbeit....
Leider ists noch nicht perfekt, aber ein Anfang:
[b]Diesen Code als Modul einfügen:[/b]
[code]Option Compare Database
Option Explicit
'// Basiert auf einem Beispiel von:
'// Bryan Stafford (http://www.mvps.org/vbvision)
Public Declare Function WinMessageBox _
Lib "user32.dll" Alias "MessageBoxA" ( _
ByVal hwnd As Long, _
ByVal lpText As String, _
ByVal lpCaption As String, _
ByVal wType As Long) As Long
Private Declare Function WinPostMessage _
Lib "user32.dll" Alias "PostMessageA" ( _
ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Private Declare Function WinFindWindow _
Lib "user32.dll" Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Public Declare Function WinSetTimer _
Lib "user32.dll" Alias "SetTimer" ( _
ByVal hwnd As Long, _
ByVal nIDEvent As Long, _
ByVal uElapse As Long, _
ByVal lpTimerFunc As Long) As Long
Public Declare Function WinKillTimer _
Lib "user32.dll" Alias "KillTimer" ( _
ByVal hwnd As Long, _
ByVal nIDEvent As Long) As Long
Public Const NV_CLOSEMSGBOX As Long = &H5000&
Private Const WM_CLOSE As Long = &H10&
Public MsgBox2_Title As String
Public Sub TimerProc( _
ByVal hwnd As Long, _
ByVal uMsg As Long, _
ByVal idEvent As Long, _
ByVal dwTime As Long)
'// Callback-Funktion
'// Windows ruft diese Funktion auf, wenn ein Timer-Ereignis eingetreten ist,
'// die Festlegung, dass es diese Prozedur sein soll, wurde beim Setzen des
'// Timers festgelegt
'// Als Erstes wird der Timer wieder entfernt
Call WinKillTimer(hwnd, idEvent)
'// Jetzt die Manipulation
Select Case idEvent
Case NV_CLOSEMSGBOX '// Schliessen der MsgBox nach einer vorher
'// bestimmten Zeit
Dim hMessageBox As Long
'// MsgBox finden
hMessageBox = WinFindWindow("#32770", MsgBox2_Title)
'// Die Nachricht WM_CLOSE as das Fenster senden
If hMessageBox Then
Call WinPostMessage(hMessageBox, WM_CLOSE, ByVal 0&, ByVal 0&)
End If
End Select
End Sub
[/code]
[b]Dies in das Formular kopieren:[/b]
[code]
Option Compare Database
Option Explicit
Private Sub cmdClose_Click()
DoCmd.Close acForm, Me.Name
End Sub
Private Sub cmdShowMsgBox_Click()
'Aufruf der Funktion
MsgBox2 "Hallo Welt1", 1, "titel"
MsgBox2 "Hallo Welt2", 1, "Mein Titel", 1
MsgBox2 "Hallo Welt3!", 1, "Mein Titel", 1, 2 'Probleme, siehe unten Case 234, bricht nicht ab
MsgBox2 "Hallo Welt4", 1, "Mein Titel", 1, 5
End Sub
Public Sub MsgBox2(strMessage As String, intTime As Integer, Optional strTitle As String = "InformationBox", _
Optional intIcon As Integer = 3, Optional intButton As Integer = 0)
On Error GoTo Err_MsgBox2
Dim varIconType As Variant
Dim varButtonType As Variant
'------------------------
'Constants for API-MsgBox
'------------------------
MsgBox2_Title = strTitle
Select Case (intIcon)
Case 0: varIconType = &H10&
Case 1: varIconType = &H20&
Case 2: varIconType = &H30&
Case 3: varIconType = &H40&
Case vbCritical: varIconType = &H10&
Case vbQuestion: varIconType = &H20&
Case vbExclamation: varIconType = &H30&
Case vbInformation: varIconType = &H40&
Case Else: varIconType = &H10&
End Select
Select Case (intButton)
Case 0: varButtonType = &H0&
Case 1: varButtonType = &H1&
'Case 2: varButtonType = &H2& 'Unknown Problems
'Case 3: varButtonType = &H3& 'Unknown Problems
'Case 4: varButtonType = &H4& 'Unknown Problems
Case 5: varButtonType = &H5&
Case Else: varButtonType = &H0&
End Select
'Const MB_ICONSTOPP = &H10&
'Const MB_ICONQUESTION = &H20&
'Const MB_ICONEXCLAMATION = &H30&
'Const MB_ICONASTERISK = &H40&
'Const MB_OK = &H0&
'Const MB_OKCANCEL = &H1&
'Const MB_ABORTRETRYIGNORE = &H2&
'Const MB_YESNOCANCEL = &H3&
'Const MB_YESNO = &H4&
'Const MB_RETRYCANCEL = &H5&
'// Timer set - Callback in the Procedure TimerProc
' hier ist das Problem mit dem Me.hwnd, da dies eine ID des Formualrs zurückgibt
' könnte dies nicht auch ohne das klappen?
Call WinSetTimer(Me.hwnd, NV_CLOSEMSGBOX, intTime * 1000, AddressOf TimerProc)
'// Call API-MsgBox
Call WinMessageBox(Me.hwnd, strMessage, MsgBox2_Title, varIconType Or varButtonType)
Exit_MsgBox2:
Exit Sub
Err_MsgBox2:
MsgBox Err.Description
Resume Exit_MsgBox2
End Sub
'Function bases on MsgBox2 Sub
Public Function MsgBoxf2(strMessage As String, intTime As Integer, Optional strTitle As String = "InformationBox", _
Optional intIcon As Integer = 3, Optional intButton As Integer = 0)
Call MsgBox2(strMessage, intTime, strTitle, intIcon, intButton)
End Function
'MsgBox2 "Hallo Welt!",3,"Mein Titel",1,1
[/code]
Ich wäre sehr glücklich wenn jemand den Fehler in den Buttons 234 finden würde...
Grüße
Roland
Downloadbar: http://www.ms-office-forum.net/forum/showthread.php?p=1016706#post1016706