Polygone Forms

Vor einigen Jahren wollte ich verhindern, dass meine User-Forms geschlossen werden. Aber ich wollte nicht nur einfach mittels dem Ereignis QueryClose das Schließen verhindern, es sollte auch das Kreuz rechts oben nicht zu sehen sein. Letztendlich habe ich einfach via API das Systemmenü entfernt.
Bis dahin habe ich unter anderen auch mit Regionen experimentiert. Runde, vieleckige und auch durchlöcherte User-Formen sind also quasi als Abfallprodukt entstanden. Persönlich habe ich diese aber nie benutzt.
Das Prinzip ist einfach:
Mittels einer API-Funktion wird eine (polygone, runde, elyptische) Region erzeugt. Das Fensterhandle der Form wird ermittelt und mittels der Funktion SetWindowRgn wird die normal rechteckige Region des Fensters überschrieben. Da auch die Titelleiste wegfallen kann und ein Verschieben mit der Maus dann nicht mehr möglich ist, wurde dafür im UserForm_MouseDown-Ereignis Abhilfe geschaffen.

Beispieldatei (polygoneform.zip)

Private Type POINTAPI
  X As Long
  Y As Long
End Type

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

Private Declare Function CreatePolygonRgn Lib "gdi32" _
  (lpPoint As POINTAPI, ByVal nCount As Long, _
  ByVal nPolyFillMode As Long) As Long

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

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

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

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

Private Declare Function EnableWindow Lib "user32" _
  (ByVal hwnd As Long, ByVal bEnable As Long) As Long

Private Umriss() As POINTAPI
Private PolygonRegion As Long
Private GesamtRegion As Long
Private MeHwnd As Long
Private iNonModal As Boolean
Private iPixel As Boolean
Private iWerteÜbergeben As Boolean

Private Const WM_NCLBUTTONDOWN = &HA1
Private Const HTCAPTION = 2
Private Const WINDING = 2

 Private Sub UserForm_Activate()
  On Error Resume Next
  'Wenn keine Werte für das Polygon übergeben
  'wurden, werden feste Einstellungen benutzt
  If Not iWerteÜbergeben Then FesteEinstellungen
  'Polygone Region erzeugen
  CreatePolygoneRegion
  'Fensterhandle der Form ermitteln
  MeHwnd = FindWindowA("ThunderXFrame", Me.Caption)
  'Regionen ändern
  GesamtRegion = SetWindowRgn(MeHwnd, PolygonRegion, True)
  If iNonModal Then
    'Jetzt kann auch gleichzeitig im Blatt gearbeitet werden
    EnableWindow FindWindowA("XLMAIN", Application.Caption), 1
  End If
End Sub

 Private Function CreatePolygoneRegion()
  'Polygone Region erzeugen
  PolygonRegion = CreatePolygonRgn(Umriss(1), _
    UBound(Umriss), WINDING)
End Function

Private Sub UserForm_MouseDown(ByVal Button As Integer, _
  ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  'Ohne diese Prozedur ist kein Verschieben möglich,
  'wenn die Titelleiste nicht sichtbar ist
  If Button = 1 Then
    If MeHwnd <> 0 Then
      ReleaseCapture
      SendMessage MeHwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0
    End If
  Else
    'Mausklick mit der rechten Maustaste schließt die Form
    Unload Me
  End If
End Sub

Private Sub UserForm_Terminate()
  DeleteObject PolygonRegion
  DeleteObject GesamtRegion
End Sub

Private Sub FesteEinstellungen()
  'Wenn nichts als Property übergeben wird,
  'diese Prozedur benutzen
  Dim X_Array, Y_Array
  Dim i As Long
  Dim FaktorX As Double
  Dim FaktorY As Double
  Dim dummy As Double
  'Wenn das Array in Pixeln vorliegt, Faktoren auf 1 setzen
  FaktorX = Me.Width / 50
  FaktorY = Me.Height / 35
  'Kopiert aus Tabellenblatt Formeditor
  X_Array = Array(27, 4, 4, 10, 10, 4, 4, 27, 27, 38, 27)
  Y_Array = Array(9, 9, 11, 11, 20, 20, 22, 22, 26, 16, 5)
  ReDim Preserve Umriss(1 To UBound(X_Array) + 1)
  For i = 0 To UBound(X_Array)
    dummy = X_Array(i)
    Umriss(i + 1).X = dummy * FaktorX
    dummy = Y_Array(i)
    Umriss(i + 1).Y = dummy * FaktorY
  Next
End Sub

Public Property Let Pixelwerte(Wert As Boolean)
  'Durch setzen auf True kann man auch Pixelwerte benutzen
  iPixel = Wert
End Property

Public Property Let ArrayX(X_Array)
  Dim i As Long
  Dim FaktorX As Double
  Dim dummy As Double
  On Error GoTo Fehlerbehandlung
  FaktorX = Me.Width / 50
  'Wenn das Array in Pixeln vorliegt, Faktoren auf 1 setzen
  If iPixel Then FaktorX = 1
  ReDim Preserve Umriss(1 To UBound(X_Array))
  For i = 1 To UBound(X_Array)
    dummy = X_Array(i)
    Umriss(i).X = dummy * FaktorX
  Next
   iWerteÜbergeben = True
  Fehlerbehandlung:
End Property

Public Property Let ArrayY(Y_Array)
  Dim i As Long
  Dim FaktorY As Double
  Dim dummy As Double
  On Error GoTo Fehlerbehandlung
  FaktorY = Me.Height / 35
  'Wenn das Array in Pixeln vorliegt, Faktoren auf 1 setzen
  If iPixel Then FaktorY = 1
  ReDim Preserve Umriss(1 To UBound(Y_Array))
  For i = 1 To UBound(Y_Array)
    dummy = Y_Array(i)
    Umriss(i).Y = dummy * FaktorY
  Next
  iWerteÜbergeben = True
  Fehlerbehandlung:
  End Property

Public Property Let NichtModal(Wert As Boolean)
  'Durch setzen auf True kann gleichzeitig
  'im Tabellenblatt gearbeitet werden
  iNonModal = Wert
End Property