在窗体系统菜单中加入自己的内容
发表于:2007-07-14来源:作者:点击数:
标签:
在窗体系统菜单中加入自己的内容,使用subclass,占用资源。 Option Explicit Declare Function AppendMenu Lib user32 Alias _ AppendMenuA (ByVal hMenu As Long, ByVal wFlags _ As Long, ByVal wIDNewItem As Long, ByVal _ lpNewItem As String) As Lon
在窗体系统菜单中加入自己的内容,使用subclass,占用资源。
Option Explicit
Declare Function AppendMenu Lib "user32" Alias _
"AppendMenuA" (ByVal hMenu As Long, ByVal wFlags _
As Long, ByVal wIDNewItem As Long, ByVal _
lpNewItem As String) As Long
Declare Function GetSystemMenu Lib "user32" _
(ByVal hWnd As Long, ByVal bRevert As Long) As Long
Declare Function SetWindowLong Lib "user32" _
Alias "SetWindowLongA" (ByVal hWnd As Long, _
ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
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 Const WM_SYSCOMMAND = &H112
Public Const MF_SEPARATOR = &H800&
Public Const MF_STRING = &H0&
Public Const GWL_WNDPROC = (-4)
Public Const IDM_ABOUT As Long = 1010
Public lProcOld As Long
Public Function SysMenuHandler(ByVal hWnd _
As Long, ByVal iMsg As Long, ByVal wParam _
As Long, ByVal lParam As Long) As Long
If iMsg = WM_SYSCOMMAND Then
If wParam = IDM_ABOUT Then
MsgBox "歪歪的
VB小技巧第22天的技巧",
vbInformation, "歪歪的VB技巧"
Exit Function
End If
End If
SysMenuHandler = CallWindowProc(lProcOld, _
hWnd, iMsg, wParam, lParam)
End Function
Public Function SubClass(FormName As Form)
Dim lhSysMenu As Long, lRet As Long
lhSysMenu = GetSystemMenu(FormName.hWnd, 0&)
lRet = AppendMenu(lhSysMenu, MF_SEPARATOR, 0&, vbNullString)
lRet = AppendMenu(lhSysMenu, MF_STRING, IDM_ABOUT, "歪歪的VB技巧")
FormName.Show
lProcOld = SetWindowLong(FormName.hWnd, GWL_WNDPROC, AddressOf SysMenuHandler)
End Function
第四步在form窗口的代码框中加入下面的代码
Option Explicit
Private Sub Form_Load()
Dim d As String
d = SubClass(Form1)
'这里Form1要换成你窗口自己的名字
End Sub
Private Sub Form_Unload(Cancel As Integer)
SetWindowLong Me.hWnd, GWL_WNDPROC, lProcOld
End Sub
原文转自:http://www.ltesting.net