Thomas Risi Softwareentwicklung

UserForm mit Min/MaxButton
Downloads Demo-Datei

Dieses Beispiel verleiht den langweiligen Excel-UserForms einige neue Möglichkeiten. Es werden ein Min- und ein MaxButton hinzugefügt, und auf Wunsch läßt sich auch die Größe der UserForm mit der Maus ändern. Realisiert wird dies mit Hilfe einiger API-Funktionen. Wegen der einfacheren Handhabung, habe ich die Funktionen in einer Klasse gekapselt ...

Fügen Sie also in Ihr VBA-Projekt ein Klassenmodul ein. Sie finden es unter Einfügen/Klassenmodul. Ein Klassenmodul ist ausreichend, auch wenn Sie mehrere UserForms in Ihrem Projekt haben. Benennen Sie das Klassenmodul mit CUserForm und fügen Sie den Quellcode (s.u.) ein.

Bei jeder UserForm, welche die neuen Fähigkeiten erhalten soll, muß im Initialize-Ereignis der weiter unten angegebene Code einfügt werden.

Der Userform kann auch ein funktionierendes Menü angehängt werden. Dazu benötigen Sie ein normales Code-Modul und fügen den angegebenen Code (s.u.) dort ein.

Und so könnte ein UserForm-Fenster aussehen ...

Quellcode für Klassenmodul ...

Option Explicit Private Declare Function CreateMenu Lib "user32" () As Long Private Declare Function InsertMenuItem Lib "user32" Alias "InsertMenuItemA" ( _ ByVal hMenu As Long, ByVal un As Long, ByVal bool As Long, _ lpcMenuItemInfo As MENUITEMINFO) As Long Private Declare Function SetMenu Lib "user32" ( _ ByVal hWnd As Long, ByVal hMenu As Long) As Long Private Declare Function CreatePopupMenu Lib "user32" () As Long Private Declare Function DestroyMenu Lib "user32" (ByVal glngMenu As Long) As Long Private Declare Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long 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 dwNewLong As Long) As Long Private Declare Function MoveWindow Lib "user32" (ByVal hWnd As Long, _ ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, _ ByVal nHeight As Long, ByVal bRepaint As Long) As Long Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" ( _ ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Private Declare Function SetWindowPos Lib "user32" Alias "SetWindowPosA" ( _ 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 uFlags As Long) As Long Private Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" ( _ ByVal hWnd As Long, ByVal lpString As String) As Long Private Type MENUITEMINFO cbSize As Long fMask As Long fType As Long fState As Long wID As Long hSubMenu As Long hbmpChecked As Long hbmpUnchecked As Long dwItemData As Long dwTypeData As String cch As Long hbmpItem As Long ' erst ab Win2000 End Type Const MF_APPEND = &H100& Const MF_BITMAP = &H4& Const MF_BYPOSITION = &H400& Const MF_CHECKED = &H8& Const MF_DISABLED = &H2& Const MF_GRAYED = &H1& Const MF_SEPARATOR = &H800& Const MF_STRING = &H0& Const MIIM_CHECKMARKS As Long = &H8 Const MIIM_DATA As Long = &H20 Const MIIM_ID As Long = &H2& Const MIIM_STATE As Long = &H1& Const MIIM_SUBMENU As Long = &H4 Const MIIM_TYPE As Long = &H10 Const MIIM_STRING As Long = &H40 Const MIIM_BITMAP As Long = &H80 Const MIIM_FTYPE As Long = &H100 Const WS_BORDER As Long = &H800000 Const WS_CAPTION As Long = &HC00000 Const WS_CHILD As Long = &H40000000 Const WS_CLIPSIBLINGS As Long = &H4000000 Const WS_DLGFRAME As Long = &H400000 Const WS_MAXIMIZE As Long = &H1000000 Const WS_MAXIMIZEBOX As Long = &H10000 Const WS_MINIMIZEBOX As Long = &H20000 Const WS_OVERLAPPED As Long = 0 Const WS_POPUP As Long = &H80000000 Const WS_SIZEBOX As Long = &H40000 Const WS_SYSMENU As Long = &H80000 Const WS_THICKFRAME As Long = &H40000 Const WS_OVERLAPPEDWINDOW As Long = WS_OVERLAPPED Or _ WS_CAPTION Or _ WS_SYSMENU Or _ WS_THICKFRAME 'Or _ WS_MINIMIZEBOX Or _ WS_MAXIMIZEBOX Const WS_EX_DLGMODALFRAME As Long = &H1 Const WS_EX_ACCEPTFILES As Long = &H10 Const WS_EX_STATICEDGE As Long = &H20000 Const WS_EX_TOOLWINDOW As Long = &H80 Const WS_EX_TRANSPARENT As Long = &H20 Const WS_EX_WINDOWEDGE As Long = &H100 Const MFT_STRING As Long = 0 Const MFT_BITMAP As Long = &H4& Const MFT_MENUBARBREAK As Long = &H20& Const MFT_MENUBREAK As Long = &H40& Const MFT_OWNERDRAW As Long = &H100& Const GWL_WNDPROC = (-4) Const GWL_STYLE As Long = (-16) Const GWL_EXSTYLE As Long = (-20) Const SM_CXSCREEN As Long = 0 Const SM_CYSCREEN As Long = 1 Const WM_SETICON As Long = &H80& Const WM_SYSCOMMAND As Long = &H112& Const SC_MINIMIZE As Long = &HF020& Const SC_MAXIMIZE As Long = &HF030& Const SC_CLOSE As Long = &HF060& Const SC_SCREENSAVE As Long = &HF140& Const ICON_SMALL As Long = &H0& Const ICON_BIG As Long = &H1& Dim WithEvents myUserForm As MSForms.UserForm Dim m_Handle&, hIcon&, hMenu&, Border& Dim hMainMenu&, hSubMenu&, hSubSubMenu& Dim FormCaption$ Dim MaxBox As Boolean, MinBox As Boolean Dim UFIconImage As Object Public Enum BorderStyles xlSolid = 0 xlChangeable = 1 End Enum Public Sub Create(UF As MSForms.UserForm) Set myUserForm = UF FormCaption = myUserForm.Caption m_Handle = GetHandle SetWindowLong m_Handle, GWL_STYLE, GetStyle Or WS_OVERLAPPEDWINDOW SetWindowLong m_Handle, GWL_STYLE, GetStyle Or Border If MaxBox Then SetWindowLong m_Handle, GWL_STYLE, GetStyle Or WS_MAXIMIZEBOX If MinBox Then SetWindowLong m_Handle, GWL_STYLE, GetStyle Or WS_MINIMIZEBOX SetWindowLong m_Handle, GWL_EXSTYLE, GetStyle And WS_EX_WINDOWEDGE ' Um ein eigenes Icon in die Symbolleiste einzufügen, muß die Userform ein ' Image-Control enthalten. In der Picture-Eigenschaft von Image1 wird ' nun der Pfad zum Icon angegeben. Dann wird noch die Visible-Eigenschaft ' von Image1 auf False gesetzt ... On Error GoTo 10 Set UFIconImage = UF.Image1 hIcon = UFIconImage.Picture If (hIcon) Then SendMessage m_Handle, WM_SETICON, ICON_SMALL, hIcon 10: On Error GoTo 0 ' Wer will, kann auch noch ein Menü erstellen ... ' Erstellen des Hauptmenüs hMainMenu = CreateMenu ' Ein Untermenü dem Hauptmenü hinzufügen hSubMenu = CreatePopupMenu AddSubMenu "&Datei", 100, hMainMenu, hSubMenu, 0 ' Dem Untermenü Einträge hinzufügen AddMenuItem "&Öffnen", 110, hSubMenu, 0 AddMenuItem "&Schließen", 120, hSubMenu, 1 AddMenuSeparator hSubMenu, 2 AddMenuItem "&Beenden", 130, hSubMenu, 3 ' Ein weiteres Untermenü dem Hauptmenü hinzufügen hSubMenu = CreatePopupMenu AddSubMenu "&Liste", 200, hMainMenu, hSubMenu, 1 ' Dem zweiten Untermenü Einträge hinzufügen AddMenuItem "&Löschen", 230, hSubMenu AddMenuItem "&Drucken", 220, hSubMenu ' Dem zweiten Untermenü ein Untermenü hinzufügen hSubSubMenu = CreatePopupMenu AddSubMenu "&Auswahl", 300, hSubMenu, hSubSubMenu ' Dem Unternemü des Untermenüs Einträge hinzufügen AddMenuItem "&Krank", 310, hSubSubMenu AddMenuItem "&Urlaub", 320, hSubSubMenu ' Ein drittes Untermenü dem Hauptmenü hinzufügen hSubMenu = CreatePopupMenu AddSubMenu "&?", 400, hMainMenu, hSubMenu, 2 ' Dem dritten Untermenü Einträge hinzufügen AddMenuItem "&About ...", 410, hSubMenu, 0 ' Menü erstellen SetMenu m_Handle, hMainMenu ' Die UserForm 'subclassen' g_OldProc = SetWindowLong(m_Handle, GWL_WNDPROC, AddressOf NewProc) End Sub Private Sub AddMenuItem(Caption As String, ID As Long, ParentMenu As Long, Optional Position As Long = 0) Dim mi As MENUITEMINFO With mi .cbSize = Len(mi) .fMask = MIIM_TYPE Or MIIM_ID Or MIIM_SUBMENU .fType = MF_STRING .hSubMenu = 0 .dwTypeData = Caption .wID = ID End With InsertMenuItem ParentMenu, Position, True, mi End Sub Private Sub AddMenuSeparator(ParentMenu As Long, Optional Position As Long = 0) Dim mi As MENUITEMINFO With mi .cbSize = Len(mi) .fMask = MIIM_TYPE Or MIIM_ID .fType = MF_SEPARATOR End With InsertMenuItem ParentMenu, Position, True, mi End Sub Private Sub AddSubMenu(Caption As String, ID As Long, ParentMenu As Long, SubMenu As Long, Optional Position As Long = 0) Dim mi As MENUITEMINFO With mi .cbSize = Len(mi) .fMask = MIIM_TYPE Or MIIM_ID Or MIIM_SUBMENU .fType = MF_STRING .hSubMenu = SubMenu .dwTypeData = Caption .wID = ID End With InsertMenuItem ParentMenu, Position, True, mi End Sub Private Function GetHandle() As Long Select Case Int(Val(Application.Version)) Case 8 'Excel 97 GetHandle = FindWindow("ThunderXFrame", vbNullString) Case Else 'Excel 2000, XP, 2003, 2007, 2010 GetHandle = FindWindow("ThunderDFrame", vbNullString) End Select End Function Public Property Get hWnd() As Boolean hWnd = m_Handle End Property Public Property Get Caption() As String Caption = FormCaption End Property Public Property Let Caption(Title As String) SetWindowText m_Handle, Title FormCaption = Title End Property Public Property Get MaxButton() As Boolean MaxButton = MaxBox End Property Public Property Let MaxButton(Status As Boolean) MaxBox = Status End Property Public Property Get MinButton() As Boolean MinButton = MinBox End Property Public Property Let MinButton(Status As Boolean) MinBox = Status End Property Public Property Let BorderStyle(Style As BorderStyles) Select Case Style Case 0: Border = 0 Case 1: Border = WS_SIZEBOX End Select End Property Public Sub CloseForm() Unload myUserForm End Sub Public Sub Maximize() SendMessage m_Handle, WM_SYSCOMMAND, SC_MAXIMIZE, 0& End Sub Public Sub Minimize() SendMessage m_Handle, WM_SYSCOMMAND, SC_MINIMIZE, 0& End Sub Public Sub Screensaver() SendMessage m_Handle, WM_SYSCOMMAND, SC_SCREENSAVE, 0& End Sub Private Function GetStyle() As Long GetStyle = GetWindowLong(m_Handle, GWL_STYLE) End Function Private Sub Class_Initialize() MaxBox = False MinBox = False End Sub Private Sub Class_Terminate() DestroyMenu hMenu SetWindowLong m_Handle, GWL_WNDPROC, g_OldProc End Sub

Quellcode für die UserForm

Option Explicit Dim UF As New CUserForm Private Sub UserForm_Activate() 'UF.Maximize ' UserForm maximieren 'UF.Minimize ' UserForm minimieren UF.Caption = " Unsere kleine Form" End Sub Private Sub UserForm_Initialize() With UF .MaxButton = True .MinButton = True .BorderStyle = xlSolid .Create Me End With Set g_UserForm = Me End Sub

Quellcode für das normale Code-Modul

Option Explicit Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" ( _ ByVal lpPrevWndFunc As Long, _ ByVal hWnd As Long, _ ByVal Msg As Long, _ ByVal wParam As Long, _ ByVal lParam As Long) As Long Public g_OldProc As Long Public g_UserForm As MSForms.UserForm Public Function NewProc(ByVal hWnd As Long, ByVal Msg As Long, _ ByVal wParam As Long, ByVal lParam As Long) As Long If Msg = &H111& Then If lParam = 0 Then Select Case wParam Case Is = 110 MsgBox "Öffnen ausgewählt" Case Is = 120 MsgBox "Schließen ausgewählt" Case Is = 130 Unload g_UserForm Case Is = 410 MsgBox "http://rtsoftwaredevelopment.de" End Select End If End If NewProc = CallWindowProc(g_OldProc, hWnd, Msg, wParam, lParam) End Function

Wie nützlich finden Sie diesen Tipp?

	1	2	3	4	5
Weniger nützlich						Sehr nützlich

Bitte teilen Sie uns mit, warum Sie die Seite so bewertet haben. (optional)