word中如何批量加入超链接？

如题所述

Public Declare Function GetShortPathName Lib "kernel32" Alias _
"GetShortPathNameA" (ByVal lpszLongPath As String, _
ByVal lpszShortPath As String, ByVal cchBuffer As _
Long) As Long
Public Function ShortPath(ByVal Path As String) As String
Dim Tmp As String
Dim L As Long
Tmp = String(256, 0)
L = GetShortPathName(Path, Tmp, Len(Tmp))
ShortPath = Replace(Left(Tmp, L), Chr(0), "")
End Function
Sub BatHyper()
Selection.HomeKey Unit:=wdStory '光标移到文档首
MyStart = -1
MyHyperDir = "C:\Documents and Settings\mkw\桌面\源文档\" '指定源文档所在的目录，可自行修改
If Dir(MyHyperDir, vbDirectory) = "" Then '判断源目录是否存在
MsgBox "你指定的源文件目录不存在，请修正后重试。", vbCritical, "消息"
Exit Sub
End If
Shell "cmd.exe /c dir /b " + ShortPath(MyHyperDir) + "*.doc > " + ShortPath(MyHyperDir) + "SHyper.txt" '获取该目录下doc类型的文件名，如果是docx类型，则自行修改即可
Do Until FileLen(MyHyperDir + "SHyper.txt") > 2 '等待提取文件名结束
DoEvents
Loop
Open MyHyperDir + "SHyper.txt" For Input As #11
Do Until EOF(11)
Line Input #11, MyHyperAdd
If Selection.Start = MyStart Then Exit Do
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "[0-9]{4}" '查找待插入超链接的标签通配符表达式，可自行修改
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
Selection.Find.Execute
On Error Resume Next
If Selection.Range.Hyperlinks(1).Target <> "" Then DoEvents
If Err.Number = 0 Then Exit Do '文档中的目标标签已设置完毕，提前结束操作
ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, Address:= _
MyHyperDir + MyHyperAdd, SubAddress:="", _
ScreenTip:="", TextToDisplay:="" '插入超链接关键代码
MyStart = Selection.Start
Selection.Find.Execute
Selection.MoveLeft , 1 '查找下一个标签的关键代码
Loop
Close (11)
MsgBox "处理完毕！"
End Sub

'本宏代码由mkw007达人提供。

温馨提示：内容为网友见解，仅供参考

当前网址：https://11.t2y.org/zz/v8qp8qpp2q28vvf4ps.html