Msgbox: Schriftfarbe und Hintergrundfarbe ändern

[volti]

Hallo liebe Leserin, lieber Leser,

immer wieder liest man in den Foren zu Fragen, ob denn die Hintergrundfarbe oder die Textfarbe einer Messagebox nicht geändert werden könne, dass das nicht möglich sei.
Nur einer hat es m.E. bei Mr. Excel mit viel Aufwand geschafft, hier eine entsprechende Lösung zu präsentieren.

Und ja, es ist (natürlich) möglich, die Hintergrundfarbe einer MsgBox oder weiterer Dialogboxen individuell zu verändern.

Eine Möglichkeit wäre, für die gesamte Klasse die Hintergrundfarbe mittels SetClasslong zu setzen. Aber dann hätten ja alle Dialogboxen diesen Hintergrund. Eher nicht so gut.
Das Setzen der Hintergrundfarbe einer Dialogbox oder eines Controls ist mit vertretbarem Aufwand nicht so einfach.

Aber, warum zeichnen wir die Dialogbox oder das Control nicht einfach neu.
Im hier gezeigten Code machen wir genau das. Leider mit ein paar Einschränkungen, aber für den Hausgebrauch könnte es reichen.

Als Font holen wir uns den Originalfont des Static der Messagebox. Natürlich könnte man auch einen eigenen Font kreieren, mit abweichender Schriftart, fett oder unterstrichen usw.
Hierzu findest Du hier eine entsprechende Anregung....
https://www.clever-excel-forum.de/Thread...se-aendern

Eine Möglichkeit, die Button individuell zu beschriften, findest Du hier.
https://www.clever-excel-forum.de/Thread...genem-Icon

Leider sind die Icons, die die Msgbox hier verwendet, keine guten Icons. Die Hintergrundfarbe ist nicht transparent, so dass diese nicht so gut aussehen.
Ggf. kann man bei Bedarf auch eigene Icons verwenden.

PS: Hier wird eine einfache Hintergrundfarbe verwendet. Als Brush könnte man natürlich auch ein Muster hier verwenden....

   

Und nun viel Spaß beim Ausprobieren...

Code:

Option Explicit
' Timerfunktionen
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
' Windowsfunktionen
Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
Private Declare PtrSafe Function CallWindowProcA Lib "user32" ( _
        ByVal lpPrevWndFunc As LongPtr, _
        ByVal hwnd As LongPtr, ByVal Msg As Long, _
        ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
#If Win64 Then
 Private Declare PtrSafe Function SetWindowLongA Lib "user32" Alias "SetWindowLongPtrA" ( _
         ByVal hwnd As LongPtr, ByVal nIndex As Long, _
         ByVal dwNewLong As LongPtr) As LongPtr
#Else
 Private Declare PtrSafe Function SetWindowLongA Lib "user32" (ByVal hwnd As LongPtr, _
         ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
#End If
Private Const GWL_WNDPROC = -4
Private Declare PtrSafe Function GetClientRect Lib "user32" (ByVal hwnd As LongPtr, _
        lpRect As RECT) As Long
' GDI-Funktionen
Private Declare PtrSafe Function SetTextColor Lib "gdi32" (ByVal hdc As LongPtr, _
        ByVal crColor As Long) As Long
Private Declare PtrSafe Function SetBkMode Lib "gdi32" (ByVal hdc As LongPtr, _
        ByVal nBkMode As Long) As Long
Private Declare PtrSafe Function FillRect Lib "user32" (ByVal hdc As LongPtr, _
        lpRect As RECT, ByVal hBrush As LongPtr) As Long
Private Declare PtrSafe Function BeginPaint Lib "user32" (ByVal hwnd As LongPtr, _
        lpPaint As PAINTSTRUCT) As LongPtr
Private Declare PtrSafe Function EndPaint Lib "user32" (ByVal hwnd As LongPtr, _
        lpPaint As PAINTSTRUCT) As Long
Private Declare PtrSafe Function CreateSolidBrush Lib "gdi32" ( _
        ByVal crColor As Long) As LongPtr
Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As LongPtr, _
        ByVal hObject As LongPtr) As LongPtr
Private Declare PtrSafe Function GetDlgItem Lib "user32" ( _
        ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long) As LongPtr
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
Private Declare PtrSafe Function TextOutA Lib "gdi32" (ByVal hdc As LongPtr, _
        ByVal x As Long, ByVal y As Long, ByVal lpString As String, _
        ByVal nCount As Long) As Long

Private Declare PtrSafe Function SendMessageA Lib "user32" (ByVal hwnd As LongPtr, _
        ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr

Private Type RECT
   Left   As Long
   Top    As Long
   Right  As Long
   Bottom As Long
End Type

Private Type PAINTSTRUCT
   hdc        As LongPtr
   fErase     As Long
   rcPaint    As RECT
   fRestore   As Long
   fIncUpdate As Long
   rgbReserved(0& To 31&) As Byte
End Type

Private Type MSGBOXPARAM
   Textfarbe As Long
   HGFarbe   As Long
End Type
Dim mMP As MSGBOXPARAM

Dim mhTimer As LongPtr, mlpOldProc As LongPtr, msText As String

Private Function MsgboxEx(sText As String, _
         Optional ByVal iDlgStyle As Long, Optional sCaption As String) As Long
  msText = sText
  mhTimer = SetTimer(0&, 0&, 25, AddressOf MsgBoxHookProc)             ' Timer setzen
  MsgboxEx = MsgBox(sText, iDlgStyle, sCaption)                        ' (Excel)-Msgbox starten
End Function

Sub MsgBoxHookProc()
' Setzt die Hooking-Prozedur für die MsgBox
  Dim hwnd As LongPtr
  
  KillTimer 0&, mhTimer: mhTimer = 0                                   ' Timer löschen
  hwnd = GetActiveWindow()                                             ' (Excel)-Msgbox suchen
  If hwnd <> 0 Then _
  mlpOldProc = SetWindowLongA(hwnd, GWL_WNDPROC, AddressOf WindowProc) ' (Excel)-Msgbox hooken
End Sub

Private Function WindowProc(ByVal hwnd As LongPtr, ByVal uMsg As Long, _
         ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
  Dim tPS As PAINTSTRUCT
  Dim tR  As RECT
  Dim hdc As LongPtr, hBrush As LongPtr, hStatic As LongPtr, hFont As LongPtr
  Dim i As Integer, z As Integer, sArr() As String
    
  Select Case uMsg
  Case &HF  ' &HF = WM_PAINT
     hBrush = CreateSolidBrush(mMP.HGFarbe)             ' Einen neuen Brush erstellen
     hStatic = GetDlgItem(hwnd, 65535)                  ' Handle des Textfeldes
     hFont = SendMessageA(hStatic, &H31, 0, 0)          ' Schriftart des Textfeldes
     For i = 1 To 2
         BeginPaint IIf(i = 1, hwnd, hStatic), tPS
         If i = 1 Then
            FillRect tPS.hdc, tPS.rcPaint, hBrush       ' Dlgbox mit Farbe füllen
         Else
            SetBkMode tPS.hdc, 1 ' 1 = Transparent      ' Hintergrundmodus setzen
            SelectObject tPS.hdc, hFont                 ' Font aktivieren
            SetTextColor tPS.hdc, mMP.Textfarbe         ' Schriftfarbe setzen
            sArr = Split(msText, vbLf)
            For z = 0 To UBound(sArr)
                TextOutA tPS.hdc, 1, z * 18 + 1, sArr(z), Len(sArr(z)) ' Text ausgeben
            Next z
         End If
         EndPaint hwnd, tPS
      Next i
      DeleteObject hBrush                               ' Brush löschen
   End Select
  WindowProc = CallWindowProcA(mlpOldProc, hwnd, uMsg, wParam, lParam)
End Function

Private Sub Aufruftest()
  Dim sText As String
  sText = "Dieses hier ist ein Beispieltext," & vbLf & "der auch umgebrochen ist" _
        & vbLf & "und zwar mehrfach!" & vbLf & "Findest Du das gut?"
  With mMP
    .Textfarbe = RGB(0, 0, 60)
    .HGFarbe = RGB(255, 210, 255)
  End With
  MsgBox (MsgboxEx(sText, vbYesNo, "Mein Hintergundtest"))
End Sub

_________
viele Grüße
Karl-Heinz

[volti]

Hallo zusammen,

hier noch mal eine leicht abweichende Version zur weiteren Verwendung.
Hier wird anstelle von TextOut die Funktion Drawtext verwendet und die Funktion CreateBrushIndirekt, die auch ein Hintergrundmuster erlaubt.

Drawtext verarbeitet neben anderen Abweichungen auch vbLF selbstständig.

Code:

Option Explicit
' Timerfunktionen
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
' Windowsfunktionen
Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
Private Declare PtrSafe Function CallWindowProcA Lib "user32" ( _
        ByVal lpPrevWndFunc As LongPtr, _
        ByVal hwnd As LongPtr, ByVal Msg As Long, _
        ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
#If Win64 Then
 Private Declare PtrSafe Function SetWindowLongA Lib "user32" Alias "SetWindowLongPtrA" ( _
         ByVal hwnd As LongPtr, ByVal nIndex As Long, _
         ByVal dwNewLong As LongPtr) As LongPtr
#Else
 Private Declare PtrSafe Function SetWindowLongA Lib "user32" (ByVal hwnd As LongPtr, _
         ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
#End If
Private Const GWL_WNDPROC = -4
Private Declare PtrSafe Function GetClientRect Lib "user32" (ByVal hwnd As LongPtr, _
        lpRect As RECT) As Long
' GDI-Funktionen
Private Declare PtrSafe Function SetTextColor Lib "gdi32" (ByVal hdc As LongPtr, _
        ByVal crColor As Long) As Long
Private Declare PtrSafe Function SetBkMode Lib "gdi32" (ByVal hdc As LongPtr, _
        ByVal nBkMode As Long) As Long
Private Declare PtrSafe Function FillRect Lib "user32" (ByVal hdc As LongPtr, _
        lpRect As RECT, ByVal hBrush As LongPtr) As Long
Private Declare PtrSafe Function BeginPaint Lib "user32" (ByVal hwnd As LongPtr, _
        lpPaint As PAINTSTRUCT) As LongPtr
Private Declare PtrSafe Function EndPaint Lib "user32" (ByVal hwnd As LongPtr, _
        lpPaint As PAINTSTRUCT) As Long
Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As LongPtr, _
        ByVal hObject As LongPtr) As LongPtr
Private Declare PtrSafe Function GetDlgItem Lib "user32" ( _
        ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long) As LongPtr
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
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 Declare PtrSafe Function CreateBrushIndirect Lib "gdi32" ( _
        lpLogBrush As LOGBRUSH) As LongPtr

Private Type LOGBRUSH
   lbStyle As Long
   lbColor As Long
   lbHatch As LongPtr
End Type
Private Declare PtrSafe Function SendMessageA Lib "user32" (ByVal hwnd As LongPtr, _
        ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr

Private Type RECT
   Left   As Long
   Top    As Long
   Right  As Long
   Bottom As Long
End Type

Private Type PAINTSTRUCT
   hdc        As LongPtr
   fErase     As Long
   rcPaint    As RECT
   fRestore   As Long
   fIncUpdate As Long
   rgbReserved(0& To 31&) As Byte
End Type

Private Type MSGBOXPARAM
   Textfarbe As Long
   HGFarbe   As Long
End Type
Dim mMP As MSGBOXPARAM

Dim mhTimer As LongPtr, mlpOldProc As LongPtr, msText As String

Private Function MsgboxEx(sText As String, Optional ByVal iDlgStyle As Long, _
                          Optional sCaption As String) As Long
  msText = sText
  mhTimer = SetTimer(0&, 0&, 25, AddressOf MsgBoxHookProc)             ' Timer setzen
  MsgboxEx = MsgBox(sText, iDlgStyle, sCaption)                        ' (Excel)-Msgbox starten
End Function

Private Sub MsgBoxHookProc()
' Setzt die Hooking-Prozedur für die MsgBox
  Dim hwnd As LongPtr
  
  KillTimer 0&, mhTimer: mhTimer = 0                                   ' Timer löschen
  hwnd = GetActiveWindow()                                             ' (Excel)-Msgbox suchen
  If hwnd <> 0 Then _
  mlpOldProc = SetWindowLongA(hwnd, GWL_WNDPROC, AddressOf WindowProc) ' (Excel)-Msgbox hooken
End Sub

Private Function WindowProc(ByVal hwnd As LongPtr, ByVal uMsg As Long, _
         ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
  Dim tPS As PAINTSTRUCT, tLB As LOGBRUSH
  Dim tR  As RECT
  Dim hdc As LongPtr, hStatic As LongPtr, hFont As LongPtr, hBrush As LongPtr
  Dim i As Integer
    
  Select Case uMsg
  Case &HF  ' &HF = WM_PAINT
       tLB.lbStyle = 2  ' 0=BS_SOLID, 1=BS_HOLLOW, 2=BS_HATCHED, 3=BS_PATTERN
       tLB.lbHatch = 5  ' 0=HS_HORIZONTAL, 1=HS_VERTICAL, 4=HS_CROSS, 5=HS_DIACROSS usw.
       tLB.lbColor = mMP.HGFarbe
       hBrush = CreateBrushIndirect(tLB)                ' Einen neuen Brush erstellen
       hStatic = GetDlgItem(hwnd, 65535)                ' Handle des Textfeldes
       hFont = SendMessageA(hStatic, &H31, 0, 0)        ' Schriftart des Textfeldes
       For i = 1 To 2
           hdc = BeginPaint(IIf(i = 1, hwnd, hStatic), tPS)
           If i = 1 Then
              FillRect hdc, tPS.rcPaint, hBrush         ' Dlgbox mit Farbe füllen
           Else
              SetBkMode hdc, 1 ' 1 = Transparent        ' Hintergrundmodus setzen
              hFont = SelectObject(hdc, hFont)          ' Font aktivieren
              SetTextColor hdc, mMP.Textfarbe           ' Schriftfarbe setzen
              DrawTextA hdc, msText & vbNullChar, (-1), tPS.rcPaint, 0
              DeleteObject SelectObject(hdc, hFont)     ' Font löschen
           End If
           EndPaint hwnd, tPS
        Next i
        DeleteObject hBrush                             ' Brush löschen
   End Select
  WindowProc = CallWindowProcA(mlpOldProc, hwnd, uMsg, wParam, lParam)
End Function

Private Sub Aufruftest()
  Dim sText As String
  sText = "Dieses hier ist ein Beispieltext," & vbLf & "der auch umgebrochen ist " _
        & "und zwar mehrfach!" & vbLf & "Findest Du das gut?"
  With mMP
    .Textfarbe = RGB(255, 0, 0)
    .HGFarbe = RGB(210, 230, 250)
  End With
  MsgBox (MsgboxEx(sText, vbYesNo, "Mein Hintergrundtest"))
End Sub

_________
viele Grüße
Karl-Heinz

[volti]

Und zu guter Letzt!

Jetzt auch mit korrekten Icons. Hier musste noch die Hintergrundfarbe angepasst werden, was mit dieser Version jetzt möglich ist.
Neben einigen Code-Änderungen jetzt auch zwei Varianten möglich. Im Beitrag werden nur Schrift- und Hintergrundfarbe behandelt.
Ein Gesamtkonzept mit Schriftgröße, Buttonbeschriftung, eigenen Icons  usw. wird es vielleicht irgendwann mal geben....

   

Code:

Option Explicit
' Timerfunktionen
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
' Windowsfunktionen
Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
Private Declare PtrSafe Function CallWindowProcA Lib "user32" ( _
        ByVal lpPrevWndFunc As LongPtr, _
        ByVal hwnd As LongPtr, ByVal Msg As Long, _
        ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
#If Win64 Then
 Private Declare PtrSafe Function SetWindowLongA Lib "user32" Alias "SetWindowLongPtrA" ( _
         ByVal hwnd As LongPtr, ByVal nIndex As Long, _
         ByVal dwNewLong As LongPtr) As LongPtr
#Else
 Private Declare PtrSafe Function SetWindowLongA Lib "user32" (ByVal hwnd As LongPtr, _
         ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
#End If
' GDI-Funktionen
Private Declare PtrSafe Function SetTextColor Lib "gdi32" (ByVal hdc As LongPtr, _
        ByVal crColor As Long) As Long
Private Declare PtrSafe Function SetBkMode Lib "gdi32" (ByVal hdc As LongPtr, _
        ByVal nBkMode As Long) As Long
Private Declare PtrSafe Function BeginPaint Lib "user32" (ByVal hwnd As LongPtr, _
        lpPaint As PAINTSTRUCT) As LongPtr
Private Declare PtrSafe Function EndPaint Lib "user32" (ByVal hwnd As LongPtr, _
        lpPaint As PAINTSTRUCT) As Long
Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As LongPtr, _
        ByVal hObject As LongPtr) As LongPtr
Private Declare PtrSafe Function GetDlgItem Lib "user32" ( _
        ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long) As LongPtr
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 Declare PtrSafe Function CreateBrushIndirect Lib "gdi32" ( _
        lpLogBrush As LOGBRUSH) As LongPtr

Private Type LOGBRUSH
   lbStyle As Long
   lbColor As Long
   lbHatch As LongPtr
End Type
Private Declare PtrSafe Function SendMessageA Lib "user32" (ByVal hwnd As LongPtr, _
        ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr

Private Type RECT
   Left   As Long
   Top    As Long
   Right  As Long
   Bottom As Long
End Type

Private Type PAINTSTRUCT
   hdc        As LongPtr
   fErase     As Long
   rcPaint    As RECT
   fRestore   As Long
   fIncUpdate As Long
   rgbReserved(0& To 31&) As Byte
End Type

Private Type MSGBOXPARAM
   Text      As String
   Textfarbe As Long
   HGFarbe   As Long
   Art       As Long
End Type
Dim mMP As MSGBOXPARAM

Dim mhTimer As LongPtr, mlpOldProc As LongPtr, mhBrush As LongPtr
Dim mtLB    As LOGBRUSH

Private Function MsgboxEx(sText As String, Optional ByVal iDlgStyle As Long, _
                          Optional sCaption As String) As Long
  mMP.Text = sText & vbNullChar                                        ' Text global setzen
  mhTimer = SetTimer(0&, 0&, 25, AddressOf MsgBoxHookProc)             ' Timer setzen
  MsgboxEx = MsgBox(sText, iDlgStyle, sCaption)                        ' (Excel)-Msgbox starten
End Function

Private Sub MsgBoxHookProc()
' Setzt die Hooking-Prozedur für die MsgBox
  Const GWL_WNDPROC = -4
  Dim hwnd As LongPtr, hStatic As LongPtr
  
  KillTimer 0&, mhTimer: mhTimer = 0                                   ' Timer löschen
  mtLB.lbStyle = 0  ' 0=BS_SOLID, 1=BS_HOLLOW, 2=BS_HATCHED, 3=BS_PATTERN
  mtLB.lbHatch = 5  ' 0=HS_HORIZONTAL, 1=HS_VERTICAL, 4=HS_CROSS, 5=HS_DIACROSS usw.
  mtLB.lbColor = mMP.HGFarbe
  mhBrush = CreateBrushIndirect(mtLB)                                  ' Einen neuen Brush erstellen
  hwnd = GetActiveWindow()                                             ' (Excel)-Msgbox suchen
  If hwnd <> 0 Then _
  mlpOldProc = SetWindowLongA(hwnd, GWL_WNDPROC, AddressOf WindowProc) ' (Excel)-Msgbox hooken
End Sub

Private Function WindowProc(ByVal hwnd As LongPtr, ByVal uMsg As Long, _
         ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
  Const WM_PAINT          As Long = &HF
  Const WM_CTLCOLORDLG    As Long = &H136
  Const WM_CTLCOLORSTATIC As Long = &H138
  Const WM_GETFONT        As Long = &H31
  Const WM_DESTROY        As Long = &H2
  
  Dim tPS As PAINTSTRUCT
  Dim hFont As LongPtr, hStatic As LongPtr
    
  Select Case uMsg
  Case WM_PAINT
       If mMP.Art = 1 Then
          BeginPaint hwnd, tPS                              ' Gesamte Dlgbox mit Farbe füllen
          EndPaint hwnd, tPS                                ' Bereich löschen, Hintergrundfarbe rein
       End If
      
       hStatic = GetDlgItem(hwnd, 65535)                    ' Handle des Textfeldes
       hFont = SendMessageA(hStatic, WM_GETFONT, 0, 0)      ' Schriftart des Textfeldes
      
       BeginPaint hStatic, tPS
       SetBkMode tPS.hdc, 1 ' 1 = Transparent               ' Hintergrundmodus transparent setzen
       hFont = SelectObject(tPS.hdc, hFont)                 ' Font aktivieren
       SetTextColor tPS.hdc, mMP.Textfarbe                  ' Schriftfarbe setzen
       DrawTextA tPS.hdc, mMP.Text, (-1), tPS.rcPaint, 0
       DeleteObject SelectObject(tPS.hdc, hFont)            ' Font löschen
       EndPaint hStatic, tPS

  Case WM_CTLCOLORDLG, WM_CTLCOLORSTATIC
       WindowProc = mhBrush: Exit Function                  ' Hintergrund Dlg und Icon
      
  Case WM_DESTROY                                           ' MsgBox beeenden
       DeleteObject mhBrush                                 ' Brush löschen
  End Select
  WindowProc = CallWindowProcA(mlpOldProc, hwnd, uMsg, wParam, lParam)
End Function

Private Sub Aufruftest()
  Dim sText As String
  
  sText = "Dieses hier ist ein Beispieltext," & vbLf & "der auch umgebrochen ist!"
  With mMP
    .Textfarbe = RGB(255, 255, 255)
    .HGFarbe = RGB(0, 0, 100)
    .Art = 1
  End With
  MsgBox (MsgboxEx(sText, vbExclamation, "Mein Hintergrundtest"))
End Sub

_________
viele Grüße
Karl-Heinz

[volti]

Hallo Forum,

hier noch mal ein wichtiges Update zum letzten Beispiel, welches vorrangig genommen werden sollte.

Beim letzten Beispiel hatte sich ein kleiner Fehler eingeschlichen, der unter bestimmten Voraussetzungen zu einer Unschärfe in der Darstellung führen kann.

Außerdem wurde der Code bei gleichem Ergebnis noch mal deutlich reduziert.

Code:

Option Explicit
' Timerfunktionen
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
' Windowsfunktionen
Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
Private Declare PtrSafe Function CallWindowProcA Lib "user32" ( _
        ByVal lpPrevWndFunc As LongPtr, _
        ByVal hwnd As LongPtr, ByVal Msg As Long, _
        ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
#If Win64 Then
 Private Declare PtrSafe Function SetWindowLongA Lib "user32" Alias "SetWindowLongPtrA" ( _
         ByVal hwnd As LongPtr, ByVal nIndex As Long, _
         ByVal dwNewLong As LongPtr) As LongPtr
#Else
 Private Declare PtrSafe Function SetWindowLongA Lib "user32" (ByVal hwnd As LongPtr, _
         ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
#End If
' GDI-Funktionen
Private Declare PtrSafe Function SetTextColor Lib "gdi32" (ByVal hDC As LongPtr, _
        ByVal crColor As Long) As Long
Private Declare PtrSafe Function SetBkMode Lib "gdi32" (ByVal hDC As LongPtr, _
        ByVal nBkMode As Long) As Long
Private Declare PtrSafe Function BeginPaint Lib "user32" (ByVal hwnd As LongPtr, _
        lpPaint As PAINTSTRUCT) As LongPtr
Private Declare PtrSafe Function EndPaint Lib "user32" (ByVal hwnd As LongPtr, _
        lpPaint As PAINTSTRUCT) As Long
Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, _
        ByVal hObject As LongPtr) As LongPtr
Private Declare PtrSafe Function GetDlgItem Lib "user32" ( _
        ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long) As LongPtr
Private Declare PtrSafe Function CreateSolidBrush Lib "gdi32" ( _
        ByVal crColor As Long) As LongPtr

Private Type RECT
   Left   As Long
   Top    As Long
   Right  As Long
   Bottom As Long
End Type

Private Type PAINTSTRUCT
   hDC        As LongPtr
   fErase     As Long
   rcPaint    As RECT
   fRestore   As Long
   fIncUpdate As Long
   rgbReserved(0& To 31&) As Byte
End Type

Private Type MSGBOXPARAM
   Textfarbe As Long
   HGFarbe   As Long
   Art       As Long
End Type
Dim mMP As MSGBOXPARAM

Dim mhTimer As LongPtr, mlpOldProc As LongPtr, mhBrush As LongPtr

Private Function MsgboxEx(sText As String, Optional ByVal iDlgStyle As Long, _
                          Optional sCaption As String = "Microsoft Excel") As Long
  mhTimer = SetTimer(0&, 0&, 25, AddressOf MsgBoxCallbackProc)          ' Timer setzen
  MsgboxEx = MsgBox(sText, iDlgStyle, sCaption)                         ' (Excel)-Msgbox starten
End Function

Private Sub MsgBoxCallbackProc()
' Setzt die Hooking-Prozedur für die MsgBox
  Const GWL_WNDPROC = -4
  Dim hDlg As LongPtr
  
  KillTimer 0&, mhTimer:   mhTimer = 0                                  ' Timer löschen
  hDlg = GetActiveWindow()                                              ' (Excel)-Msgbox suchen
  If hDlg <> 0 Then
     mhBrush = CreateSolidBrush(mMP.HGFarbe)                            ' Einen neuen Pinsel erstellen
     mlpOldProc = SetWindowLongA(hDlg, GWL_WNDPROC, AddressOf WindowProc) ' (Excel)-Msgbox hooken
  End If
End Sub

Private Function WindowProc(ByVal hwnd As LongPtr, ByVal uMsg As Long, _
                            ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
  Dim tPS As PAINTSTRUCT
    
  Select Case uMsg
  
  Case &HF ' WM_PAINT
       If mMP.Art = 1 Then
          BeginPaint hwnd, tPS                                          ' Gesamte Dlgbox mit Farbe füllen
          EndPaint hwnd, tPS                                            ' Bereich löschen, Hintergrundfarbe rein
       End If

  Case &H136, &H138 ' WM_CTLCOLORDLG, WM_CTLCOLORSTATIC
       SetBkMode wParam, 1   ' 1 = Transparent                          ' wParam => Zeiger auf DC
       If lParam = GetDlgItem(hwnd, 65535) Then                         ' lParam => Zeiger auf Fenster (Textfeld)
          SetTextColor wParam, mMP.Textfarbe                            ' Schriftfarbe des Textfeldes setzen
       End If
       WindowProc = mhBrush: Exit Function                              ' Hintergrund Dlg, Textfeld und Icon
      
  Case &H2 ' WM_DESTROY                                                 ' MsgBox beenden
       If mhBrush <> 0 Then DeleteObject mhBrush: mhBrush = 0           ' Pinsel löschen
  End Select
  WindowProc = CallWindowProcA(mlpOldProc, hwnd, uMsg, ByVal wParam, ByVal lParam)

End Function


' ##### Beispiele #####
Private Sub Aufruftest()
  Dim sText As String
  
  sText = "Dieses hier ist ein Beispieltext," & vbLf & "der auch umgebrochen ist!"
  With mMP
     .Textfarbe = RGB(255, 255, 0)
     .HGFarbe = RGB(0, 0, 100)
     .Art = 1
  End With
  MsgBox (MsgboxEx(sText, vbExclamation, "Mein Hintergrundtest"))
End Sub

_________
viele Grüße
Karl-Heinz