|
01
02
03
04
05
06
07
08
09
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58 |
|
' Excel-MsgBox mit eigenem Button und Icon aus Ico-Datei versehen
Private Declare PtrSafe Function SetTimer Lib "user32" ( _
ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, _
ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
Private Declare PtrSafe Function KillTimer Lib "user32" ( _
ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
Private Declare PtrSafe Function FindWindowA Lib "user32" ( _
ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function SetDlgItemTextA Lib "user32" ( _
ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long, ByVal lpString As String) As Long
Private Declare PtrSafe Function LoadImageA Lib "user32" ( _
ByVal hInst As LongPtr, ByVal lpsz As String, _
ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As LongPtr
Private Declare PtrSafe Function SendDlgItemMessageA Lib "user32" ( _
ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long, ByVal wMsg As Long, _
ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
Dim hTimer As LongPtr
Dim gsPfad As String, gsCaption As String, sBtns(5) As String
Function MsgBoxEx(sText As String, Optional sBtnText As String = "OK", _
Optional ByVal vbStyle As Long, Optional sCaption As String, _
Optional sIconPfad As String) As String
Dim sBtnArr() As String, iOffset As Integer
gsCaption = sCaption: gsPfad = sIconPfad ' Parameter global setzen
vbStyle = vbStyle And &HFFFF8 ' Buttonteil abtrennen
sBtnArr = Split(sBtnText, ",")
Select Case UBound(sBtnArr) ' Buttonstyle setzen
Case 0: vbStyle = vbStyle Or vbOKOnly: sBtns(2) = sBtnArr(0): iOffset = 1
Case 1: vbStyle = vbStyle Or vbOKCancel: sBtns(1) = sBtnArr(0): sBtns(2) = sBtnArr(1)
Case 2: vbStyle = vbStyle Or vbAbortRetryIgnore:
sBtns(3) = sBtnArr(0): sBtns(4) = sBtnArr(1): sBtns(5) = sBtnArr(2)
End Select
hTimer = SetTimer(0&, 0&, 25, AddressOf SetIconButtontext)
MsgBoxEx = Replace(sBtns(MsgBox(sText, vbStyle, gsCaption) + iOffset), "&", "")
End Function
Private Sub SetIconButtontext()
' Setzt die Button-Texte und das Icon individuell
Dim hwnd As LongPtr, iBtn As Integer
KillTimer 0&, hTimer ' Timer löschen
hwnd = FindWindowA("#32770", gsCaption) ' Handle der DlgBox ermitteln
' &H170=STM_SETICON, &H1=IMAGE_ICON, 40=Breite, Höhe, &H10=LR_LOADFROMFILE
If gsPfad <> "" Then _
SendDlgItemMessageA hwnd, 20, &H170, LoadImageA(0&, gsPfad, &H1, 40, 40, &H10), 0
For iBtn = 1 To 5: SetDlgItemTextA hwnd, iBtn, sBtns(iBtn): Next iBtn
End Sub
Sub Aufruftest()
MsgBox (MsgBoxEx("Bitte wähle die Schlumpfaktion aus!", "Schlumpfe &aus,Schlumpfe &ein", _
vbInformation, "Schlumpftest", "C:\ControlApp\schlumpf.ico"))
End Sub
|