怎样将指定路径的最末一级文件夹的全路径名录入数组

weiyingde

lsc900707 发表于 2016-9-9 19:43
可参考：
超好用的遍历文件夹及子文件夹,返回文件列表数组,可搜索文件类型,傻瓜版通用VBA函数
http://c ...

这个放在工作表中好用，不错，但我只要“音视频”目录中最后一级文件夹的全名。中间的目录名一概不要，并将其录入用数组。
因为我这是ppt VBA中的一段代码，我的目的是，利用arr(int(rnd*Ubound(arr)))随机抽取文件夹，然后再从随机抽取的文件夹中，随机抽取音频或视频文件进行播放。

weiyingde

操作的界面是放映状态下的ppt中。

weiyingde

原代码如下：

Sub 插入视频()
h = ActivePresentation.PageSetup.SlideHeight / 2
w = ActivePresentation.PageSetup.SlideWidth / 2
l = w / 4 + 10
t = h / 2
  pth1 = "H:\Ofenused\视频\电影\"
  pth2 = "H:\Ofenused\视频\歌曲\"
  pth3 = "H:\Ofenused\视频\新歌\"
  pth4 = "H:\Ofenused\视频\杂合\"
  pth5 = "H:\Ofenused\视频\郑云\"
  arr = Array(pth1, pth2, pth3, pth4, pth5)
  zd = UBound(arr)
  ipth = arr(Int(Rnd * zd))
Set d = CreateObject("scripting.dictionary")
mn = Dir(ipth & "*.*")
  Do While mn <> ""
    d(ipth & mn) = ""
    mn = Dir
  Loop
k = d.keys
sj = Rnd * UBound(k)

For Each shp In ActivePresentation.SlideShowWindow.View.Slide.Shapes
    If shp.Type = 16 Then shp.Delete
Next
Set shp = Nothing
Set shps = ActivePresentation.SlideShowWindow.View.Slide.Shapes
With shps.AddMediaObject2(FileName:=k(sj), Left:=l, Top:=t, Width:=w, Height:=h)
     Randomize
           .AutoShapeType = Choose(Int(Rnd * 9) + 1, 6, 9, 10, 132, 13, 28, 94, 95, 96)
        With .ThreeD
          If sj Mod 2 = 1 Then
          .SetThreeDFormat msoThreeD & (Int(Rnd * 20) + 1)
          Else
          .BevelTopType = 3
          .BevelTopDepth = 10
          .BevelBottomType = 3
          .BevelBottomDepth = 6
         End If
        End With
     End With
End Sub

weiyingde

我想把这个获取子目录的任务交给电脑自动搜索处理，因为最后一级文件夹，随时都有增减，实现预设的话，不仅机械，而且还要随着实际情况的改变而要改动代码，很是麻烦。
其二，也是想借助数组，压缩代码，提高效率。

weiyingde

新增加的代码，要实现下列代码的最用：
pth1 = "H:\Ofenused\视频\电影\"
  pth2 = "H:\Ofenused\视频\歌曲\"
  pth3 = "H:\Ofenused\视频\新歌\"
  pth4 = "H:\Ofenused\视频\杂合\"
  pth5 = "H:\Ofenused\视频\郑云\"
  arr = Array(pth1, pth2, pth3, pth4, pth5)
  zd = UBound(arr)
  ipth = arr(Int(Rnd * zd))

weiyingde

lsc900707 发表于 2016-9-9 19:43
可参考：
超好用的遍历文件夹及子文件夹,返回文件列表数组,可搜索文件类型,傻瓜版通用VBA函数
http://c ...

烦请大侠帮我看看，能否实现这个目的。

weiyingde

as42065300 发表于 2016-9-9 19:02
不知道是不是你想要的结果。

as42065300 朋友，这个目的能否实现？

weiyingde

as42065300 发表于 2016-9-9 20:02
套个循环就可以了。没理解你的意思

测试效果是：
H:\音视频\视频\
H:\音视频\音频\
H:\音视频\视频\小品\
H:\音视频\视频\电影\
H:\音视频\视频\电视剧\
H:\音视频\视频\诗歌\
H:\音视频\视频\郑云微电影\
H:\音视频\音频\佛音\
H:\音视频\音频\手机铃声\
H:\音视频\音频\流行曲\
H:\音视频\音频\自备音效\
H:\音视频\音频\课间钟声\
H:\音视频\音频\轻音乐\
H:\音视频\音频\颁奖曲\
很好，只可惜还有两个父目录在数组之中
H:\音视频\视频\
H:\音视频\音频\
如何在录入数组之前，先把它去掉。烦请大侠不吝赐教。
我对数组可谓是一窍不通。
……
这个一定要去掉的，
因为这段代码我要用在一个程序之中
就是先随机抽取文件夹，然后在随机抽取其中的音视频文件。

as42065300

你的意思是把
  pth1 = "H:\Ofenused\视频\电影\"
  pth2 = "H:\Ofenused\视频\歌曲\"
  pth3 = "H:\Ofenused\视频\新歌\"
  pth4 = "H:\Ofenused\视频\杂合\"
  pth5 = "H:\Ofenused\视频\郑云\"
  arr = Array(pth1, pth2, pth3, pth4, pth5)
这段代码为VBA自动搜索？

as42065300

不用去掉的。你就判断随机数如果是0 和1 就重新生成新的。
ipth = arr(Int(Rnd * zd))
这里加判断ipth 如果=1或2还有0 就重新生成 就可以避免取到父级的2个文件名
Set d = CreateObject("scripting.dictionary")