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

weiyingde

as42065300 发表于 2016-9-9 21:06
最后字典里装入的数组 brr  ,别搞错了。
这2个循环可以优化成一个自己搞下把

有时间的话，还请你帮我优化一下，因为数组和Dir的联合使用，我还一时吃不消，烦请你帮我搞定，让我慢慢消化、理解并以此为此在现阶段好模仿着使用。

as42065300

帮你优化了。不过我很少写递归代码可能不严谨你自己测试，我这边测试没问题
自己感觉怎么好用好理解就怎么用把。

1. Private arr()
   
2. Private i%
   
3. Private Ts
   
4. Sub FilPaht()
   
5. Dim my$, mypaths$
   
6. my = ThisWorkbook.PatH & ""  '我这里是指定的当前工作簿的路径。
   
7. i = 1
   
8. Erase arr: Ts = ""
   
9. Qu my, 0
   
10. Sheet1.Range("a1").Resize(UBound(arr)) = Application.WorksheetFunction.Transpose(arr)
    
11. End Sub
    
12. Private Sub Qu(my$, j%)
    
13. Dim mypaths$, Mys$
    
14. Mys = Dir(my, vbDirectory)
    
15. Do While Mys <> ""
    
16. If Mys <> "." And Mys <> ".." And Mys <> ThisWorkbook.Name Then
    
17.     j = j + 1
    
18.     ReDim Preserve arr(1 To j)
    
19.     arr(j) = my & Mys & ""
    
20. End If
    
21.     Mys = Dir
    
22. Loop
    
23. If IsArray(Ts) = False Then Ts = arr: Erase arr: j = 0
    
24. If i > UBound(Ts) Then Exit Sub
    
25. my = Ts(i)
    
26. If my <> "" Then
    
27.     i = i + 1
    
28.     Qu my, j
    
29. Else
    
30.     Exit Sub
    
31. End If
    
32. End Sub
    

复制代码

weiyingde

还是有个问题，这段代码的运行平台是：powerpoint，而非excel，所以中间数据的储存放在excel表格中这个思路可能行不通。
你前面的代码，我只做极少的修改，就运行的非常稳定。

weiyingde

这句必须改动为其他的数组储存这个值：Sheet1.Range("a1").Resize(UBound(arr))

weiyingde

my 这个变量是否申明为pulic呢？因为你的两个过程都调用这个变量
我没有测试，但我感觉到这个肯定有问题。

weiyingde

as42065300 发表于 2016-9-9 22:46
帮你优化了。不过我很少写递归代码可能不严谨你自己测试，我这边测试没问题
自己感觉怎么好用好理解就怎么 ...

昨天喝醉了，看了你帖子之后，未加深究，为感受奇妙，遗憾。
今天再把的代码融入的程序之中，不知什么原因，还是没有结果，而且还没你原先的代码来得快。
这段代码的运行平台是ppt。
整个过程如下：
Sub 随机插入视频()
Dim my$, mypaths$, brr()
my = "H:\Ofenused\精选音频\视频\"  
i = 1
Erase arr: Ts = ""
Qu my, 0
sj = Int(Rnd * UBound(arr))
ReDim brr(LBound(arr) To UBound(arr))
brr(sj) = Left(arr(sj), Len(arr(sj)) - 1)
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:=brr(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
Private Sub Qu(my$, j%)
Dim mypaths$, Mys$
Mys = Dir(my, vbDirectory)
Do While Mys <> ""
If Mys <> "." And Mys <> ".." And Mys <> ActivePresentation.Name Then
    j = j + 1
    ReDim Preserve arr(1 To j)
    arr(j) = my & Mys & "\"
End If
    Mys = Dir
Loop
If IsArray(Ts) = False Then Ts = arr: Erase arr: j = 0
If i > UBound(Ts) Then Exit Sub
my = Ts(i)
If my <> "" Then
    i = i + 1
    Qu my, j
Else
    Exit Sub
End If
End Sub

weiyingde

你的原始代码，在生成文件名是文件名后带了一个“\"，我不得不做了改动，加了这一样几句
sj = Int(Rnd * UBound(arr))
ReDim brr(LBound(arr) To UBound(arr))
brr(sj) = Left(arr(sj), Len(arr(sj)) - 1)
没有弹出错误，而且显示正在插入视频，但就是不见插入的视频。不知是什么原因。
请大侠帮我一看：
（1）整个代码没有效果，原因何在？
（2）brr(sj) = Left(arr(sj), Len(arr(sj)) - 1) ，如果不用这句去掉“\”，该在你代码的什么地方修改
我尝试： arr(j) = my & Mys & "\"这句后的反斜杠，但是还是出问题。
请大侠帮我一看。

as42065300

附件还没删直接给你吧！自己研究下.
解压后直接打开工作簿运行看结果懂了然后在像你的代码中套。
数组和递归过程都有。另外在递归过程中去掉了"\"这个符号
音视频.rar (21.97 KB, 下载次数: 7)

2016-9-11 21:40 上传

点击文件名下载附件

weiyingde

duquancai 发表于 2016-9-9 20:04

你的这个，试试可行，只是arr(1 To 10000)，你预设的上限1000，结果在随机的抽取的时候，却抽到了很多的空文件夹，因为该路径下只有6个文件夹，按照几率来说，抽到的几率就是6/10000，我把它去掉了，就没有结果。这个能设为arr ()  然后再通过redim preserve arr（1 to X)的形式设定吗？
请你帮我看一看

嵌入到程序中，整个过程是：
Sub 随机插入视频()
    Dim arr() As String, i&, k&
h = ActivePresentation.PageSetup.SlideHeight / 2
w = ActivePresentation.PageSetup.SlideWidth / 2
l = w / 4 + 10
t = h / 2
    arr(1) = "H:\Ofenused\精选音频\视频\" '请指定路径
    i = 1: k = 1
    Do While i <= k
        If arr(i) = "" Then Exit Do
        f = Dir(arr(i), vbDirectory)
        Do
            If InStr(f, ".") = 0 And f <> "" Then
                k = k + 1
                arr(k) = arr(i) & f & "\"
            End If
            f = Dir
        Loop Until f = ""
        i = i + 1
    Loop
zd = UBound(arr)
ipth = arr(Int(Rnd * zd))
MsgBox ipth
Set d = CreateObject("scripting.dictionary")
mn = Dir(ipth & "*.*")
  Do While mn <> ""
    d(ipth & mn) = ""
    mn = Dir
  Loop
k1 = d.keys
sj = Rnd * UBound(k1)
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:=k1(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

请帮我看看。

山菊花

Sub 视频文件()
    Dim cPath$, cFile$, Arr(), Brr(), Crr, i1%, i2%, m1%, m2%
    cPath = ActivePresentation.Path & "\"
    ReDim Arr(0 To 100), Brr(1 To 100)
    Arr(0) = cPath
    On Error Resume Next
    Do
        cFile = Dir(Arr(i1), 16)
        Do While cFile <> ""
            If cFile <> "." And cFile <> ".." Then
                m2 = GetAttr(Arr(i1) & cFile)
                If Err = 0 Then
                    If m2 = 16 Then
                        i2 = i2 + 1
                        If i2 > UBound(Arr) Then ReDim Preserve Arr(0 To UBound(Arr) + 100)
                        Arr(i2) = Arr(i1) & cFile & "\"
                    Else
                        Crr = Split(cFile, ".")
                        If "AVI,WMA,RMVB,RM,FLASH,MP4,MID,3GP" Like "*" & UCase(Crr(UBound(Crr))) & "*" Then
                            m1 = m1 + 1
                            If m1 > UBound(Brr) Then ReDim Preserve Brr(1 To UBound(Brr) + 100)
                            Brr(m1) = Arr(i1) & cFile
                        End If
                    End If
                Else
                    Err.Clear
                End If
            End If
            cFile = Dir
        Loop
        i1 = i1 + 1
    Loop Until i1 > i2
   
    '显示结果
    For i = 1 To m1
        Debug.Print Brr(i)
    Next
   
End Sub