VB程序员博客
Option Explicit
Private hMainMenu As Long '主菜单
Private hFirstLevelMenu() As Long '一级菜单
Private hSecondLevelMenu As Long '二级菜单
Private hThirdLevelMenu As Long '三级菜单
Private intMenuCount As Integer '菜单总数
Private arrMenuList() As String '菜单信息列表数组
Private lngWinProc As Long
Private Const MF_POPUP = &H10
Private Const MF_STRING = &H0
Private Const MF_SEPARATOR = &H800
Private Const MF_BYPOSITION = &H400
Private Const WM_COMMAND = &H111
Private Const GWL_WNDPROC = (-4)
Public Xwx As New Class1
Public R1 As Recordset
'创建菜单API函数
Private Declare Function CreateMenu Lib "User32" () As Long
'创建弹出式菜单API函数
Private Declare Function CreatePopupMenu Lib "User32" () As Long
'插入菜单项API函数
Private 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
'追加菜单项API函数
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
'修改菜单项API函数
Private 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 Any) As Long
'设定菜单到对象上API函数
Private Declare Function SetMenu Lib "User32" (ByVal hwnd As Long, ByVal hMenu As Long) As Long
'在对象上画菜单条API函数
Private Declare Function DrawMenuBar Lib "User32" (ByVal hwnd 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 Declare Function DestroyMenu Lib "User32" (ByVal hMenu As Long) 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 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
Sub main()
Form1.Show
End Sub
'自动创建菜单过程
Public Sub AutoCreateMenu(frmName As Form)
Dim i As Integer, j As Integer, k As Integer, intTopMenuCount As Integer
Dim wFlags As Long
'建立主菜单
hMainMenu = GetMenu(frmName.hwnd)
If hMainMenu = 0 Then Exit Sub
'从数据库菜单表中取出信息初始化菜单数组
Call InitMenuArray
ReDim hFirstLevelMenu(intMenuCount)
'建立一级菜单 TODO 循环优化
For i = 1 To intMenuCount
If arrMenuList(3, i) = "1" Then
'取得一个弹出式菜单的句柄。
hFirstLevelMenu(i) = CreatePopupMenu()
'为主菜单添加菜单项及添加Caption属性并指定为弹出式菜单属性。
AppendMenu hMainMenu, MF_POPUP Or MF_BYPOSITION Or MF_STRING, hFirstLevelMenu(i), arrMenuList(2, i)
intTopMenuCount = intTopMenuCount + 1
End If
Next i
'建立二级菜单
For i = 1 To intMenuCount
If arrMenuList(3, i) = "2" Then
If arrMenuList(2, i) = "-" Then
wFlags = MF_SEPARATOR Or MF_BYPOSITION
Else
wFlags = MF_STRING Or MF_BYPOSITION
End If
For j = 1 To intMenuCount
If arrMenuList(5, i) = arrMenuList(1, j) Then 'i循环菜单的上级菜单编号=j循环菜单的菜单编号
hSecondLevelMenu = GetSubMenu(hMainMenu, arrMenuList(4, j))
'建立三级菜单
If arrMenuList(6, i) = "0" Then 'END_MENU_FLAG=0 表示还有下属子菜单
'取得一个弹出式菜单的句柄。
hThirdLevelMenu = CreatePopupMenu()
For k = 1 To intMenuCount
If arrMenuList(5, k) = arrMenuList(1, i) Then 'k循环菜单的上级菜单编号=i循环菜单的菜单编号
AppendMenu hThirdLevelMenu, wFlags, arrMenuList(1, k), arrMenuList(2, k)
End If
Next k
AppendMenu hSecondLevelMenu, wFlags Or MF_POPUP, hThirdLevelMenu, arrMenuList(2, i)
Else
AppendMenu hSecondLevelMenu, wFlags, arrMenuList(1, i), arrMenuList(2, i)
End If
End If
Next j
End If
Next i
'将主菜单设置给本窗口。
SetMenu frmName.hwnd, hMainMenu
'响应API创建成的菜单单击事件
lngWinProc = GetWindowLong(frmName.hwnd, GWL_WNDPROC)
'SetWindowLong frmName.hwnd, GWL_WNDPROC, AddressOf ClickMenu
SetWindowLong frmName.hwnd, GWL_WNDPROC, AddressOf ClickMenu
End Sub
'响应API创建成的菜单单击事件
Private Function ClickMenu(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Select Case wMsg
Case WM_COMMAND
Select Case wParam
Case 900204
frmSysUser.Show
Case 900205
frmSysRole.Show
Case 900210
Unload frmMain
End Select
End Select
ClickMenu = CallWindowProc(lngWinProc, hwnd, wMsg, wParam, lParam)
End Function
'获取系统菜单总个数
Private Function GetMenuCount() As Integer
Dim rsMenu As New ADODB.Recordset
Dim gsSql As String
gsSql = "SELECT COUNT(*) CNT FROM SYS_MENU"
If DBQuerySQL(rsMenu, gsSql) = 1 Then
GetMenuCount = rsMenu("CNT").Value
Else
GetMenuCount = 0
End If
rsMenu.Close
End Function
'菜单数组赋值
Function InitMenuArray()
Dim i As Integer
Dim rsMenu As New ADODB.Recordset
Dim gsSql As String
'MenuArray数组描述
'第一维按顺序分别存放 菜单编号、菜单名称、菜单层级、菜单显示顺序、上级菜单、是否末级菜单、菜单对应窗体名、菜单操作权限
intMenuCount = GetMenuCount()
ReDim arrMenuList(1 To 8, 1 To intMenuCount)
'gsSql = "SELECT " & _
"MENU_NO," & _
"MENU_NAME," & _
"MENU_LEVEL," & _
"MENU_SEQ," & _
"PARENT_MENU," & _
"END_MENU_FLAG," & _
"EXEC_FORM," & _
"'1' MENU_PVG" & _
" FROM SYS_MENU " & _
" ORDER BY MENU_NO,MENU_SEQ"
gsSql = "SELECT " & _
"sys_MENU_1," & _
"sys_MENU_2," & _
"sys_MENU_3," & _
"sys_MENU_4," & _
"sys_MENU_5," & _
"sys_MENU_6," & _
"sys_MENU_7," & _
"'0' sys_MENU_8" & _
" FROM SYS_MENU " & _
" ORDER BY sys_MENU_1,sys_MENU_4"
If DBQuerySQL(rsMenu, gsSql) <> -1 Then
For i = 1 To rsMenu.RecordCount
arrMenuList(1, i) = rsMenu("sys_MENU_1").Value
arrMenuList(2, i) = rsMenu("sys_MENU_2").Value
arrMenuList(3, i) = rsMenu("sys_MENU_3").Value
arrMenuList(4, i) = rsMenu("sys_MENU_4").Value
arrMenuList(5, i) = rsMenu("sys_MENU_5").Value
arrMenuList(6, i) = rsMenu("sys_MENU_6").Value
arrMenuList(7, i) = rsMenu("sys_MENU_7").Value
arrMenuList(8, i) = rsMenu("sys_MENU_8").Value
rsMenu.MoveNext
Next i
End If
rsMenu.Close
End Function
那位老师可以决绝这个，问题
程序运行到：
SetWindowLong frmName.hwnd, GWL_WNDPROC, AddressOf ClickMenu
vb就自动关闭了，不知道问题出在哪儿，在线求助！
问题已近解决，明天结贴，谢谢各位。
ClickMenu参数问题？
还是有问题，
Case WM_COMMAND
Select Case wParam
Case 900204
‘’ frmSysUser.Show
Case 900205
‘’ frmSysRole.Show
Case 900210
‘’ Unload frmMain
End Select
单引号后面不用就可以，去掉单引号就自动退出VB
人呢？
问题解决，是参数回调错误。