Option Explicit
' Fenstererstellung und -handling
Private Declare PtrSafe Function CreateWindowExA Lib "user32" ( _
ByVal dwExStyle As Long, _
ByVal lpClassName As String, ByVal lpWindowName As String, _
ByVal dwStyle As Long, _
ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, _
ByVal hWndParent As LongPtr, ByVal hMenu As LongPtr, ByVal hInstance As LongPtr, _
lpParam As Any) As LongPtr
Private Declare PtrSafe Function FindWindowA Lib "user32" ( _
ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function DestroyWindow Lib "user32" ( _
ByVal hWnd As LongPtr) As Long
Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
Private Declare PtrSafe Function ReleaseDC Lib "user32" ( _
ByVal hWnd As LongPtr, ByVal hDC As LongPtr) As Long
' Zeichnen/Schreiben
Private Declare PtrSafe Function SetBkColor Lib "gdi32" ( _
ByVal hDC As LongPtr, ByVal crColor As Long) As Long
Private Declare PtrSafe Function DrawTextA Lib "user32" ( _
ByVal hDC As LongPtr, ByVal lpStr As String, _
ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Const WS_EX_MYWINDOW = &H40008 ' WS_EX_APPWINDOW + WS_EX_TOPMOST
Private Const WS_MYWINDOW = &H90800000 ' WS_BORDER + WS_POPUP + WS_VISIBLE
Private Const WS_CAPTION = &HC00000
Private Sub Infobox(sCaption As String, sText As String, Optional lStyle As Long = WS_CAPTION, _
Optional X As Long, Optional Y As Long)
Dim hWnd As LongPtr, hDC As LongPtr, R As RECT
If sCaption = "" Then Exit Sub ' Kein gültiger Caption angegeben =>raus
hWnd = FindWindowA("#32770", sCaption) ' Handle ermitteln
If sText = "Destroy" Then ' Infobox schließen?
If hWnd <> 0 Then DestroyWindow hWnd ' Infobox schließen
Exit Sub
ElseIf hWnd = 0 Then ' Neue Infobox starten
If X = 0 Then X = (GetSystemMetrics(0) - 350) \ 2 ' X-Position
If Y = 0 Then Y = (GetSystemMetrics(1) - 150) \ 2 ' Y-Position
hWnd = CreateWindowExA(WS_EX_MYWINDOW, _
"#32770", sCaption, WS_MYWINDOW Or lStyle, _
X, Y, 350, 150, 0&, 0&, Application.HinstancePtr, ByVal 0&)
End If
hDC = GetDC(hWnd) ' Device Context des Fensters holen
R.Left = 10: R.Top = 10: R.Bottom = 100: R.Right = 330 ' Schreibbereich festlegen
SetBkColor hDC, RGB(240, 240, 240)
DrawTextA hDC, sText & Space(255), 255, R, &H10 ' Text ausgeben
ReleaseDC hWnd, hDC ' Device Context auflösen
End Sub
' ################# Starten Updaten Schließen #################
' Anzeigebox öffnen mit Caption
Sub Open_MsgBox11a()
Call Infobox("Prozessablauf", "Die Verarbeitung wurde um " & Left$(Time, 5) & " Uhr gestartet!", , 350, 200)
End Sub
' Anzeigebox schließen
Sub Destroy_MsgBox11a()
Call Infobox("Prozessablauf", "Destroy")
End Sub
' Text aktualisieren, während der Laufzeit
Sub UpDate_MsgBox11a()
Call Infobox("Prozessablauf", "Mein neuer Text")
End Sub
' Anzeigebox öffnen ohne Caption
Sub Open_MsgBox1a11()
Call Infobox("Prozessablauf", "Die Verarbeitung wurde um " & Left$(Time, 5) & " Uhr gestartet!", 0, 350, 200)
End Sub