---- 启动Visual Basic,新建标准EXE工程,在工程中添加一标准模块,名称可以是默认的。在标准模块的声明部分加入下列代码:'菜单API函数声明 Public Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long Public 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 '菜单API函数常数声明 Public Const MF_BYCOMMAND = "H0" Public Const MF_SEPARATOR ="H800" Public Const MF_STRING = "H0" '有关窗口函数的API函数声明 Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long,ByVal dwNewLong As Long) As Long Public 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 Declare Function DefWindowProc Lib "user32" Alias "DefWindowProcA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long '消息 Public Const GWL_WNDPROC = (-4) Public Const WM_NCLBUTTONDOWN = "HA1" Public Const WM_NCRBUTTONDOWN = "HA4" Public Const WM_USER = "H400" Public Const WM_SYSCOMMAND = "H112" Public Const HTSYSMENU = 3 Public Const HTCAPTION = 2 '自定义菜单项的标识号偏移量 Public Const IDM_SEPARATOR = 1 Public Const IDM_MYABOUT = 2 '其他变量 Dim sHwnd As Long Dim OldProc As Long 接着可向标准模块添加下面两个过程: Public Sub AddMenu(frm As Form) '置换窗口函数过程 sHwnd = frm.hwnd OldProc = SetWindowLong(frm.hwnd, GWL_WNDPROC, AddressOf AddCallBack) End Sub Public Sub Release() '释放自定义窗口函数过程 SetWindowLong sHwnd,GWL_WNDPROC, OldProc End Sub最后向标准模块中添加一自定义窗口函数过程: Public Function AddCallBack(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Select Case wMsg Case WM_SYSCOMMAND '系统消息 Select Case wParam '测试 Case WM_USER + IDM_MYABOUT '"关于..."菜单项 '此处可加入用户需要自己处理"关于…" 菜单项的代码 MsgBox "单击了添加的菜单条目",vbOKOnly Case Else '其它菜单项交换系统处理 AddCallBack =DefWindowProc(hwnd, wMsg, wParam, lParam) End Select Exit Function Case Else AddCallBack = CallWindowProc(OldProc, hwnd, wMsg, wParam, lParam) End Select End Function 关闭标准模块的代码窗口,打开窗体的代码窗口, 在Form_Load()过程中加入下列代码: '加载自定义窗口过程 AddMenu Me '获得系统菜单的句柄 Dim hMenu As Long hMenu = GetSystemMenu(Me.hwnd, 0) '在系统菜单中添加自定义2条菜单项 AppendMenu hMenu, MF_SEPARATOR Or MF_BYCOMMAND, IDM_SEPARATOR, vbNullString '分隔符 AppendMenu hMenu, MF_BYCOMMAND Or MF_STRING, WM_USER + IDM_MYABOUT, "关于..." ' "关于…"菜单项 在Form_Unload过程中加入下列代码: Release '释放自定义窗口过程---- 到此,代码的输入工作完成,接下来的是进行测试。单击启动按钮或按F5,启动工程,用鼠标单击窗体左上角的图标弹出系统菜单,看看是否如愿。千万要注意的一点是,在结束工程时,一定要用窗体右上角的关闭按钮或者系统菜单中的关闭菜单项,否则的话,会造成Visual Basic系统崩溃,出现非法操作的错误,所以在测试工程前,最好对工程进行保存。 ---- 以上程序在Windows95,Visual Basic6.0环境下调试通过。
Public Const IDM_ABOUT = &H2000 Public Const IDM_UNITS = &H2001 Public Const IDM_RESET = &H2002 Public Const IDM_EXIT = &H2003 Public Const IDM_TEST = &H2005 '添加菜单 Dim hSysMenu As Long ' Get handle of system menu hSysMenu = GetSystemMenu(Me.hwnd, 0) ' Append separator and menu item with ID IDM_ABOUT Call AppendMenu(hSysMenu, MF_SEPARATOR, 0&, 0&) Call AppendMenu(hSysMenu, MF_STRING, IDM_ABOUT, "About...") Call AppendMenu(hSysMenu, MF_STRING, IDM_UNITS, "Units...") Call AppendMenu(hSysMenu, MF_STRING, IDM_RESET, "Reset...") Call AppendMenu(hSysMenu, MF_STRING, IDM_EXIT, "Exit") '改变窗体的处理函数 hwnd = Me.hwnd ' Install system menu window procedure procOld = SetWindowLong(ByVal hwnd, GWL_WNDPROC, AddressOf WindowsProc) '获取消息 Public Function WindowsProc(ByVal hwnd As Long, ByVal uMsg As Long, _ ByVal wParam As Long, ByVal lParam As Long) As Long ' Ignore everything but system commands If uMsg = WM_SYSCOMMAND Then ' ' Check for one special menu item ' WindowsProc = CallWindowProc(procOld, hwnd, uMsg, wParam, lParam) Debug.Print uMsg, wParam, lParam Select Case wParam Case IDM_ABOUT ' FrmAbout.Show ' Exit Function Case IDM_UNITS ' FrmUnits.Show ' Exit Function Case IDM_RESET ' FrmMain.TmrSys.Enabled = False ' Dim Response ' Response = MsgBox("Do you want to reset your Mouse Tracker to zero? " & Chr(13) & "Your current mileage reading will lost forever.", vbOKCancel + vbExclamation, "Reset Mouse Tracker") If Response = vbOK Then Distance = 0 'reset to zero GetCursorPos Pnt OldX = Pnt.x * Screen.TwipsPerPixelX OldY = Pnt.y * Screen.TwipsPerPixelY FrmMain.Caption = Format(Distance / UnitValue, FormatStr) & UnitName FrmMain.TmrSys.Enabled = True Else: FrmMain.TmrSys.Enabled = True End If Exit Function Case IDM_EXIT Unload FrmMain Exit Function Case IDM_TEST MsgBox "你好,现在已经受到你的消息!" End Select End If ' Let old window procedure handle other messages WindowsProc = CallWindowProc(procOld, hwnd, uMsg, wParam, lParam)
End Function
'模块中的代码 Public Declare Function GetSystemMenu Lib "user32" (ByVal hWnd As Long, ByVal bRevert As Long) As Long Public Declare Function InsertMenu Lib "user32" Alias "InsertMenuA" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As Any) As Long Public Const MF_BYCOMMAND = &H0& Public Const MF_BYPOSITION = &H400& Public Const MF_STRING = &H0& Public Const MF_SEPARATOR = &H800&'有关窗口的消息处理的API 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 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
Const GWL_WNDPROC = (-4&) Const WM_SYSCOMMAND = &H112 Const WM_DESTROY = &H2Dim PrevWndProc& Public Sub Init(hWnd As Long) PrevWndProc = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf SubWndProc) End SubPublic Sub Terminate(hWnd As Long) Call SetWindowLong(hWnd, GWL_WNDPROC, PrevWndProc) End SubPrivate Function SubWndProc(ByVal hWnd As Long, ByVal Msg As Long, _ ByVal wParam As Long, ByVal lParam As Long) _ As Long Debug.Print Msg If Msg = WM_DESTROY Then Terminate (Form1.hWnd)
If Msg = WM_SYSCOMMAND Then If wParam = 2002 Then MsgBox "我是40Star", vbInformation, "hia..hia..." End If End If
End Function '窗体中的代码 Private Sub Form_Load() InsertMenu GetSystemMenu(Me.hWnd, False), 0, MF_BYPOSITION Or MF_SEPARATOR, 2001, "" '加入一条分割线 InsertMenu GetSystemMenu(Me.hWnd, False), 0, MF_BYPOSITION Or MF_STRING, 2002, "About Me(&A)" '加入About me菜单在系统菜单中 Call Init(Me.hWnd) End SubPrivate Sub Form_Unload(Cancel As Integer) Call Terminate(Me.hWnd) End Sub
Public Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long
Public 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 '菜单API函数常数声明
Public Const MF_BYCOMMAND = "H0"
Public Const MF_SEPARATOR ="H800"
Public Const MF_STRING = "H0" '有关窗口函数的API函数声明
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long,ByVal dwNewLong As Long) As Long
Public 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 Declare Function DefWindowProc Lib "user32" Alias "DefWindowProcA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long '消息
Public Const GWL_WNDPROC = (-4)
Public Const WM_NCLBUTTONDOWN = "HA1"
Public Const WM_NCRBUTTONDOWN = "HA4"
Public Const WM_USER = "H400"
Public Const WM_SYSCOMMAND = "H112"
Public Const HTSYSMENU = 3
Public Const HTCAPTION = 2 '自定义菜单项的标识号偏移量
Public Const IDM_SEPARATOR = 1
Public Const IDM_MYABOUT = 2 '其他变量
Dim sHwnd As Long
Dim OldProc As Long
接着可向标准模块添加下面两个过程: Public Sub AddMenu(frm As Form) '置换窗口函数过程
sHwnd = frm.hwnd
OldProc = SetWindowLong(frm.hwnd, GWL_WNDPROC, AddressOf AddCallBack)
End Sub
Public Sub Release() '释放自定义窗口函数过程
SetWindowLong sHwnd,GWL_WNDPROC, OldProc
End Sub最后向标准模块中添加一自定义窗口函数过程:
Public Function AddCallBack(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Select Case wMsg Case WM_SYSCOMMAND
'系统消息
Select Case wParam '测试
Case WM_USER + IDM_MYABOUT
'"关于..."菜单项
'此处可加入用户需要自己处理"关于…" 菜单项的代码
MsgBox "单击了添加的菜单条目",vbOKOnly Case Else '其它菜单项交换系统处理
AddCallBack =DefWindowProc(hwnd, wMsg, wParam, lParam)
End Select
Exit Function
Case Else
AddCallBack = CallWindowProc(OldProc, hwnd, wMsg, wParam, lParam) End
Select End
Function 关闭标准模块的代码窗口,打开窗体的代码窗口, 在Form_Load()过程中加入下列代码:
'加载自定义窗口过程 AddMenu Me '获得系统菜单的句柄 Dim
hMenu As Long hMenu = GetSystemMenu(Me.hwnd, 0) '在系统菜单中添加自定义2条菜单项
AppendMenu hMenu, MF_SEPARATOR Or MF_BYCOMMAND, IDM_SEPARATOR,
vbNullString '分隔符 AppendMenu hMenu, MF_BYCOMMAND Or MF_STRING,
WM_USER + IDM_MYABOUT, "关于..." ' "关于…"菜单项
在Form_Unload过程中加入下列代码: Release '释放自定义窗口过程---- 到此,代码的输入工作完成,接下来的是进行测试。单击启动按钮或按F5,启动工程,用鼠标单击窗体左上角的图标弹出系统菜单,看看是否如愿。千万要注意的一点是,在结束工程时,一定要用窗体右上角的关闭按钮或者系统菜单中的关闭菜单项,否则的话,会造成Visual Basic系统崩溃,出现非法操作的错误,所以在测试工程前,最好对工程进行保存。
---- 以上程序在Windows95,Visual Basic6.0环境下调试通过。
Public Const IDM_UNITS = &H2001
Public Const IDM_RESET = &H2002
Public Const IDM_EXIT = &H2003
Public Const IDM_TEST = &H2005
'添加菜单
Dim hSysMenu As Long
' Get handle of system menu
hSysMenu = GetSystemMenu(Me.hwnd, 0)
' Append separator and menu item with ID IDM_ABOUT
Call AppendMenu(hSysMenu, MF_SEPARATOR, 0&, 0&)
Call AppendMenu(hSysMenu, MF_STRING, IDM_ABOUT, "About...")
Call AppendMenu(hSysMenu, MF_STRING, IDM_UNITS, "Units...")
Call AppendMenu(hSysMenu, MF_STRING, IDM_RESET, "Reset...")
Call AppendMenu(hSysMenu, MF_STRING, IDM_EXIT, "Exit")
'改变窗体的处理函数
hwnd = Me.hwnd
' Install system menu window procedure
procOld = SetWindowLong(ByVal hwnd, GWL_WNDPROC, AddressOf WindowsProc)
'获取消息
Public Function WindowsProc(ByVal hwnd As Long, ByVal uMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
' Ignore everything but system commands
If uMsg = WM_SYSCOMMAND Then
' ' Check for one special menu item
' WindowsProc = CallWindowProc(procOld, hwnd, uMsg, wParam, lParam)
Debug.Print uMsg, wParam, lParam
Select Case wParam
Case IDM_ABOUT
' FrmAbout.Show
' Exit Function
Case IDM_UNITS
' FrmUnits.Show
' Exit Function
Case IDM_RESET
' FrmMain.TmrSys.Enabled = False
' Dim Response
' Response = MsgBox("Do you want to reset your Mouse Tracker to zero? " & Chr(13) & "Your current mileage reading will lost forever.", vbOKCancel + vbExclamation, "Reset Mouse Tracker")
If Response = vbOK Then
Distance = 0 'reset to zero
GetCursorPos Pnt
OldX = Pnt.x * Screen.TwipsPerPixelX
OldY = Pnt.y * Screen.TwipsPerPixelY
FrmMain.Caption = Format(Distance / UnitValue, FormatStr) & UnitName
FrmMain.TmrSys.Enabled = True
Else: FrmMain.TmrSys.Enabled = True
End If
Exit Function
Case IDM_EXIT
Unload FrmMain
Exit Function
Case IDM_TEST
MsgBox "你好,现在已经受到你的消息!"
End Select End If ' Let old window procedure handle other messages
WindowsProc = CallWindowProc(procOld, hwnd, uMsg, wParam, lParam)
End Function
Public Declare Function GetSystemMenu Lib "user32" (ByVal hWnd As Long, ByVal bRevert As Long) As Long
Public Declare Function InsertMenu Lib "user32" Alias "InsertMenuA" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As Any) As Long
Public Const MF_BYCOMMAND = &H0&
Public Const MF_BYPOSITION = &H400&
Public Const MF_STRING = &H0&
Public Const MF_SEPARATOR = &H800&'有关窗口的消息处理的API
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 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
Const GWL_WNDPROC = (-4&)
Const WM_SYSCOMMAND = &H112
Const WM_DESTROY = &H2Dim PrevWndProc&
Public Sub Init(hWnd As Long)
PrevWndProc = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf SubWndProc)
End SubPublic Sub Terminate(hWnd As Long)
Call SetWindowLong(hWnd, GWL_WNDPROC, PrevWndProc)
End SubPrivate Function SubWndProc(ByVal hWnd As Long, ByVal Msg As Long, _
ByVal wParam As Long, ByVal lParam As Long) _
As Long
Debug.Print Msg
If Msg = WM_DESTROY Then Terminate (Form1.hWnd)
If Msg = WM_SYSCOMMAND Then
If wParam = 2002 Then
MsgBox "我是40Star", vbInformation, "hia..hia..."
End If
End If
SubWndProc = CallWindowProc(PrevWndProc, hWnd, Msg, wParam, lParam)
End Function
'窗体中的代码
Private Sub Form_Load()
InsertMenu GetSystemMenu(Me.hWnd, False), 0, MF_BYPOSITION Or MF_SEPARATOR, 2001, "" '加入一条分割线
InsertMenu GetSystemMenu(Me.hWnd, False), 0, MF_BYPOSITION Or MF_STRING, 2002, "About Me(&A)" '加入About me菜单在系统菜单中
Call Init(Me.hWnd)
End SubPrivate Sub Form_Unload(Cancel As Integer)
Call Terminate(Me.hWnd)
End Sub
如果我的窗体Me.BorderStyle = 0或如果我想自定义我的窗体界面,也就是说现在不是点击左上解的图标了,而是我任意放的位置点击就会跳出这个系统菜单呀,特别是当Me.BorderStyle = 0
的时候我又让系统菜单出现了,也就是说当你在任务栏上右击的时候出现在系统菜单,但那个关闭不管用呀,而其它的如最小化呀这些都生效的,要怎么要才能让关闭生效,也就是真的关闭了,