请求帮助－根据文件夹目录生成菜单（已解决）

huanglicheng

请求帮助,根据某一个文件夹目录结构.用VBA在点击一个按钮时生成一个菜单,菜单的目录级别与文件夹一样
最终实现效果如下图类似

huanglicheng

请问有人可以帮我看一下.{:soso_e114:}

huanglicheng

再次求助一下。实在很需要这一项功能。希望哪位大师能帮忙看看

huanglicheng

求助了多个地方没有解决，自已组织了些代码效果还是实现了。可能还有些不足，先分享给大家参考参考
Sub Test()    '使用双字典，旨在提高速度
    Dim MyName$, I, MyFileName$, rr$
    Dim d As Object, Dic As Object
    Set d = CreateObject("scripting.dictionary")
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(0, "选择文件夹", &H10, 0)
    If Not objFolder Is Nothing Then lj = objFolder.self.Path & "\" Else MsgBox "没有选择文件夹": Exit Sub
    Set objFolder = Nothing
    Set objShell = Nothing
    On Error Resume Next

    CommandBars("tmpContextMenu").Delete
    Dim m As CommandBar
    Set m = CommandBars.Add("tmpContextMenu", msoBarPopup)
    Set regex1 = CreateObject("VBSCRIPT.REGEXP")    'RegEx为建立正则表达式
    With regex1
        .Global = True    '设置全局可用
        .Pattern = "[^\\]+"
    End With
    Set oSubMenu = m.Controls.Add(msoControlPopup)
    oSubMenu.Caption = lj
    Set oSubMenu2 = oSubMenu
    Set Dic = CreateObject("Scripting.Dictionary")    '创建一个字典对象
    Set d = CreateObject("Scripting.Dictionary")   '创建一个字典对象
    Dic(lj) = 0
    I = 0
    Do While I < Dic.Count
        Ke = Dic.keys   '开始遍历字典
        MyName = Dir(Ke(I), vbDirectory)    '查找目录
        Do While MyName <> ""
            If MyName <> "." And MyName <> ".." Then
                If (GetAttr(Ke(I) & MyName) And vbDirectory) = vbDirectory Then    '如果是次级目录
                    Dic(Ke(I) & MyName & "\") = 0    '就往字典中添加这个次级目录名作为一个条目
                End If
            End If
            MyName = Dir    '继续遍历寻找
        Loop
        I = I + 1
    Loop
For Each Ke In Dic.keys
        MyFileName = Dir(Ke & "*.*")
        Do While MyFileName <> ""
            If MyFileName <> "." And MyFileName <> ".." Then
                Set c1 = regex1.Execute(lj)
                Set c = regex1.Execute(Ke & MyFileName)
                If c.Count > c1.Count Then
                    For j = c1.Count To c.Count - 1
                        q = c.Item(j)
                        rr = rr & c.Item(j)
                        If Not d.exists(rr) Then
                            d(rr) = 0
                            If InStr(q, ".") = 0 Then
                                Set d(rr) = oSubMenu.Controls.Add(msoControlPopup)
                                Set oSubMenu = d(rr)
                                d(rr).Caption = q
                            Else
                                Set d(rr) = oSubMenu.Controls.Add(msoControlButton)
                                d(rr).Caption = q
                            End If
                        Else
                            Set oSubMenu = d(rr)
                        End If
                    Next j
                    Set oSubMenu = oSubMenu2
                    rr = ""
                End If
            End If
            MyFileName = Dir
        Loop
    Next
    m.ShowPopup
    Set c1 = Nothing
    Set c = Nothing
    Set Dic = Nothing
    Set d = Nothing
    Set m = Nothing
    Set oSubMenu = Nothing
    Set oSubMenu2 = Nothing
    Set regex1 = Nothing
End Sub生成效果图：

xtanuihazfh

http://club.excelhome.net/thread-724566-1-1.html
这里的代码库里面有一个完全动态创建菜单的例子,你可以直接拿去用,修改下根目录就可以了

huanglicheng

谢谢楼上的朋友，我想用这个代码和我其他功能连合一起，之间想改的地方也挺多了。你这个比我那要快好多{:soso_e181:}我的实现的一次性把目录全部建完。你的代码是一次性建一级目录。

huanglicheng

最终工具已实现。有需要的朋友可以到下面链接看看
经过几天的努力终于做出来了－快速打开硬盘文件 [url]http://club.excelhome.net/thread-760293-1-1.html [/url]

大雨治水

楼主的思路，完成的怎么样了，这几天我正在研究这个问题！{:soso_e121:}

ljjqaz

路过，想学习学习

ljjqaz

好东西，分享了