Userform - Multipage mit individueller Hintergrundfarbe versehen

[volti]

Liebe Leserin, lieber Leser,

für das individuelle Setzen der Hintergrundfarbe einer Multipage gibt es offensichtlich keine Einstellmöglichkeit in den Eigenschaften.
In verschiedenen Forenbeiträgen wird daher empfohlen, eine Bitmap-Datei mit der gewünschten Farbe zu erstellen und diese dann in den Eigenschaften zuzuordnen.
Den Tab selbst kann man damit jedoch nicht einfärben.

So weit, so gut.

Natürlich kann man das ganze auch automatisieren, z.B. wenn man mehrere Seiten mit mehreren Farben haben möchte oder öfter mal die Farbe gewechselt werden soll, ohne dass man das dann manuell vorbereiten muss.

Nachfolgend mal ein Beispiel dazu.

Neben dem Setzen der Farbe an sich, lassen sich auch leicht ein paar Muster zaubern, ist vielleicht im Einzelfall auch ganz schick.

Grundlage des u.a. Codes ist das Erstellen und Abspeichern einer einfarbigen BitMap (ggf. mit Muster). Das Ergebnis kann dann z.B. zur Übernahme in eine Multipage genutzt werden.


  Userform_Multipagefarbe.xlsb (Größe: 42,82 KB / Downloads: 6)

   

Code:

Option Explicit

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

Private Type LOGBRUSH
    lbStyle As Long
    lbColor As Long
    lbHatch As LongPtr
End Type

Private Type BITMAPFILEHEADER
    bfType      As Integer
    bfSize      As Long
    bfReserved1 As Integer
    bfReserved2 As Integer
    bfOffBits   As Long
End Type

Private Type BITMAPINFOHEADER
    biSize          As Long
    biWidth         As Long
    biHeight        As Long
    biPlanes        As Integer
    biBitCount      As Integer
    biCompression   As Long
    biSizeImage     As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed       As Long
    biClrImportant  As Long
End Type

Private Type BITMAPINFO
    bmiHeader As BITMAPINFOHEADER
'   bmiColors As RGBQUAD                ' Die TYPE RGBQUAD lassen wir weg, da nicht nötig (KHV 26.08.2023)
End Type

Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As LongPtr) As LongPtr
Private Declare PtrSafe Function SelectObject Lib "gdi32" ( _
        ByVal hdc As LongPtr, ByVal hObject 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 DeleteDC Lib "gdi32" (ByVal hdc As LongPtr) As Long
Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function CreateDIBSection Lib "gdi32" ( _
        ByVal hdc As LongPtr, pBitmapInfo As BITMAPINFO, _
        ByVal un As Long, ByVal lplpVoid As LongPtr, _
        ByVal handle As LongPtr, ByVal dw As Long) As LongPtr
Private Declare PtrSafe Function GetDIBits Lib "gdi32" ( _
        ByVal aHDC As LongPtr, ByVal hBitmap As LongPtr, _
        ByVal nStartScan As Long, ByVal nNumScans As Long, _
        lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage 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 SetBkMode Lib "gdi32" (ByVal hdc As LongPtr, ByVal nBkMode As Long) As Long
Private Declare PtrSafe Function CreateBrushIndirect Lib "gdi32" (lpLogBrush As LOGBRUSH) As LongPtr
Private Declare PtrSafe Function FillRect Lib "user32" ( _
        ByVal hdc As LongPtr, lpRect As RECT, ByVal hBrush As LongPtr) As Long
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" ( _
        ByVal hdc As LongPtr, ByVal nIndex As Long) As Long

Private Type MemoryBitmap
    hdc     As LongPtr
    hbm     As LongPtr
    hDCold  As LongPtr
    width   As Long
    height  As Long
    BM_Info As BITMAPINFO
End Type

Private Const DIB_RGB_COLORS As Long = 0&

Public Sub SetzeHintergrundfarbeMultipage(oPage As MSForms.Page, iFarbe As Long, _
                                          Optional iStil As Long = 0, Optional iHatch As Long = 0)
' Setzt die Hintergrundfarbe oder das Muster einer Multipage in einer Userform
  Dim sBMPDatei As String, Memory_Bitmap As MemoryBitmap
  Dim bitmap_file_header As BITMAPFILEHEADER
  Dim LB As LOGBRUSH, R As RECT, hBrush As LongPtr
  Dim iFF As Integer, pixels() As Byte

  sBMPDatei = Environ("Temp") & "\Multipagetemp.bmp"    ' Temporären Dateinamen vorgeben
  LB.lbColor = iFarbe  ' Farbe
  LB.lbStyle = iStil   ' 0=BS_SOLID, 1=BS_HOLLOW, 2=BS_HATCHED, 3=BS_PATTERN
  LB.lbHatch = iHatch  ' 0=HS_HORIZONTAL, 1=HS_VERTICAL, 4=HS_CROSS, 5=HS_DIACROSS usw.

  hBrush = CreateBrushIndirect(LB)                      ' Einen neuen Brush erstellen
  
  Memory_Bitmap = ErstelleMemoryBitmap(oPage)           ' Ein neues Memory Bitmap erstellen
  
  With Memory_Bitmap
      SetRect R, 0, 0, .width, .height                  ' Rechteck setzen
      SetBkMode .hdc, 2   ' 2=Opaque, 1=Transparent      ' Hintergrundmodus setzen
      FillRect .hdc, R, hBrush                          ' Male den Brush in den Device Context
  
      With bitmap_file_header                           ' BitMap-Header füllen
          .bfType = &H4D42   ' "BM"
          .bfOffBits = Len(bitmap_file_header) + Len(Memory_Bitmap.BM_Info.bmiHeader)
          .bfSize = .bfOffBits + Memory_Bitmap.BM_Info.bmiHeader.biSizeImage
      End With

' Das BitMap in eine  Datei schreiben
      iFF = FreeFile                                    ' Freie Filenummer ermitteln
      Open sBMPDatei For Binary As iFF                  ' Bitmapdatei zum Schreiben öffnen
      Put #iFF, , bitmap_file_header                    ' Den BITMAPFILEHEADER schreiben
      Put #iFF, , .BM_Info                              ' Die Bitmap-Info schreiben
      ReDim pixels(1 To 4, 1 To .width, 1 To .height)   ' Ermittle die DIB bits
      GetDIBits .hdc, .hbm, 0, .height, pixels(1, 1, 1), .BM_Info, DIB_RGB_COLORS
      Put #iFF, , pixels                                ' Datei schreiben
      Close iFF                                         ' Datei schließen
      
' Bitmap in die Multipage übernehmen
      Set oPage.Picture = LoadPicture(sBMPDatei)        ' Lade jetzt das Bitmap aus der Datei in die MultiPage

' Das Memory-Bitmap, den Brush und die Datei wieder löschen
      SelectObject .hdc, .hDCold                        ' Alten Device Context wiederherstellen
      DeleteObject .hbm                                 ' Bitmap löschen
      DeleteObject hBrush                               ' Brush löschen
      DeleteDC .hdc                                     ' Device Context löschen
  End With
  Kill sBMPDatei                                        ' Temporäre Bitmap-Datei wieder löschen
End Sub

Private Function ErstelleMemoryBitmap(oPage As MSForms.Page) As MemoryBitmap
' Erstelle ein Memory Bitmap entsprechend der MultiPage Größe
' Teilweise Anregungen aus dem Internet verwendet
  Dim MBP As MemoryBitmap, w As Long, h As Long
  Dim BytesProLine As Long, PadsProLine As Long
  
  w = PTtoPX(oPage.Parent.Parent.InsideWidth, 0)        ' Maße holen
  h = PTtoPX(oPage.Parent.Parent.InsideHeight, 1)       ' Maße holen
  
  With MBP
      .hdc = CreateCompatibleDC(0)                      ' Einen Device Context erstellen

' Jetzt ein BitMap-Struktur füllen und erstellen
      With .BM_Info.bmiHeader
          .biSize = LenB(MBP.BM_Info.bmiHeader)
          .biBitCount = 32
          .biCompression = 0  ' 0 = BI_RGB
          .biPlanes = 1
          .biWidth = w: .biHeight = h
          BytesProLine = ((((.biWidth * .biBitCount) + 31) \ 32) * 4)
          PadsProLine = BytesProLine - (((.biWidth * .biBitCount) + 7) \ 8)
          .biSizeImage = BytesProLine * Abs(.biHeight)
      End With
      .hbm = CreateDIBSection(.hdc, .BM_Info, DIB_RGB_COLORS, ByVal 0&, ByVal 0&, ByVal 0&)
      .hDCold = SelectObject(.hdc, .hbm)                ' BitMap in den Device Context ziehen
      .width = w: .height = h
  End With
  
  ErstelleMemoryBitmap = MBP

End Function

Private Function ScreenDPI(bVert As Boolean) As Long
  Static lDPI(1) As Long, hdc As LongPtr

  If lDPI(0) = 0 Then
     hdc = GetDC(0)                                     ' Hole Device Context
     lDPI(0) = GetDeviceCaps(hdc, 88)                   ' 88 = LOGPIXELSX
     lDPI(1) = GetDeviceCaps(hdc, 90)                   ' 90 = LOGPIXELSY
     hdc = ReleaseDC(0, hdc)                            ' Löse Device Context wieder auf
  End If
  ScreenDPI = lDPI(Abs(bVert))
End Function

Private Function PTtoPX(Points As Single, bVert As Boolean) As Long
' Punkte zu Pixel umrechnen
  PTtoPX = Points * ScreenDPI(bVert) / 72 ' 72 = PointsPerInch
End Function

_________
viele Grüße
Karl-Heinz