Excel VBA 窗体UserForm制作菜单栏与添加窗体最大化最小化功能(转载)

?

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148

窗体   '-------------------------------------------------------- '->Forms '  Module '  ClassModules '-------------------------------------------------------- Option Explicit   Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function SetMenu Lib "user32" (ByVal hWnd As Long, ByVal hMenu As Long) As Long Private Declare Function CreateMenu Lib "user32" () As Long Private Declare Function AppendMenu Lib "user32" Alias "AppendMenuA" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As Any) As Long Private Declare Function DestroyMenu Lib "user32" (ByVal hMenu As Long) As Long Private Declare Function CreatePopupMenu Lib "user32" () 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 GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long   Private Const GWL_WNDPROC = (-4) Private Const MF_STRING = &H0& Private Const MF_POPUP = &H10& Private Const MF_SEPARATOR = &H800&     'Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long 'Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long 'Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long   'Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex 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 SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long     Private Const GWL_STYLE = (-16) Private Const WS_THICKFRAME As Long = &H40000 '(恢复大小) Private Const WS_MINIMIZEBOX As Long = &H20000 '(最小化) Private Const WS_MAXIMIZEBOX As Long = &H10000 '(最大化)   Dim MenuWnd As Long, Dump As Long, PopupMenuID As Long, PopupMenuWnd As Long, MenuID As Long     Private Sub UserForm_Initialize()       '给窗体添加最大化最小化     Dim hWndForm As Long     Dim IStyle As Long     hWndForm = FindWindow("ThunderDFrame", Me.Caption)     IStyle = GetWindowLong(hWndForm, GWL_STYLE)     IStyle = IStyle Or WS_THICKFRAME '还原     IStyle = IStyle Or WS_MINIMIZEBOX '最小化     IStyle = IStyle Or WS_MAXIMIZEBOX '最大化     SetWindowLong hWndForm, GWL_STYLE, IStyle         '给窗体添加菜单     If Val(Application.Version) < 9 Then         hWnd = FindWindow("ThunderXFrame", Me.Caption)     Else         hWnd = FindWindow("ThunderDFrame", Me.Caption)     End If     MenuWnd = CreateMenu()           PopupMenuID = CreatePopupMenu()     Dump = AppendMenu(MenuWnd, MF_STRING + MF_POPUP, PopupMenuID, "Setting(&X)")     Dump = AppendMenu(PopupMenuID, MF_STRING, 100, "save(&S)...")     Dump = AppendMenu(PopupMenuID, MF_STRING, 101, "backup(&E)")     Dump = AppendMenu(PopupMenuID, MF_STRING, 102, "Exit(&X)")           PopupMenuID = CreatePopupMenu()     Dump = AppendMenu(MenuWnd, MF_STRING + MF_POPUP, PopupMenuID, "Review(&P)")     Dump = AppendMenu(PopupMenuID, MF_STRING, 110, "Record(&L)")     Dump = AppendMenu(PopupMenuID, MF_STRING, 111, "Review(&C)")           PopupMenuID = CreatePopupMenu()     Dump = AppendMenu(MenuWnd, MF_STRING + MF_POPUP, PopupMenuID, "Tools(&Z)")     Dump = AppendMenu(PopupMenuID, MF_STRING, 112, "Tuninghelper(&T)")     Dump = AppendMenu(PopupMenuID, MF_STRING, 113, "Kgthelper(&J)")           PopupMenuID = CreatePopupMenu()     Dump = AppendMenu(MenuWnd, MF_STRING + MF_POPUP, PopupMenuID, "Help(&B)")     Dump = AppendMenu(PopupMenuID, MF_STRING, 114, "help(&F)")     Dump = AppendMenu(PopupMenuID, MF_STRING, 115, "about(&Y)")           Dump = SetMenu(hWnd, MenuWnd)     PreWinProc = GetWindowLong(hWnd, GWL_WNDPROC)     SetWindowLong hWnd, GWL_WNDPROC, AddressOf MsgProcess End Sub     Private Sub UserForm_Terminate()     DestroyMenu MenuWnd     DestroyMenu PopupMenuID     DestroyMenu PopupMenuWnd     SetWindowLong hWnd, GWL_WNDPROC, PreWinProc End Sub         模块   '-------------------------------------------------------- '  Forms '->Module '  ClassModules '-------------------------------------------------------- Public PreWinProc As Long, hWnd As Long   Public Declare Function CheckMenuRadioItem Lib "user32" (ByVal hMenu As Long, ByVal un1 As Long, ByVal un2 As Long, ByVal un3 As Long, ByVal un4 As Long) As Long Public Declare Function CheckMenuItem Lib "user32" (ByVal hMenu As Long, ByVal wIDCheckItem As Long, ByVal wCheck As Long) As Long Public Declare Function EnableMenuItem Lib "user32" (ByVal hMenu As Long, ByVal wIDEnableItem As Long, ByVal wEnable As Long) As Long Public Const MF_UNCHECKED = &H0& Public Const MF_CHECKED = &H8& Public Const MF_DISABLED = &H2& Public Const MF_GRAYED = &H1& Public Const MF_ENABLED = &H0&   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 Private Declare Function GetMenu Lib "user32" (ByVal hWnd As Long) As Long Private Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long Private Const MF_BYCOMMAND = &H0&       Public Function MsgProcess(ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long     Dim SubMenu_hWnd As Long     Select Case wParam         Case 100             MsgBox "YourChoose: Save Button"         Case 101             MsgBox "YourChoose: Backup Buttion"         Case 102             Unload UserForm1         Case 110             MsgBox "YourChoose: Record Button"         Case 111             MsgBox "YourChoose: Review Button"         Case 112             MsgBox "YourChoose: Tuninghelper Button"         Case 113             MsgBox "YourChoose: Kgthelper Button"         Case 114             MsgBox "YourChoose: help Button"         Case 115             MsgBox "YourChoose: about Button"         Case Else             MsgProcess = CallWindowProc(PreWinProc, hWnd, Msg, wParam, lParam)     End Select End Function