Tipp 0464 UserForm - Skin-Effekt
Autor/Einsender:
Datum:
  Frank Sohn
30.09.2005
Entwicklungsumgebung:   Excel 97
Mit Hilfe dieses Tipps ist man in der Lage UserForms und Steuerelemente mit verschiedenen/unregelmäßigen Formen zu erstellen. Jeder kennt bestimmt den Wunsch statt des Standards seinen Fenstern oder Buttons einmal ein anderes Aussehen zu geben. Wenn man selbst einmal versucht hat, eine unregelmäßige Form zu erstellen, merkt man schnell, dass das nicht so einfach ist und wenn es eine bestimmte Form ist, kann das sehr aufwendig sein.
Wie einfach es eigentlich ist, demonstriert dieses Beispiel. Zuerst wird eine BMP-Grafik erstellt, die das spätere Aussehen der UserForm haben soll. Die Bereiche der Grafik, die transparent bzw. "weggeschnitten" werden sollen, also auch außen herum, müssen die Farbe haben, die dann der entsprechenden Funktion übergeben wird.
Alle Bereiche (inkl. sichtbarer Steuerelemente), die nicht die angegebene Farbe haben, werden zu einer neuen Fensterregion zusammengefasst. Eine Region ist ein Bereich in den Kombinationen von Rechtecken, Polygonen und Ellipsen beschrieben werden. Somit kann man nicht nur schöne Skins für sein Formular erstellen, sondern auch für jedes Steuerelement.
Anmerkungen zum Code
Damit sich das Beispiel ohne großem Aufwand in eigene Projekte integrieren lässt, wurde der Code zum Erstellen des Skin-Effekts und das für das Verschieben der UserForm notwendige MouseDown-Ereignis der UserForm in einer Klasse gekapselt.
Abwärtskompatibilität - MouseDown-Ereignis der UserForm
Die Automatisierung der Klasse 'UserForm' wird erst ab Office 2000 unterstützt. D. h., es ist erst ab Office 2000 möglich, in einem Klassenmodul auf die Ereignisse einer UserForm zu reagieren.
Für die Abwärtskompatibilität zu Office 97 wurde hier das im Klassenmodul enthaltene Ereignis als "öffentlich" (Public) deklariert. So kann diese Prozedur in einer Office 97-Anwendung im MouseDown-Ereignis im Codebereich der UserForm (nur für Office 97 notwendig!) aufgerufen werden. Siehe dazu auch unseren Tipp Code abhängig von der VBA-Version ausführen.
Systemfarben
Wenn, wie in diesem Beispiel, durch das Zuweisen eines Hintergrundbilds, die Hintergrundfarbe der UserForm geändert wird, sollte entweder zur Entwurfs- oder zur Laufzeit auch die Hintergrund- und Schriftfarbe ggf. auf der UserForm vorhandenen Steuerelemente explizit zugewiesen werden. Je nach vom Anwender gewählter Darstellung für Fenster und Schaltflächen (Systemfarben/Farbschema) könnte es sonst passieren, dass Farben nicht mehr "zusammenpassen" (Hintergrundfarbe der UserForm mit der Hintergrundfarbe der Steuerelemente) oder das Steuerelement unbeabsichtigt "transparent" wird und/oder aber auch Text nicht mehr lesbar ist.
Im Download-Beispiel ist der Code ausführlich kommentiert.
Code im Codebereich des Klassenmoduls CFormSkin
 
Option Explicit

Private Const RGN_OR        As Long = 2
Private Const CLR_INVALID   As Long = &HFFFFFFFF
Private Const WindowBounds  As Long = 3
Private Const WS_EX_LAYERED As Long = &H80000
Private Const LWA_ALPHA     As Long = &H2
Private Const GWL_EXSTYLE   As Long = -20

Private Declare Function FindWindow Lib "user32" Alias _
      "FindWindowA" (ByVal lpClassName As String, _
      ByVal lpWindowName As String) As Long

Private Declare Function GetWindowLong Lib "user32" Alias _
      "GetWindowLongA" (ByVal hWnd As Long, _
      ByVal nIndex As Long) As Long

Private Declare Function SetWindowLong Lib "user32" Alias _
      "SetWindowLongA" (ByVal hWnd As Long, _
      ByVal nIndex As Long, ByVal dwNewIndex As Long) _
      As Long

Private Declare Function DrawMenuBar Lib "user32" _
      (ByVal hWnd As Long) As Long

Private Declare Function ReleaseCapture Lib "user32" () As Long

Private Declare Function SendMessage Lib "user32" Alias _
      "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, _
      ByVal wParam As Long, ByVal lParam As Long) As Long

Private Declare Function SetLayeredWindowAttributes Lib "user32" _
      (ByVal hWnd As Long, ByVal crKey As Long, ByVal bAlpha _
      As Byte, ByVal dwFlags As Long) As Long

Private Declare Function GetDC Lib "user32" _
      (ByVal hWnd As Long) As Long

Private Declare Function CreateRectRgn Lib "gdi32" _
      (ByVal x1 As Long, ByVal y1 As Long, _
      ByVal x2 As Long, ByVal y2 As Long) As Long

Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn _
      As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, _
      ByVal nCombineMode As Long) As Long

Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, _
      ByVal X As Long, ByVal Y As Long) As Long

Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd _
      As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long

Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd _
      As Long, ByVal hdc As Long) As Long

Private Declare Function DeleteObject Lib "gdi32" _
                         (ByVal hObject As Long) As Long

#If VBA6 Then
   Private WithEvents e_UserForm As MSForms.UserForm
#Else
   Private e_UserForm As MSForms.UserForm
#End If

Private m_TransparentColor As Long

Private m_hWndForm As Long
Private m_hSkinRgn As Long
Private m_hFormRgn As Long

Private Sub ChangeWindowTransparenz(ByVal hWnd As Long, _
      ByVal cAlpha As Byte)
  Dim lStyle As Long

  lStyle = GetWindowLong(hWnd, GWL_EXSTYLE)
  lStyle = lStyle Or WS_EX_LAYERED
  SetWindowLong hWnd, GWL_EXSTYLE, lStyle
  SetLayeredWindowAttributes hWnd, ByVal 0&, cAlpha, LWA_ALPHA
End Sub

Private Function MakeTransparentRegion(ByVal hdc As Long, _
      ByVal lHeigth As Long, ByVal lWidth As Long, _
      ByVal TransparentColor As Long) As Long

  Dim lSkinRgn  As Long
  Dim lTempRgn  As Long
  Dim StartRgnX As Long
  Dim StartRgn  As Boolean

  Dim PixColor  As Long

  Dim Y As Long
  Dim X As Long

  lSkinRgn = CreateRectRgn(0, 0, 0, 0)

  For Y = 0 To lHeigth - 1
    StartRgnX = 0
    StartRgn = False

    For X = 0 To lWidth
      PixColor = GetPixel(hdc, X, Y)
      If PixColor <> TransparentColor And _
            PixColor <> CLR_INVALID Then
        If StartRgn = False Then
          StartRgn = True
          StartRgnX = X
        End If

      Else
        If StartRgn = True Then
          lTempRgn = CreateRectRgn(StartRgnX + WindowBounds + 1, _
                Y + WindowBounds + 1, X + WindowBounds, _
                Y + WindowBounds)

          Call CombineRgn(lSkinRgn, lSkinRgn, lTempRgn, RGN_OR)
          Call DeleteObject(lTempRgn)
          StartRgn = False
        End If
       End If
     Next X
  Next Y

  MakeTransparentRegion = lSkinRgn
End Function

Public Sub Form_Initialize(ByRef objForm As Object, _
      ByVal TransparentColor As Long)

  Set e_UserForm = objForm
  m_TransparentColor = TransparentColor

  objForm.BorderStyle = fmBorderStyleNone
  objForm.BackColor = m_TransparentColor

  Dim strUFCaption As String

  strUFCaption = objForm.Caption
  objForm.Caption = "Dummy-Caption - djadljfepgtjaejhkaeljljaelji"
  m_hWndForm = FindWindow(vbNullString, objForm.Caption)
  objForm.Caption = strUFCaption

  If m_hWndForm <> 0 Then
    SetWindowLong m_hWndForm, -16, _
          GetWindowLong(m_hWndForm, -16) And Not &H400000
    DrawMenuBar m_hWndForm
    ChangeWindowTransparenz m_hWndForm, 0
  End If
End Sub

Public Sub Form_Activate()
  Dim hWndDC As Long

  e_UserForm.Repaint

  If m_hWndForm <> 0 Then
    hWndDC = GetDC(m_hWndForm)
    m_hSkinRgn = MakeTransparentRegion(hWndDC, _
          e_UserForm.InsideHeight / 0.748, _
          e_UserForm.InsideWidth / 0.748, _
          m_TransparentColor)

    m_hFormRgn = SetWindowRgn(m_hWndForm, m_hSkinRgn, True)
    ReleaseDC m_hWndForm, hWndDC

    ChangeWindowTransparenz m_hWndForm, 255
  End If
End Sub

Public Sub e_UserForm_MouseDown(ByVal Button As Integer, ByVal _
      Shift As Integer, ByVal X As Single, ByVal Y As Single)

  If Button = 1 Then
    If m_hWndForm <> 0 Then
      ReleaseCapture
      SendMessage m_hWndForm, &HA1, 2, 0
    End If
  End If
End Sub

Private Sub Class_Terminate()
  If m_hWndForm <> 0 Then
    DeleteObject m_hFormRgn
    DeleteObject m_hSkinRgn
    SetWindowLong m_hWndForm, -16, _
          GetWindowLong(m_hWndForm, -16) Or &H400000
  End If
  Set e_UserForm = Nothing
End Sub
 
Code im Codebereich der UserForm
 
Option Explicit

Private m_objCFormSkin As CFormSkin

Private Sub UserForm_Initialize()
  With Me.cmdExit
    .Cancel = True
    .Default = True

    .BackColor = &HC0C0&
    .ForeColor = vbBlack
  End With

  Set m_objCFormSkin = New CFormSkin
  Call m_objCFormSkin.Form_Initialize(Me, RGB(178, 31, 114))
End Sub

Private Sub UserForm_Activate()
  Call m_objCFormSkin.Form_Activate
End Sub

#If VBA6 = False Then
   Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal _
          Shift As Integer, ByVal X As Single, ByVal Y As Single)
     Call m_objCFormSkin.e_UserForm_MouseDown(Button, Shift, X, Y)
   End Sub
#End If

Private Sub cmdExit_Click()
  Unload Me
End Sub

Private Sub UserForm_Terminate()
  Set m_objCFormSkin = Nothing
End Sub
 
Hinweis
Die im Download befindlichen *.frm- und *.cls-Dateien können in den unten angegebenen Anwendungen im VB-Editor importiert werden.

Windows-Version
95
98
ME
NT
2000
XP
Vista
Win 7
Anwendung/VBA-Version
Access 97
Access 2000
Access XP
Access 2003
Access 2007
Access 2010
Excel 97
Excel 2000
Excel XP
Excel 2003
Excel 2007
Excel 2010
Word 97
Word 2000
Word XP
Word 2003
Word 2007
Word 2010
PPT 97
PPT 2000
PPT XP
PPT 2003
PPT 2007
PPT 2010
Outlook 97
Outlook 2000
Outlook XP
Outlook 2003
Outlook 2007
Outlook 2010


Download  (140 kB) Downloads bisher: [ 3170 ]

Vorheriger Tipp Zum Seitenanfang Nächster Tipp

Startseite | Projekte | Tutorials | API-Referenz | VB-/VBA-Tipps | Komponenten | Bücherecke | VB/VBA-Forum | VB.Net-Forum | DirectX-Forum | Foren-Archiv | DirectX | VB.Net-Tipps | Chat | Spielplatz | Links | Suchen | Stichwortverzeichnis | Feedback | Impressum

Seite empfehlen Bug-Report
Letzte Aktualisierung: Samstag, 3. September 2011