自动生成菜单 - 编程论坛

#2

renxiaoyao362015-05-20 20:48

自动生成菜单我做不到，可能是我不知道吧
我有其他的方式做到你的要求：
1.自己排版一个类似菜单的控件
2.这个控件下有个Label控件数组
3.启动时，用DIR函数搜索该文件夹下的EXE文件并存储到控件数组中
其中，因为控件数组是要Load的，所以可以使Label总数在可控制范围内可变。
以上就是思路

#3

yuk_yu2015-05-20 21:19

回复 2楼 renxiaoyao36

用label也可以，可否做个样板学习下吗？谢谢

#4

lianyicq2015-05-21 09:24

就用drivelist,filelist,dirlist就能实现基本功能.至于要由什么操作来执行,任意做.

程序代码：

Private Sub Dir1_Change()
File1.Path = Dir1.Path
End Sub

Private Sub Drive1_Change()
Dir1.Path = Drive1.Drive
End Sub

Private Sub File1_DblClick()
Dim temp As String
temp = Dir1.Path & "\" & File1.FileName
Call Shell(temp, vbNormalFocus)
End Sub

Private Sub Form_Load()
File1.Pattern = "*.exe"
End Sub

#5

风吹过b2015-05-21 09:48

程序代码：

Option Explicit

Dim apppath As String                       '保存着最后一次调用的路径

Private Sub Command1_Click()
Call addlab("c:\windows\system32")          '调用
End Sub

Private Sub Form_Load()
Label1(0).AutoSize = True                   '自动大小
Label1(0).ForeColor = &HFF0000              '文字颜色，还有一个鼠标图标，需要在属性里设置
Label1(0).Visible = False                   '不显示

Call addlab("c:\windows\")                  '调用，示例，这个与按钮的调用的路径不同，路径以最后一次调用为准

End Sub

Public Sub addlab(p As String)

Dim s As String
Dim i As Long

If Right(p, 1) <> "\" Then                  '标准化路径，是否带最后一个 \
    apppath = p & "\"                       '不带，加上
Else
    apppath = p
End If

For i = 1 To Label1.Count - 1               '先删原有的
    Unload Label1(i)
Next i

i = 1
s = Dir(apppath & "*.exe")                  '搜索 exe 文件
Do While s <> ""                            '找到
    Load Label1(i)                          '加载一个
    Label1(i).Caption = s                   '标题
    s = Dir                                 '下一个
    i = i + 1                               '计数器
Loop

Call viewlab                                '排列

End Sub

Public Sub viewlab()

Const XR = 120
Const YR = 120

Dim i As Long
Dim x As Long, y As Long
x = XR
y = YR

'第一个元素需要特殊处理
Label1(1).Left = XR
x = XR + Label1(1).Width
Label1(1).Top = YR
Label1(1).Visible = True                                '放完后显示

'从第二个元素开始
For i = 2 To Label1.Count - 1

    If Label1(i).Width + XR + x > Me.ScaleWidth Then       '如果本元素放上去会超出窗体
        y = y + Label1(0).Height + YR                      '换到下一行
        x = XR + Label1(i).Width
        Label1(i).Left = XR
        Label1(i).Top = y
    Else
        Label1(i).Left = x + XR                            '否则就放到本行
        x = x + XR + Label1(i).Width
        Label1(i).Top = y
    End If

    Label1(i).Visible = True                                '放完后显示
Next i

End Sub

Private Sub Form_Resize()
Call viewlab                                                '改变窗体大小时，重新排列
End Sub

Private Sub Label1_Click(Index As Integer)

'单击时
If Dir(apppath & Label1(Index).Caption) <> "" Then          '文件存在，防止显示列表后又把文件删掉，造成程序出错
    Shell apppath & Label1(Index).Caption, vbNormalFocus    '执行
Else
    MsgBox Label1(Index).Caption & " 已不存在，请检查！", vbCritical, "错误"
End If

End Sub

[ 本帖最后由风吹过b 于 2015-5-21 10:03 编辑 ]

#6

wmf20142015-05-21 09:58

VB用API创建动态菜单，并通过子菜单响应事件（百度到的，希望对楼主有帮助）。
1．模块代码如下：
注意：因为有用到AddressOf OnMenu，函数OnMenu只能放在模块部分。

Public Const MF_POPUP = &H10&
Public Const MF_STRING = &H0&
Public Const MF_DISABLED = &H2&
Public Const MF_SEPARATOR = &H800&
Public Const MF_CHECKED = &H8&
Public Const MF_GRAYED = &H1&
Public Const MF_BYCOMMAND = &H0&
Public Const GWL_WNDPROC = (-4)
Public Const WM_COMMAND = &H111
Public Declare Function CreateMenu Lib "user32" () As Long
Public Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function GetMenuItemCount Lib "user32" (ByVal hMenu As Long) As Long
Public Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Public Declare Function CreatePopupMenu Lib "user32" () As Long
Public Declare Function AppendMenu1 Lib "user32" Alias "AppendMenuA" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As String) As Long
Public Declare Function SetMenu Lib "user32" (ByVal hwnd As Long, ByVal hMenu As Long) As Long
Public Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
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 MenuCount As Long '菜单数量，不包括不能触发的菜单
Public MenuText() As String '菜单文本，ID=wParam的菜单的文本为MenuText(wParam - 1000)
Public OldWinProc As Long

Public Function OnMenu(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'{响应菜单事件}
Select Case wMsg
Case WM_COMMAND
If wParam > 1000 And wParam <= 1000 + MenuCount Then
MsgBox MenuText(wParam - 1000)
End If
End Select
OnMenu = CallWindowProc(OldWinProc, hwnd, wMsg, wParam, lParam)
End Function

2．Form1代码如下：
设计窗体的Negotiation=False，以防止弹出对话框或响应OnMenu后窗体上的菜单消失

Private Sub Form_Load()
Call CreateActiveMenu
End Sub

Sub CreateActiveMenu()
Dim hMenu As Long, hSubMenu As Long
Dim hPopMenuTmp As Long
ReDim MenuText(0)

hMenu = GetMenu(Me.hwnd) '窗体级菜单句柄
If hMenu = 0 Then
'窗体上没有菜单时，创建菜单。这种情况下需在设计阶段设置窗体的NegotiatMenu=False菜单才能显示出来。
hMenu = CreateMenu()
End If

'添加到0级菜单
hSubMenu = hMenu
FullAllSubMenu hSubMenu

'添加到1级菜单
hSubMenu = GetSubMenu(hSubMenu, GetMenuItemCount(hSubMenu) - 1) '获取最后一个0级菜单的句柄
FullAllSubMenu hSubMenu

'添加到2级菜单
hSubMenu = GetSubMenu(hSubMenu, GetMenuItemCount(hSubMenu) - 1)
FullAllSubMenu hSubMenu

'添加到3级菜单
hSubMenu = GetSubMenu(hSubMenu, GetMenuItemCount(hSubMenu) - 1)
FullAllSubMenu hSubMenu

SetMenu Me.hwnd, hMenu
DrawMenuBar Me.hwnd
Me.Refresh

OldWinProc = SetWindowLong(Me.hwnd, GWL_WNDPROC, AddressOf OnMenu)
End Sub

Sub FullAllSubMenu(hFather As Long)
'加入全部子菜单
Dim hPopMenuTmp As Long
Dim i As Integer
hPopMenuTmp = CreatePopupMenu()
For i = 0 To 4
MenuCount = MenuCount + 1
'保存菜单文本，用于菜单事件触发时识别出被选择的菜单对象
ReDim Preserve MenuText(MenuCount)
MenuText(MenuCount) = "文件" & MenuCount
'加入子菜单，令其ID>1000，说明其为自动生成的菜单
AppendMenu1 hPopMenuTmp, MF_STRING, 1000 + MenuCount, MenuText(MenuCount)
'如果是间隔线，则wFlags=MF_SEPARATOR
'如果要Check，则wFlags=MF_STRING + MF_CHECKED，若令不可用，则再加MF_GRAYED
Next
AppendMenu1 hFather, MF_POPUP, hPopMenuTmp, "&Files"
End Sub

#7

yuk_yu2015-05-21 10:13

统一回复各位版主，谢谢帮忙，我测试后回复大家结果，再次感谢！！

#8

yuk_yu2015-05-21 12:20

回复 5楼风吹过b

版主，可以给个实例吗？我调试是出错，提示加载错误！

#9

yuk_yu2015-05-21 12:24

回复 6楼 wmf2014

谢谢版主！

#10

yuk_yu2015-05-21 13:54

回复 5楼风吹过b

为何Unload and Load 出错？

#11

yuk_yu2015-05-21 14:36

回复 5楼风吹过b

已解决，谢谢版主关注！！