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