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

窗体

'--------------------------------------------------------
'->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