这个获取文件名，能否改成word版本

413191246se

____139：我的《通用模板宏》辅助菜单中就有提取文件名的宏命令，你可以使用。经测试，能提取桌面上的文件夹中的文件名。
——杜先生 代码太高明，在我这儿，只提取了一个；也许是在2003下的缘故，杜先生 的 WORD 是 2007 的，可能。
——谢谢 杜先生！前几天的《公文四个标题层次》宏代码很好，但我也看不懂，函数更是一窍不通。另外，尚有其它周边的小宏我要完善；我还向 杜先生 学会了类似 Dim i$ 这样的用法，省了不少字节。其它宏也有不少 杜先生 的代码，真是太感谢了！

413191246se

139：请暂时用我的试试吧！文件扩展名要键入 3 个字母，如：doc/txt/xls/......

1. Sub a循环遍历文件夹_提取文件名()
   
2.     On Error Resume Next
   
3.     Dim fd As FileDialog, i As Long, doc As Document, p As String, s$
   
4.     s = InputBox("请输入要提取的文件扩展名！" & vbCr & "Word文档(*.doc)    Excel工作簿(*.xls)" & vbCr & "文本文档(*.txt)    PowerPoint幻灯片(*.ppt)", "提取文件名", "doc")
   
5.     If s = "" Then Exit Sub
   
6.     Set fd = Application.FileDialog(msoFileDialogFolderPicker)
   
7.     If fd.Show = -1 Then p = fd.SelectedItems(1) Else Exit Sub
   
8.     Set fd = Nothing
   
9.     If MsgBox("是否处理文件夹 " & p & " ?", vbYesNo + vbExclamation, "循环遍历文件夹_提取文件名") = vbNo Then Exit Sub
   
10.     Documents.Add
    
11.     With Application.FileSearch
    
12.         .NewSearch
    
13.         .LookIn = p
    
14.         .SearchSubFolders = True
    
15.         .FileName = "*." & s
    
16.         If .Execute > 0 Then
    
17.             For i = 1 To .FoundFiles.Count
    
18.                 ActiveDocument.Content.InsertAfter Text:=.FoundFiles(i) & vbCr
    
19.             Next i
    
20.             MsgBox "处理完毕！共处理 " & .FoundFiles.Count & " 个文件！", vbOKOnly + vbExclamation, "循环遍历文件夹_提取文件名"
    
21.         Else
    
22.             MsgBox "未发现文件！", vbOKOnly + vbCritical, "循环遍历文件夹_提取文件名"
    
23.         End If
    
24.     End With
    
25. End Sub

复制代码

13907933959

413191246se 发表于 2017-5-25 21:14
139：请暂时用我的试试吧！文件扩展名要键入 3 个字母，如：doc/txt/xls/......

师傅好！
好的、这个可以了，感谢师傅！！！

duquancai

13907933959 发表于 2017-5-25 06:38
杜前辈好！
好的、我本来的意思是想再劳您把11楼的代码完善一下，让它把直接复制粘贴到桌面上的文件夹， ...

看你说的啥啊？我给你一个 高级的，你拿去用吧》》》》》》》》

Sub FSO_提取全路径文件()
    Dim f As Object, fd As Object, fso As Object, Stack$(), top&
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then pPath$ = .SelectedItems(1) Else MsgBox "请选目标文件夹": Exit Sub
    End With
    Set fso = CreateObject("Scripting.FileSystemObject")
    top = 1: ReDim Stack(0 To top)
    Do While top >= 1
        For Each f In fso.GetFolder(pPath).Files
            n = n + 1
            stxt = stxt & f.Path & Chr(13)
        Next
        For Each fd In fso.GetFolder(pPath).SubFolders
            Stack(top) = fd.Path: top = top + 1
            If top > UBound(Stack) Then ReDim Preserve Stack(0 To top)
        Next
        If top > 0 Then pPath = Stack(top - 1): top = top - 1
    Loop
    ActiveDocument.Content.Text = Empty
    ActiveDocument.Content.Text = stxt
    MsgBox "已提取：" & n & "个包含选择路径下的所有文件！"
End Sub

13907933959

duquancai 发表于 2017-5-26 10:03
看你说的啥啊？我给你一个 高级的，你拿去用吧》》》》》》》》

Sub FSO_提取全路径文件()

杜前辈好！
不但比我师傅的代码快，还统吃，真的是高级！微秒级的秒杀！眼睛都没反应过来，2000多个文件名就提取好了。拜谢前辈！！！