同一文件夹下的WORD文件,用VBA显示所有WORD类型文件目录

同一文件夹下的WORD文件,用VBA显示所有WORD类型文件目录

打开一WORD文件, 则可显示全部该文件夹的所有WORD类型,文件名!

参考贴子：http://club.excelhome.net/viewthread.php?tid=69821

你好，YORK888

请参：

'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋'* Created By I Love You_Word!@ExcelHome 2005-7-1 07:22:36'仅测试于System: Windows NT Word: 10.0 Language: 2052'^The Code CopyIn [ThisDocument-ThisDocument]^''* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－

Option ExplicitSub WordFilesList()Dim MyFolderString As String, AllWordFileType As Variant, WordFileType As Variant'取得本文档的路径MyFolderString = ThisDocument.Path'如果本文档未保存过则提示保存并退出程序运行If MyFolderString = "" Then MsgBox "你必须先保存本文档!", vbOKOnly + vbInformation: Exit Sub'定义一个所有WORD程序能打开的文件类型(请再枚举,只是示例)AllWordFileType = Array("*.doc", "*.dot", "*.rtf", "*.txt", "*.wiz", "*.dochtml", "*.docmhtml", "*.dothtml")'在所有文件类型中循环For Each WordFileType In AllWordFileType'在文档开始处插入指定的查找文件名ThisDocument.Range(0, 0).InsertAfter GetWordFiles(MyFolderString, WordFileType)NextEnd Sub'----------------------Function GetWordFiles(FolderPath As String, FileType As Variant) As StringDim Root As String, MyFileList As String, AWordFile As StringRoot = VBA.Left(FolderPath, 1)'取得盘符(根目录)ChDrive Root'设置当前驱动器盘符ChDir FolderPath'进入指定目录AWordFile = Dir(FileType)Do While AWordFile <> ""'如果是文件夹,或者没有此文件,则会返回""Debug.Print AWordFileMyFileList = MyFileList & AWordFile & vbCrLf'内存中变量累加AWordFile = Dir()LoopIf MyFileList = "" ThenMyFileList = "Word 没有发现在路径为""""" & FolderPath & """""的任何" & VBA.UCase(Mid(FileType, 3, Len(FileType) - 2)) & "文件" & vbCrLfElseMyFileList = "Word查找到路径为" & """" & FolderPath & """" & "的" & VBA.UCase(Mid(FileType, 3, Len(FileType) - 2)) & "文件列表如下:" & vbCrLf & MyFileListEnd If'MsgBox MyFileList'函数返回为文件列表变量MyFileList值GetWordFiles = MyFileListEnd Function'----------------------Private Sub Document_Open()WordFilesListEnd Sub'----------------------如果出现以下情况（版本号不同），请据实修改：

http://club.excelhome.net/viewthread.php?tid=104218第四楼

守版主,你好!

非常感谢,你的回复,已经运行正常了,!在次多谢! 当你出书时我第一个购买!

还有一个问题, 能否实出在显示出来的目录中, 点击该目录则能打开文件?? 请问是否有办法解决? 多谢版主大人!

请参考：

'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋'* Created By I Love You_Word!@ExcelHome 2005-7-6 11:43:59'仅测试于System: Windows NT Word: 10.0 Language: 2052'^The Code CopyIn [ThisDocument-ThisDocument]^''* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－

'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋'* Created By I Love You_Word!@ExcelHome 2005-7-1 07:22:36'仅测试于System: Windows NT Word: 10.0 Language: 2052'^The Code CopyIn [ThisDocument-ThisDocument]^''* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－Option ExplicitSub WordFilesList()Dim MyFolderString As String, AllWordFileType As Variant, WordFileType As VariantDim StartRange As Long, EndRange As Long, MyRange As Range, MyString As StringDim i As Paragraph, strFileName As String'一个比较大的发现,在VBA中对Document .Hyperlinks.Add 时,在连续段落中ADD时出现异常,本.Hyperlink'将修改上一个.Hyperlink,实在百思不得其解!'取得本文档的路径Application.ScreenUpdating = FalseMyFolderString = ThisDocument.Path'如果本文档未保存过则提示保存并退出程序运行If MyFolderString = "" Then MsgBox "你必须先保存本文档!", vbOKOnly + vbInformation: Exit Sub'定义一个所有WORD程序能打开的文件类型(请再枚举,只是示例)AllWordFileType = Array("*.doc", "*.dot", "*.rtf", "*.txt", "*.wiz", "*.dochtml", "*.docmhtml", "*.dothtml")'在所有文件类型中循环With ThisDocumentFor Each WordFileType In AllWordFileType'在文档开始处插入指定的查找文件名MyString = GetWordFiles(MyFolderString, WordFileType)StartRange = .Content.End - 1.Content.InsertAfter MyStringEndRange = .Content.End - 1If VBA.InStr(MyString, "Word 没有发现在路径为") = 0 ThenSet MyRange = .Range(StartRange, EndRange)Set MyRange = .Range(MyRange.Paragraphs(2).Range.Start, EndRange)For Each i In MyRange.ParagraphsIf Len(i.Range) > 1 ThenstrFileName = .Range(i.Range.Start, i.Range.End - 1)strFileName = MyFolderString & "\" & strFileName.Hyperlinks.Add Anchor:=i.Range, Address:=strFileNameEnd IfNextEnd IfNextEnd WithApplication.ScreenUpdating = TrueEnd Sub'----------------------'----------------------Function GetWordFiles(FolderPath As String, FileType As Variant) As StringDim Root As String, MyFileList As String, AWordFile As StringRoot = VBA.Left(FolderPath, 1)'取得盘符(根目录)ChDrive Root'设置当前驱动器盘符ChDir FolderPath'进入指定目录AWordFile = Dir(FileType)Do While AWordFile <> ""'如果是文件夹,或者没有此文件,则会返回""'Debug.Print AWordFileMyFileList = MyFileList & AWordFile & Chr(13) & Chr(13)'内存中变量累加AWordFile = Dir()LoopIf MyFileList = "" ThenMyFileList = "Word 没有发现在路径为""""" & FolderPath & """""的任何" & VBA.UCase(Mid(FileType, 3, Len(FileType) - 2)) & "文件" & vbCrLfElseMyFileList = "Word查找到路径为" & """" & FolderPath & """" & "的" & VBA.UCase(Mid(FileType, 3, Len(FileType) - 2)) & "文件列表如下:" & vbCrLf & MyFileListEnd If'MsgBox MyFileList'函数返回为文件列表变量MyFileList值GetWordFiles = MyFileListEnd Function'----------------------'----------------------Private Sub Document_Open()WordFilesListEnd Sub'----------------------

'一个比较大的发现,在VBA中对Document .Hyperlinks.Add 时,在连续段落中ADD时出现异常,本.Hyperlink'将修改上一个.Hyperlink,实在百思不得其解!所以，我只能加外空白段落进行处理，而且，这些外加段落目前尚不能删除，手动可以，程序删除会出错！替换只能一次一个。好在无妨，此问题，我将做进一步跟踪，这个题，有点意思，耗了我一个多小时找原因啊！

感谢, 守柔版主!

非常好用! 太棒了! 向版主学习!

学习了。

感谢, 守柔版主!
能否增加一功能：列出文件目录包含子文件夹下的文件，谢谢！
使用WORD2007发现不再支持FileSearch，没办法对子文件夹再搜索，又对代码了解不多，特来求助增加列出含子目录的文件名称。

做个标记，学习ing……

我不知如何用?请守柔版主贴出完整代码,并附使用说明.