Userform - Titelleiste formatieren
#1
Liebe Leserin, lieber Leser,

das Formatieren der Titelleiste einer Userform ist eigentlich nicht vorgesehen. Möchte man diese formatieren, blenden viele Programmierer die Titelleiste aus und formatieren die Userform an sich entsprechend.
Es entsteht sozusagen eine "Fake"-Titelleiste.

Dass es aber trotzdem geht, die Titelleiste zu formatieren, möchte ich mit nachfolgendem Code einmal aufzeigen.

Der nachfolgende Code bzw. der Code in der Beispieldatei erstellt formatiert die Titelleiste einer Userform.

Hierzu müssen wir uns in die Messageschleife der Userform einhooken und die Message WM_NCPAINT entsprechend bearbeiten, denn das Bemalen der Captionbar ist in Windows standardmäßig nicht vorgesehen.

Zum Malen in der Captionbar wird diese und der Rahmen drum herum erst mal von Windows gelöscht. Leider werden auch der Schatten und das Systemkreuz gelöscht und nicht wieder hergestellt.
Der Aufwand das Systemkreuz und den Schatten wieder herzustellen, ist mir zu groß. Das Systemkreuz wurde daher abgeschaltet und als Schatten eine kleine Sonderlösung eingebaut.

     

Wen's also nicht stört, der kann dann gerne so eine formatierte Userform bauen. Restliche Erklärungen wie immer im Code....

Und nun viel Spaß und Erfolg beim Ausprobieren....


.xlsb   Userform_Titelleiste_Formatieren.xlsb (Größe: 46,78 KB / Downloads: 0)

Code:

Private Const iPenB As Long = 2     ' Schattenbreite 1 bis 5

' Window-Funktionen
Private Declare PtrSafe Function FindWindowA Lib "user32" ( _
        ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function GetClientRect Lib "user32" ( _
        ByVal hwnd As LongPtr, lpRect As RECT) As Long
Private Declare PtrSafe Function GetWindowRect Lib "user32" ( _
        ByVal hwnd As LongPtr, lpRect As RECT) As Long

' Hooking-Funktionen
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
 Private Declare PtrSafe Function GetWindowLongA Lib "user32" Alias "GetWindowLongPtrA" ( _
         ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
#Else
 Private Declare PtrSafe Function SetWindowLongA Lib "user32" (ByVal hwnd As LongPtr, _
         ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
 Private Declare PtrSafe Function GetWindowLongA Lib "user32" (ByVal hwnd As LongPtr, _
         ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
#End If
Private Const GWL_WNDPROC    As Long = -4

' GDI-Funktionen
Private Declare PtrSafe Function GetWindowDC Lib "user32" (ByVal hwnd As LongPtr) 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 CreatePen Lib "gdi32" ( _
        ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As LongPtr
Private Declare PtrSafe Function CreateSolidBrush Lib "gdi32" ( _
        ByVal crColor As Long) As LongPtr
Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, _
        ByVal hObject As LongPtr) As LongPtr
Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function CreateFontA Lib "gdi32.dll" ( _
        ByVal nHeight As Long, ByVal nWidth As Long, _
        ByVal nEscapement As Long, ByVal nOrientation As Long, _
        ByVal fnWeight As Long, ByVal fdwItalic As Long, _
        ByVal fdwUnderline As Long, ByVal fdwStrikeOut As Long, _
        ByVal fdwCharSet As Long, ByVal fdwOutputPrecision As Long, _
        ByVal fdwClipPrecision As Long, ByVal fdwQuality As Long, _
        ByVal fdwPitchAndFamily As Long, ByVal lpszFace As String) As LongPtr
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 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 GetStockObject Lib "gdi32" (ByVal nIndex As Long) As LongPtr
Private Declare PtrSafe Function MoveToEx Lib "gdi32" (ByVal hDC As LongPtr, _
        ByVal x As Long, ByVal y As Long, lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function LineTo Lib "gdi32" (ByVal hDC As LongPtr, _
        ByVal x As Long, ByVal y As Long) As Long

Type POINTAPI
    x As Long
    y As Long
End Type

Private Declare PtrSafe Function OleTranslateColor Lib "oleaut32.dll" ( _
        ByVal clr As OLE_COLOR, ByVal palet As LongPtr, col As Long) As Long
Private Declare PtrSafe Function ColorAdjustLuma Lib "shlwapi.dll" ( _
        ByVal clrRGB As Long, ByVal n As Long, ByVal fScale As Long) As Long
Private Declare PtrSafe Function SetRect Lib "user32" (lpRect As RECT, _
        ByVal X1 As Long, ByVal Y1 As Long, _
        ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare PtrSafe Function FrameRect Lib "user32" (ByVal hDC As LongPtr, _
        lpRect As RECT, ByVal hBrush As LongPtr) As Long
Private Declare PtrSafe Function FillRect Lib "user32" (ByVal hDC As LongPtr, _
        lpRect As RECT, ByVal hBrush As LongPtr) As Long

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

Type Userform_Titlebar_STRUCT
   Caption        As String
   BackFarbe      As Long
   Textfarbe      As Long
   TextPosition   As Long       ' 0=links, 1=Zentriert
   Schriftgroesse As Long
   Schriftart     As String
   Fett           As Boolean
   kursiv         As Boolean
   Rand           As Long       ' 0=keiner, 1=weiß, 5=schwarz usw.
   Rahmenfarbe    As Long
End Type
Global mtUF As Userform_Titlebar_STRUCT

Dim mhDlgProc As LongPtr, mhFont As LongPtr
Dim mhPen(2) As LongPtr, mhBrush(2) As LongPtr
Dim PT As POINTAPI

Sub FormatUserform()
  Dim hWndUF As LongPtr, iFarbe As Long
  Const GWL_STYLE As Long = -16
  
  mhPen(1) = 0: mhPen(2) = 0: mhFont = 0
  With mtUF
     hWndUF = FindWindowA("ThunderDFrame", .Caption)
    
     SetWindowLongA hWndUF, GWL_STYLE, _
     GetWindowLongA(hWndUF, GWL_STYLE) And Not &H80000              ' &H80000 = WS_SYSMENU abschalten

     mhBrush(1) = CreateSolidBrush(.BackFarbe)                      ' Pinsel Caption HG-Farbe erstellen
     iFarbe = IIf(.Rahmenfarbe <> 0, .Rahmenfarbe, .BackFarbe)
     mhBrush(2) = CreateSolidBrush(iFarbe)                          ' Pinsel Rahmen HG-Farbe erstellen
     If .Schriftgroesse > 0 And .Schriftart <> "" Then              ' Neue Schriftart erstellen
        mhFont = CreateFontA(.Schriftgroesse, 0, 0, 0, _
                             IIf(.Fett, 700, 400), IIf(.kursiv, 1, 0), _
                             0, 0, 0, 0, 0, 0, 0, .Schriftart)
     End If
' Pens für die Schattenbildung erstellen
     If .Rand > 0 Then
        mhPen(1) = CreatePen(0, 2, vbWhite)                         ' Weißen Pen erstellen (2 Pixel)
        iFarbe = ColorAdjustLuma(iFarbe, -300, True)                ' Farbe für Schatten abdunkeln
        mhPen(2) = CreatePen(0, iPenB, iFarbe)                      ' Farbigen Pen erstellen (2 Pixel)
     End If
  End With
' Userform hooken, alle Meldungen für die Userform werden umgeleitet
  mhDlgProc = SetWindowLongA(hWndUF, GWL_WNDPROC, AddressOf WindowProc)
End Sub

Private Function WindowProc(ByVal hwnd As LongPtr, ByVal uMsg As Long, _
                            ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
' CallbackProzedur für Meldungen der Userform
  Dim hDC As LongPtr
  Dim B As Long, H As Long, i As Long
  Dim R As RECT, RC As RECT
  
  Select Case uMsg
  
  Case &H85, &H6  ' WM_NCPAINT, WM_ACTIVATE
' Titelleiste und Rahmen beabeiten
       GetClientRect hwnd, RC                                       ' Userform-Fläche holen
       hDC = GetWindowDC(hwnd)                                      ' Userform-Fläche incl. Caption/Rahmen
       B = RC.Right: H = RC.Bottom + 48
       SetRect R, 0, 0, 9, H:           FillRect hDC, R, mhBrush(2) ' linker Rahmen
       SetRect R, B + 9, 0, B + 18, H:  FillRect hDC, R, mhBrush(2) ' rechter Rahmen
       SetRect R, 0, H - 10, B + 18, H: FillRect hDC, R, mhBrush(2) ' unterer Rahmen
       SetRect R, 9, 0, B + 9, 9:       FillRect hDC, R, mhBrush(2) ' oberer Rahmen
       SetRect R, 9, 9, B + 9, 38:      FillRect hDC, R, mhBrush(1) ' Captionbereich setzen
'      SetRect R, 9, 0, B + 9, 38:      FillRect hDC, R, mhBrush(1) ' Captionbereich setzen
      
       SetBkMode hDC, 1 ' 1 = Transparent                           ' Hintergrundmodus transparent setzen
       If mhFont <> 0 Then SelectObject hDC, mhFont                 ' Font aktivieren
       SetTextColor hDC, mtUF.Textfarbe                             ' Schriftfarbe setzen
       DrawTextA hDC, mtUF.Caption & vbNullChar, (-1), R, _
                      IIf(mtUF.TextPosition > 0, &H25, &H24)        ' Jetzt Text erneut ausgeben

       If mhPen(1) <> 0 And mhPen(2) <> 0 Then                      ' Rand bearbeiten>0
          SelectObject hDC, mhPen(1)                                ' Weißen Pen aktivieren
          MoveToEx hDC, 1, H - 1, PT:  LineTo hDC, 1, 1: LineTo hDC, B + 18, 1
          SelectObject hDC, mhPen(2)                                ' Farbigen Pen aktivieren
          MoveToEx hDC, B + 18 - iPenB, 2, PT: LineTo hDC, B + 18 - iPenB, H - iPenB - 1
                                               LineTo hDC, 2, H - iPenB - 1
       Else
          SetRect R, 1, 1, RC.Right + 18, RC.Bottom + 47            ' Rahmenbereich setzen
          FrameRect hDC, R, GetStockObject(5)                       ' Userform-Umrandung zeichnen
       End If
      
       ReleaseDC hwnd, hDC                                          ' Device Context (DC) auflösen
       Exit Function

  Case &H2   ' WM_DESTROY                                           ' Userform beeenden
' Aufräumen
       For i = 1 To 2
         If mhPen(i) <> 0 Then DeleteObject mhPen(i)                ' Pens wieder löschen
         If mhBrush(i) <> 0 Then DeleteObject mhBrush(i)            ' Pinsel wieder löschen
       Next i
       If mhFont <> 0 Then DeleteObject mhFont                      ' Font wieder löschen
       Call SetWindowLongA(hwnd, GWL_WNDPROC, mhDlgProc)            ' Userform unhooken
       Exit Function
  End Select

' Andere Messages an Urspungsprozedur weiterleiten
  WindowProc = CallWindowProcA(mhDlgProc, hwnd, uMsg, ByVal wParam, ByVal lParam)

End Function

_________
viele Grüße
Karl-Heinz
[-] Folgende(r) 2 Nutzer sagen Danke an volti für diesen Beitrag:
  • knobbi38, schauan
Antworten Top


Gehe zu:


Benutzer, die gerade dieses Thema anschauen: 1 Gast/Gäste