UserForm Anpassen

Forumthread: UserForm Anpassen

UserForm Anpassen

11.01.2025 20:57:09

Daniel Eberhard

Guten Abend zusammen
Ich habe im Forum unterstehender Code gefunden. Finde den Code super.
Ich habe einen Button unten rechts positioniert. Wende ich den Code an, so ist der Button nicht mehr ganz unten. Gibt es eine Möglichkeit den Code anzupassen?





Option Explicit



#If VBA7 Then

    Public Declare PtrSafe Function FindWindow Lib "user32.dll" Alias "FindWindowA" ( _

        ByVal lpClassName As String, _

        ByVal lpWindowName As String) As Long

    Public Declare PtrSafe Function GetWindowLong Lib "user32.dll" Alias "GetWindowLongA" ( _

        ByVal hWnd As Long, _

        ByVal nIndex As Long) As Long

    Public Declare PtrSafe Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" ( _

        ByVal hWnd As Long, _

        ByVal nIndex As Long, _

        ByVal dwNewLong As Long) As Long

    Public Declare PtrSafe Function DrawMenuBar Lib "user32.dll" ( _

        ByVal hWnd As Long) As Long

    Public Declare PtrSafe Function SendMessage Lib "user32.dll" Alias "SendMessageA" ( _

        ByVal hWnd As Long, _

        ByVal wMsg As Long, _

        ByVal wParam As Long, _

        ByRef lParam As Any) As Long

    Public Declare PtrSafe Function ReleaseCapture Lib "user32.dll" () As Long

#Else

    Public Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" ( _

        ByVal lpClassName As String, _

        ByVal lpWindowName As String) As Long

    Public Declare Function GetWindowLong Lib "user32.dll" Alias "GetWindowLongA" ( _

        ByVal hWnd As Long, _

        ByVal nIndex As Long) As Long

    Public Declare Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" ( _

        ByVal hWnd As Long, _

        ByVal nIndex As Long, _

        ByVal dwNewLong As Long) As Long

    Public Declare Function DrawMenuBar Lib "user32.dll" ( _

        ByVal hWnd As Long) As Long

    Public Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" ( _

        ByVal hWnd As Long, _

        ByVal wMsg As Long, _

        ByVal wParam As Long, _

        ByRef lParam As Any) As Long

    Public Declare Function ReleaseCapture Lib "user32.dll" () As Long

#End If





Public Const GC_CLASSNAMEMSEXCELFORM = "ThunderDFrame"

Public Const GWL_STYLE = -16&

Public Const WS_CAPTION = &HC00000

Public Const HTCAPTION = 2&

Public Const WM_NCLBUTTONDOWN = &HA1



Public hWndForm As Long



Sub Titelleiste_weg(ObjForm As Object)

    hWndForm = FindWindow(GC_CLASSNAMEMSEXCELFORM, ObjForm.Caption)

    If hWndForm > 0 Then

        Call SetWindowLong(hWndForm, GWL_STYLE, GetWindowLong(hWndForm, _

            GWL_STYLE) And Not WS_CAPTION)

        Call DrawMenuBar(hWndForm)

    End If

End Sub



Private Sub CommandButton1_Click()

    Unload Me

End Sub



Private Sub UserForm_Initialize()

    Call Titelleiste_weg(Me)

End Sub



Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)

    If Button = 1 Then

        Call ReleaseCapture

        Call SendMessage(hWndForm, WM_NCLBUTTONDOWN, HTCAPTION, 0&)

    End If

End Sub

Besten Dank für Eure Unterstützung.

Freundliche Grüsse
Daniel Eberhard

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: UserForm Anpassen

11.01.2025 23:01:43

volti
AW: UserForm Anpassen

12.01.2025 00:05:27

volti

AW: UserForm Anpassen

11.01.2025 23:01:43

volti

Hallo Daniel,

ich habe eine Frage und einige Anmerkungen zu Deinem Code:

Frage:
Neben der Tatsache, dass die Titelleiste der Userform ausgeblendet wird, wird bei Mousedown in der UF eine NonClient-Mausdownmessage an die Userform gesendet.
Wird das von Dir auch benötigt/erwartet? Welche Reaktion erfolgt hierdurch?

Vielleicht solltest Du mal eine Musterdatei hier einstellen, wo man das testen kann.

Anmerkungen:
Die Declares für VBA7 sind völlig falsch umgesetzt und auch der hWndForm nicht richtig gesetzt.
Bist Du nur mit Excel 2007 unterwegs? Wenn ja, kommt hier nur der zweite #IF-Teil zum Tragen und alles ist ok. Der erste Teil wird nicht benötigt.

Bist Du nur mit neuerem Excel 32 oder 64Bit unterwegs, kommt der erste Teil zum Tragen, den solltest Du aber mit den erforderlichen Handle-Variablen LongPtr updaten.
DrawMenuBar ist entbehrlich. Die UF braucht nicht neu gezeichnet werden, da sie noch gar nicht angezeigt wird.

Gruß
Karl-Heinz

AW: UserForm Anpassen

12.01.2025 00:05:27

volti

Hallo Daniel,

ich weiß jetzt, was Du meinst.
Die Titelleiste wird ausgeblendet, alle Elemente rutschen dementsprechend nach oben, aber die UF-Größe bleibt gleich.

Eine Möglichkeit wäre, die Größe der UF anzupassen.....
Probiere es mal aus.

Code:


#If VBA7 Then
  Private Declare PtrSafe Function FindWindowA Lib "user32" ( _
          ByVal lpClassName As String, ByVal lpWindowName As String) 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 nIndex As Long) As LongPtr
  #End If
  Private Declare PtrSafe Function SetWindowPos Lib "user32" ( _
          ByVal hwnd As LongPtr, ByVal hWndInsertAfter As LongPtr, _
          ByVal x As Long, ByVal y As Long, _
          ByVal cx As Long, ByVal cy As Long, _
          ByVal wFlags As Long) As Long
  Private Declare PtrSafe Function GetWindowRect Lib "user32" ( _
          ByVal hwnd As LongPtr, lpRect As RECT) 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 Declare PtrSafe Function ReleaseCapture Lib "user32.dll" () As Long
  Private hWndForm As LongPtr

#Else
  Private Declare Function FindWindowA Lib "user32.dll" ( _
          ByVal lpClassName As String, ByVal lpWindowName As String) As Long
  Private Declare Function GetWindowLongA Lib "user32.dll" ( _
          ByVal hWnd As Long, ByVal nIndex As Long) As Long
  Private Declare Function SetWindowLongA Lib "user32.dll" ( _
          ByVal hWnd As Long, ByVal nIndex As Long, _
          ByVal dwNewLong As Long) As Long
  Private Declare Function SetWindowPos Lib "user32" ( _
          ByVal hwnd As Long, ByVal hWndInsertAfter As Long, _
          ByVal x As Long, ByVal y As Long, _
          ByVal cx As Long, ByVal cy As Long, _
          ByVal wFlags As Long) As Long
  Private Declare Function GetWindowRect Lib "user32" ( _
          ByVal hwnd As Long, lpRect As RECT) As Long
  Private Declare Function SendMessageA Lib "user32.dll" ( _
          ByVal hWnd As Long, ByVal wMsg As Long, _
          ByVal wParam As Long, ByRef lParam As Any) As Long
  Private Declare Function ReleaseCapture Lib "user32.dll" () As Long
  Private hWndForm As Long
#End If

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

Private Const GWL_STYLE        As Long = -16&
Private Const WS_CAPTION       As Long = &HC00000

Sub Titelleiste_weg(ObjForm As Object)
  hWndForm = FindWindowA("ThunderDFrame", ObjForm.Caption)
  If hWndForm <> 0 Then
     Call SetWindowLongA(hWndForm, GWL_STYLE, _
          GetWindowLongA(hWndForm, GWL_STYLE) And Not WS_CAPTION)
     GetWindowRect hWndForm, R
     SetWindowPos hWndForm, 0, 0, 0, R.Right - 9, R.Bottom - 38, &H2
  End If
End Sub

Private Sub CommandButton1_Click()
  Unload Me
End Sub

Private Sub UserForm_Initialize()
  Call Titelleiste_weg(Me)
End Sub

Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
  Const HTCAPTION        As Long = 2&
  Const WM_NCLBUTTONDOWN As Long = &HA1
    
  If Button = 1 Then
     Call ReleaseCapture
     Call SendMessageA(hWndForm, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
  End If
End Sub

_________________________
viele Grüße aus Freigericht 😊
Karl-Heinz

Forumthread: UserForm Anpassen

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread