【原创】VB动态菜单——数据库动态菜单的添加

注：原创文字，转载请注明出处。

作者：TranSteel；索要源码，请发邮件至t5lyg@126.com

0. 引言

编写“交通工程标志结构设计”软件时遇到一个问题，即风速的问题。一般经验值填写30m/s或者35m/s，规范建议查“风速表”。表中列出了全国各地10年遇、50年遇、100年遇的风速值。为了方便软件用户对软件的使用，计划将风速表添加到软件数据库，使用户在需要查询风速值时可以比较容易的做到。

风速值在本软件的计算中只是一个基础参数，若用表格或者树的形式进行查询未免有牛刀杀鸡之嫌，因此决定采用菜单的形式实现快速查询功能。

1.完成效果

完成效果如下图所示：

2. 核心代码

1）标准模块内代码

Option Explicit

Public Const MF_CHECKED = &H8&
Public Const MF_APPEND = &H100&
Public Const TPM_LEFTALIGN = &H0&
Public Const MF_DISABLED = &H2&
Public Const MF_GRAYED = &H1&
Public Const MF_SEPARATOR = &H800&
Public Const MF_STRING = &H0&
Public Const MF_POPUP = &H10&
Public Type POINTAPI
    X   As Long
    Y   As Long
End Type
Public Declare Function CreatePopupMenu Lib "user32" () As Long
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, ByVal lprc As Any) As Long
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
Public Declare Function DestroyMenu Lib "user32" (ByVal hMenu As Long) As Long
Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Public Declare Function GetMenu Lib "user32" (ByVal Hwnd As Long) As Long
Public Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long

Public OldProc As Long

Public Const BN_CLICKED = 0
Public Const WM_COMMAND = &H111
Public Const GWL_WNDPROC = (-4)

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 hMenu As Long
Public hSecMenu() As Long
Public hThrMenu() As Long
'-------------
    Public strMenuText(1000) As String '菜单名称
    Public longMenuID As Long '菜单编号

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

'Public Const TPM_LEFTALIGN = &H0&
Public Sub popMenuWind()

    Dim i As Integer
   
    Dim intSecNum As Integer
    Dim intThrNum As Integer
   
    Dim rstSF As Recordset: Dim rstDQ As Recordset: Dim rstY As Recordset
    Dim strSF As String: Dim strDQ As String: Dim str10Y As String: Dim str50Y As String: Dim str100Y As String
   
    hMenu = CreatePopupMenu()
'    hSecMenu = CreatePopupMenu()
   
    '打开数据库
    Set Db = OpenDatabase(App.Path + "/data/db.mdb")
    '省份
    Set rstSF = Db.OpenRecordset("select 省份 from 风速表 group by 省份")
    rstSF.MoveLast
    ReDim hSecMenu(rstSF.RecordCount - 1) As Long
    rstSF.MoveFirst
    intSecNum = 0
    longMenuID = 0
    Do While Not rstSF.EOF
        hSecMenu(intSecNum) = CreatePopupMenu()
        strSF = Trim(rstSF.Fields("省份"))
        Set rstDQ = Db.OpenRecordset("select 地区 from 风速表 where 省份='" + Trim(rstSF.Fields("省份")) + "'")
       
        rstDQ.MoveLast
        ReDim hThrMenu(rstDQ.RecordCount - 1) As Long
        rstDQ.MoveFirst
        intThrNum = 0
        Do While Not rstDQ.EOF
            hThrMenu(intThrNum) = CreatePopupMenu()
            strDQ = Trim(rstDQ.Fields("地区"))
            Set rstY = Db.OpenRecordset("select * from 风速表 where 省份='" + Trim(strSF) + "'")
            '三级菜单
            str10Y = rstY.Fields("1/10"): str50Y = rstY.Fields("1/50"): str100Y = rstY.Fields("1/100")
            AppendMenu hThrMenu(intThrNum), MF_STRING, longMenuID, "10年一遇：" + str10Y + "m/s"
            strMenuText(longMenuID) = str10Y
            longMenuID = longMenuID + 1
            AppendMenu hThrMenu(intThrNum), MF_STRING, longMenuID, "50年一遇：" + str50Y + "m/s"
            strMenuText(longMenuID) = str50Y
            longMenuID = longMenuID + 1
            AppendMenu hThrMenu(intThrNum), MF_STRING, longMenuID, "100年一遇：" + str100Y + "m/s"
            strMenuText(longMenuID) = str100Y
            longMenuID = longMenuID + 1
            '二级菜单
           
            AppendMenu hSecMenu(intSecNum), MF_POPUP, hThrMenu(intThrNum), strDQ
            rstDQ.MoveNext
'            intThrNum = intThrNum + 1
        Loop
        '一级菜单
       
        AppendMenu hMenu, MF_POPUP, hSecMenu(intSecNum), strSF
        rstSF.MoveNext
        intSecNum = intSecNum + 1
    Loop
   

End Sub

Public Function WndProc(ByVal Hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'    MsgBox "单击"
    Dim i As Integer
    If Msg = WM_COMMAND Then
        For i = 0 To 1000
            If (wParam And &HFFFF0000) = BN_CLICKED Then
                If wParam = i Or &HFFF = i Then
                    frmDanzhu.txtWindSpeed = strMenuText(i)
                End If
            End If
        Next
    Else
        WndProc = CallWindowProc(OldProc, Hwnd, Msg, wParam, lParam)
    End If
End Function
2）窗体代码

（1）载入窗体时代码

    Call popMenuWind
    OldProc = SetWindowLong(Me.Hwnd, GWL_WNDPROC, AddressOf WndProc)

（2）响应菜单代码

Dim Pt As POINTAPI
   GetCursorPos Pt
   If Button = 1 Then
      TrackPopupMenu hMenu, TPM_LEFTALIGN, Pt.X, Pt.Y, 0, Me.Hwnd, ByVal 0&
   Else
      TrackPopupMenu GetSystemMenu(Me.Hwnd, False), TPM_LEFTALIGN, Pt.X, Pt.Y, 0, Me.Hwnd, ByVal 0&