userform Maximieren minimieren
27.11.2007 13:46:00
chris
ich habe eine frage.
Habe mit hilfe des Forums diesen Code für ein Klassenmodul bekommen.
Mit dem Code kann ich die größe einer userform manuel ändern und bekommen eine Menüleiste.
Wie schaffe ich das das mann wenn man die größe mit derr hand manuel ändern also mit der maus die Userform größer zeiht das nur eine Maximalgröße möglich ist. ?
Danke vielmals
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 9, 10, 11 'Excel 2000, XP, 2003
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