|
请参考： '* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋
'* 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 Explicit
Sub WordFilesList()
Dim MyFolderString As String, AllWordFileType As Variant, WordFileType As Variant
Dim StartRange As Long, EndRange As Long, MyRange As Range, MyString As String
Dim i As Paragraph, strFileName As String
'一个比较大的发现,在VBA中对Document .Hyperlinks.Add 时,在连续段落中ADD时出现异常,本.Hyperlink
'将修改上一个.Hyperlink,实在百思不得其解!
'取得本文档的路径
Application.ScreenUpdating = False
MyFolderString = ThisDocument.Path
'如果本文档未保存过则提示保存并退出程序运行
If MyFolderString = "" Then MsgBox "你必须先保存本文档!", vbOKOnly + vbInformation: Exit Sub
'定义一个所有WORD程序能打开的文件类型(请再枚举,只是示例)
AllWordFileType = Array("*.doc", "*.dot", "*.rtf", "*.txt", "*.wiz", "*.dochtml", "*.docmhtml", "*.dothtml")
'在所有文件类型中循环
With ThisDocument
For Each WordFileType In AllWordFileType
'在文档开始处插入指定的查找文件名
MyString = GetWordFiles(MyFolderString, WordFileType)
StartRange = .Content.End - 1
.Content.InsertAfter MyString
EndRange = .Content.End - 1
If VBA.InStr(MyString, "Word 没有发现在路径为") = 0 Then
Set MyRange = .Range(StartRange, EndRange)
Set MyRange = .Range(MyRange.Paragraphs(2).Range.Start, EndRange)
For Each i In MyRange.Paragraphs
If Len(i.Range) > 1 Then
strFileName = .Range(i.Range.Start, i.Range.End - 1)
strFileName = MyFolderString & "\" & strFileName
.Hyperlinks.Add Anchor:=i.Range, Address:=strFileName
End If
Next
End If
Next
End With
Application.ScreenUpdating = True
End Sub
'----------------------
'----------------------
Function GetWordFiles(FolderPath As String, FileType As Variant) As String
Dim Root As String, MyFileList As String, AWordFile As String
Root = VBA.Left(FolderPath, 1) '取得盘符(根目录)
ChDrive Root '设置当前驱动器盘符
ChDir FolderPath '进入指定目录
AWordFile = Dir(FileType)
Do While AWordFile <> "" '如果是文件夹,或者没有此文件,则会返回""
' Debug.Print AWordFile
MyFileList = MyFileList & AWordFile & Chr(13) & Chr(13) '内存中变量累加
AWordFile = Dir()
Loop
If MyFileList = "" Then
MyFileList = "Word 没有发现在路径为""""" & FolderPath & """""的任何" & VBA.UCase(Mid(FileType, 3, Len(FileType) - 2)) & "文件" & vbCrLf
Else
MyFileList = "Word查找到路径为" & """" & FolderPath & """" & "的" & VBA.UCase(Mid(FileType, 3, Len(FileType) - 2)) & "文件列表如下:" & vbCrLf & MyFileList
End If
'MsgBox MyFileList
'函数返回为文件列表变量MyFileList值
GetWordFiles = MyFileList
End Function
'----------------------
'----------------------
Private Sub Document_Open()
WordFilesList
End Sub
'---------------------- '一个比较大的发现,在VBA中对Document .Hyperlinks.Add 时,在连续段落中ADD时出现异常,本.Hyperlink
'将修改上一个.Hyperlink,实在百思不得其解!
所以，我只能加外空白段落进行处理，而且，这些外加段落目前尚不能删除，手动可以，程序删除会出错！替换只能一次一个。好在无妨，此问题，我将做进一步跟踪，这个题，有点意思，耗了我一个多小时找原因啊！  | 
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2005-6-30 15:41
楼主
发表于 2011-3-17 22:47
