添加菜单/自定义菜单/弹出式菜单（转集）

 'Module_menu 文件是添加菜单有关的东西，原先最开始会出自动关了程序

'后来又找了个源码,原来是那个MF_STRING，MF_SEPARATOR得用地址表示，不出错了，可是没看到效果

'最后比较幸运找到了HUSTSOFT的演示代码，才看到，原来第二次的已经可以，不过那是加在窗口上的系统菜单。而这个源码里面还包括了，窗口内菜单的自定义。

''本代码,集了三次找到的源码,有些代码没删,有些要写到FORM_LOAD的删了,保留了第一次的~2008-10-18
'-------------------------------------------------

''Form_load中的代码
    'AddMenu Me
    'SysMenuHwnd = GetSystemMenu(Me.hwnd, 0)
    'Call AppendMenu(SysMenuHwnd, MF_SEPARATOR, 8000, vbNullString)
    'Call AppendMenu(SysMenuHwnd, MF_STRING, 8001, "关于本程序(&A)")
    'Call AppendMenu(SysMenuHwnd, MF_SEPARATOR, 8002, vbNullString)
    'Call AppendMenu(SysMenuHwnd, MF_STRING, 8003, "恢复系统菜单(&R)")

    'Dim mSysMenu As Long
    'Dim mMenu As Long
    'Dim mSubMenu As Long
   
    'mSysMenu = GetSystemMenu(Me.hwnd, False)
    'AppendMenu mSysMenu, MF_SEPARATOR, 0, "-" '因为本工程名字也是AppendMenu,所以只好改函数名了
    'AppendMenu mSysMenu, MF_STRING, mAddItemId, "VB广场"
   
    'mMenu = GetMenu(Me.hwnd)
    'mSubMenu = GetSubMenu(mMenu, 0)
    'AppendMenu mSubMenu, MF_SEPARATOR, 0, "-"
    'AppendMenu mSubMenu, MF_STRING, mFileId, "文件"
    'AppendMenu mSubMenu, MF_STRING + MF_GRAYED + MF_CHECKED, mSaveId, "保存"

'-------------------------------------------------

'以下是第四次集到的，主要是增加了图标的设置功能，某个单项的操作
'API的集体声明及说明请从http://www.vbgood.com/上查找

'【VB声明】
'  Private Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long

'【说明】
'  取得窗口中一个菜单的句柄

'【返回值】
'  Long，依附于指定窗口的一个菜单的句柄（如果有菜单）；否则返回零

'【参数表】
'  hwnd -----------  Long，窗口句柄。对于vb，这应该是一个窗体句柄。注意可能不是子窗口的句柄
Private Declare Function GetMenu Lib "user32" _
   (ByVal hwnd As Long) As Long
'-------------------------------------------------
'【VB声明】
'  Private Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long

'【说明】
'  取得一个弹出式菜单的句柄，它位于菜单中指定的位置

'【返回值】
'  Long，位于指定位置的弹出式菜单的句柄（如果有的话）；否则返回零

'【参数表】
'  hMenu ----------  Long，菜单的句柄

'  nPos -----------  Long，条目在菜单中的位置。第一个条目的编号为0
Private Declare Function GetSubMenu Lib "user32" _
   (ByVal hMenu As Long, ByVal nPos As Long) As Long
'-------------------------------------------------
'【VB声明】
'  Private Declare Function SetMenuItemBitmaps Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal hBitmapUnchecked As Long, ByVal hBitmapChecked As Long) As Long

'【说明】
'  设置一幅特定位图，令其在指定的菜单条目中使用，代替标准的复选符号（√）。位图的大小必须与菜单复选符号的正确大小相符，这个正确大小可以由GetMenuCheckMarkDimensions函数获得

'【返回值】
'  Long，非零表示成功，零表示失败。会设置GetLastError

'【备注】
'  使用的位图可能由多个条目共享。一旦不再需要，位图必须由应用程序清除，因为windows不能自动对它进行清除

'【参数表】
'  hMenu ----------  Long，菜单句柄

'  nPosition ------  Long，欲设置位图的一个菜单条目的标识符。如在wFlags参数中指定了MF_BYCOMMAND，这个参数就代表欲改变的菜单条目的命令ID。如设置的是MF_BYPOSITION，这个参数就代表菜单条目在菜单中的位置（第一个条目的位置为零）

'  wFlags ---------  Long，常数MF_BYCOMMAND或MF_BYPOSITION，取决于nPosition参数

'  hBitmapUnchecked -  Long，撤消复选时为菜单条目显示的一幅位图的句柄。如果为零，表示不在未复选状态下显示任何标志

'  hBitmapChecked -  Long，复选时为菜单条目显示的一幅位图的句柄。可设为零，表示复选时不显示任何标志。如两个位图句柄的值都是零，则为这个条目恢复使用默认复选位图
Private Declare Function SetMenuItemBitmaps Lib "user32" _
   (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, _
    ByVal hBitmapUnchecked As Long, ByVal hBitmapChecked As Long) As Long
'-------------------------------------------------

 

2. '菜单API函数声明
3. 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
4. Public Declare Function ModifyMenu& Lib "user32" Alias "ModifyMenuA" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpString As String)
5. Public Declare Function ModifyMenuBynum& Lib "user32" Alias "ModifyMenuA" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpString As Long)
6. Public Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
7. ''
8. Public Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long
9. Public Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
10. Public Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
13. ''创建菜单
14. Public Declare Function CreateMenu Lib "user32" () As Long
15. Public Declare Function CreatePopupMenu Lib "user32" () As Long                            '弹出菜单
16. 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
17. Public Declare Function DestroyMenu Lib "user32" (ByVal hMenu As Long) As Long  '释放菜单
18. '在屏幕的任意地方显示一个弹出式菜单
19. Public Declare Function TrackPopupMenu& Lib "user32" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal x As Long, ByVal y As Long, ByVal nReserved As Long, ByVal hwnd As Long, lprc As RECT)
20. Public Declare Function TrackPopupMenuBynum& Lib "user32" Alias "TrackPopupMenu" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal x As Long, ByVal y As Long, ByVal nReserved As Long, ByVal hwnd As Long, ByVal lprc As Long)
23. '有关窗口函数的API函数声明
24. Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
25. Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
26. 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
27. 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
29. ''取单个项ID，设置位图
30. Public Declare Function GetMenuItemID Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
31. Public Declare Function SetMenuItemBitmaps Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal hBitmapUnchecked As Long, ByVal hBitmapChecked As Long) As Long
32. Public Declare Function GetMenuItemCount Lib "user32" (ByVal hMenu As Long) As Long
33. Public Declare Function GetMenuItemInfo Lib "user32" Alias "GetMenuItemInfoA" (ByVal hMenu As Long, ByVal un As Long, ByVal b As Boolean, lpMenuItemInfo As MENUITEMINFO) As Boolean
38. '菜单API函数常数声明
    Public Const MF_BYCOMMAND = &H0
    Public Const MF_GRAYED = &H1&
    Public Const MF_DISABLED = &H2&
    Public Const MF_BITMAP = &H4&
    Public Const MF_CHECKED = &H8&
    Public Const MF_POPUP = &H10&
39. Public Const MF_BYPOSITION = &H400&
    ' 为菜单加一条分隔线
    Public Const MF_SEPARATOR = &H800&
    ' 单击控制框产生此消息
    Public Const MF_STRING = &H0&
40. ' 在菜单中加一个字符串
    Public Const GWL_WNDPROC = (-4)
41. ' 常数声明
    Public Const WM_COMMAND = &H111
    Public Const WM_SYSCOMMAND = &H112
    Public Const WM_NCLBUTTONDOWN = &HA1
    Public Const WM_NCRBUTTONDOWN = &HA4
    Public Const WM_USER As Long = &H1000  '用户ID
43. Public Const MIIM_ID = &H2
    Public Const MIIM_TYPE = &H10
44. ''消息
    Public Const HTSYSMENU = 3
    Public Const HTCAPTION = 2
45. ''自定义菜单项的标识号偏移量
    Public Const IDM_SEPARATOR = 1
    Public Const IDM_MYABOUT = 2
46. ''其他变量
    Dim sHwnd As Long
    Dim OldProc As Long
    Dim mHwnd   As Long
50. ' API函数声明
51. Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
53. ' 全局变量
54. Public OldWindowProc As Long
55. ' 保存默认的窗口函数地址
56. Public SysMenuHwnd As Long
57. ' 保存系统菜单句柄
62. Type MENUITEMINFO
63.     cbSize As Long
64.     fMask As Long
65.     fType As Long
66.     fState As Long
67.     wID As Long
68.     hSubMenu As Long
69.     hbmpChecked As Long
70.     hbmpUnchecked As Long
71.     dwItemData As Long
72.     dwTypeData As String
73.     cch As Long
74. End Type
77. Type RECT
78.     Left As Long
79.     Top As Long
80.     Right As Long
81.     Bottom As Long
82. End Type
84. ''接着可向标准模块添加下面两个过程：
85. '置换窗口函数过程
86. Public Sub AddMenu(frm As Form)
87.     sHwnd = frm.hwnd
88.     OldProc = SetWindowLong(frm.hwnd, GWL_WNDPROC, AddressOf AddCallBack)
89. End Sub
91. ''释放自定义窗口函数过程
92. Public Sub Release()
93.     SetWindowLong sHwnd, GWL_WNDPROC, OldProc
94. End Sub
98. ''最后向标准模块中添加一自定义窗口函数过程:
99. Public Function AddCallBack(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
100.     Select Case wMsg
101.     Case WM_SYSCOMMAND '这个是主菜单上的消息
102.             AddCallBack = DefWindowProc(hwnd, wMsg, wParam, lParam)
103.     Case WM_COMMAND '这个是子菜单的消息
104.         'Debug.Print wParam - WM_USER, urls(wParam - WM_USER)
105.         If wParam > WM_USER And wParam < WM_USER + &H1000 Then '自定义菜单
106.             'MsgBox urls(wParam - WM_USER)
107.             MDIForm_Main.openForm urls(wParam - WM_USER)
108.         Else '其它菜单项交换系统处理
109.             'Debug.Print wParam, WM_USER
110.             AddCallBack = CallWindowProc(OldProc, hwnd, wMsg, wParam, lParam)
111.         End If
112.     Case Else
113.         AddCallBack = CallWindowProc(OldProc, hwnd, wMsg, wParam, lParam)
114.     End Select
115. End Function
118. ''
119. Public Function SubClass1_WndMessage(ByVal hwnd As Long, ByVal Msg As Long, ByVal wp As Long, ByVal lp As Long) As Long
120.     If Msg <> WM_SYSCOMMAND Then
121.         SubClass1_WndMessage = CallWindowProc(OldWindowProc, hwnd, Msg, wp, lp)
122.         ' 如果消息不是WM_SYSCOMMAND，就调用默认的窗口函数处理
123.         Exit Function
124.     End If
126.     Select Case wp
127.         Case 2001
128.             Call MsgBox("本程序实现了修改系统菜单的功能  ", vbOKOnly + vbInformation)
129.         Case 2003
130.             Call GetSystemMenu(Form1.hwnd, True)
131.             Call SetWindowLong(Form1.hwnd, GWL_WNDPROC, OldWindowProc)
132.             Call MsgBox("已经恢复了默认的系统菜单  ", vbOKOnly + vbInformation)
133.         Case Else
134.             SubClass1_WndMessage = CallWindowProc(OldWindowProc, hwnd, Msg, wp, lp)
135.             Exit Function
136.     End Select
138.     SubClass1_WndMessage = True
140. End Function

 

 

3. ''地址数组
4. Public urls() As Variant
7. ''收藏夹菜单
8. Public Function getFavFolder()
9.     getFavFolder = getVarFolder("userprofile") & "Favorites/"
10. End Function
13. ''环境变量
14. Public Function getVarFolder(vName As String)
15.     Dim doI As Long, buf As String
16.     Dim denI As Long
17.     
18.     
19.     ''找变量
20.     Do
21.         doI = doI + 1
22.         buf = LCase(Environ(doI))
23.         If buf = "" Then Exit Do
24.         denI = InStr(buf, "=")
25.         If Left(buf, denI - 1) = LCase(vName) Then
26.             getVarFolder = Mid(buf, denI + 1) & "/"
27.             Exit Do
28.         End If
29.     Loop Until buf = ""
30. End Function
35. ''环境变量
36. Public Function appendFav(ByVal mHwnd As Long, Optional vFolder As String = "")
37.     Dim vName As String, tFld As String, tfldName As String
38.     Dim tFldFull As String, vOldName As String
39.     Dim smHwnd As Long, tmHwnd As Long
40.     Static userNum As Long
41.     'userNum = 10000
42.     
43.     If vFolder <> "" Then vName = vFolder Else vName = getFavFolder()
44.     If Right(vName, 1) <> "/" Then vName = vName & "/"
46.     vOldName = Form_Tools.Dir1.Path
47.     Form_Tools.Dir1.Path = vName    '设置文件夹
48.     Form_Tools.File1.Path = vName   '设置文件夹
49.     
50.     Dim vDir As Variant, vFile As Variant
51.     Dim vDi As Long, vFi As Long
52.     
53.     
54.     If Form_Tools.Dir1.ListCount > 0 Then AppendMenu mHwnd, MF_SEPARATOR, 0, "-" '分隔线
55.     ''添加文件夹
56.     For vDi = 0 To Form_Tools.Dir1.ListCount - 1
57.         tFld = Form_Tools.Dir1.List(vDi)
58.         tfldName = Mid(tFld, InStrRev(tFld, "/") + 1)
59.         If tfldName <> "" Then
60.             tmHwnd = CreatePopupMenu()
61.             AppendMenu mHwnd, MF_POPUP, tmHwnd, tfldName
62.             appendFav tmHwnd, tFld
63.         End If
64.     Next
67.     If Form_Tools.File1.ListCount > 0 And Form_Tools.Dir1.ListCount > 0 Then AppendMenu mHwnd, MF_SEPARATOR, 0, "-" '分隔线
68.     ''添加文件
69.     For vFi = 0 To Form_Tools.File1.ListCount - 1
70.         tFld = Form_Tools.File1.List(vFi)
71.         tfldName = Left(tFld, InStrRev(tFld, ".") - 1)
72.         tFldFull = tfldName
73.         If Len(tfldName) > 15 Then tfldName = Left(tfldName, 12) & "..."
74.         If tfldName <> "" Then
75.             userNum = userNum + 1
76.             ReDim Preserve urls(userNum)
77.             Form_INI.pathINI = vName & tFld
78.             urls(userNum) = Form_INI.classIniFile1.GetIniKey("InternetShortcut", "URL")
79.             'Debug.Print userNum, Form_INI.pathINI, urls(userNum)
80.             AppendMenu mHwnd, MF_STRING, WM_USER + userNum, tfldName
81.         End If
82.     Next
84.     DrawMenuBar mHwnd
85.     
86.     Form_Tools.Dir1.Path = vOldName    '设置文件夹
87.     Form_Tools.File1.Path = vOldName   '设置文件夹
88. End Function