楼主
kevinchengcw |
Q: 如何用vba代码将word文本中的网址或下载地址加上超链接并修改字体？
A: 实现代码如下：- Sub test()
- Dim HLK As Hyperlink, Match, Dic As Object, Arr, N&, I&, Str$
- '先删除全部的链接(本步骤可根据需要取消)
- Do
- For Each HLK In ThisDocument.Hyperlinks
- HLK.Delete
- Next HLK
- Loop While ThisDocument.Hyperlinks.Count > 0
- Application.ScreenUpdating = False '关闭屏幕刷新,提高处理速度
- With CreateObject("vbscript.regexp") '创建正则项目,用于提取网址或下载地址
- .Global = True '全局有效
- .MultiLine = True '多行有效
- .ignorecase = True '忽略大小写
- .Pattern = "[\w\d]+\:\/\/[\x20-\x7e]{4,128}|(([\w\/]+\.)+(com|cn|net|cc|la))" '设置匹配规则(因word查找的文本有长度限制,故设置最长匹配128个字符)
- If .test(ThisDocument.Range.Text) Then '判断当前文档是否有匹配内容,如果有,则
- Set Dic = CreateObject("scripting.dictionary") '创建字典项目用于提取内容的去除重复
- For Each Match In .Execute(ThisDocument.Range.Text) '循环各个匹配项
- Dic(Match.Value) = "" '利用字典去除重复内容
- Next Match
- Arr = Dic.keys '提取出网址列表
- For N = LBound(Arr) To UBound(Arr) - 1 '进行排序,长的网址在前,短的网址在后,用于避免短网址包含于长网址内先行查找造成处理结果不合要求的情况
- For I = N + 1 To UBound(Arr)
- If Len(Arr(I)) > Len(Arr(N)) Then
- Str = Arr(I)
- Arr(I) = Arr(N)
- Arr(N) = Str
- End If
- Next I
- Next N
- Set Dic = Nothing '清空字典项目
- For N = LBound(Arr) To UBound(Arr) '循环处理列表中的各个网址
- With Selection.Find '设定查找参数
- .ClearFormatting '不查找格式
- .Forward = True '向下查找
- .Wrap = wdFindStop '到文档结尾后结束
- .Text = Arr(N) '查找内容为当前循环到的数组项目中网址内容
- .Parent.HomeKey wdStory '跳到文档开头
- Do
- .Execute '执行查找
- If .Found Then '如果找到对应内容
- If .Parent.Range.Text Like "*://*" Then .Parent.Expand wdSentence '如果含有标志字段则选中整个句段
- Str = .Parent.Range.Text '取得选区的文本
- ThisDocument.Range(Selection.Range.Start + InStr(Str, Arr(N)) - 1, Selection.Range.Start + Len(Replace(Str, Chr(13), ""))).Select '根据网址开头和结尾特征修正选区范围
- If .Parent.Hyperlinks.Count = 0 Then '如果选区没有链接,则添加链接
- .Parent.Hyperlinks.Add .Parent.Range, IIf(Arr(N) Like "*://*", .Parent.Range.Text, "http://" & Arr(N)), , , .Parent.Range.Text
- Else '否则退出循环
- Exit Do
- End If
- End If
- Loop While .Found '查找不到时退出循环
- End With
- Next N
- For Each HLK In ThisDocument.Hyperlinks '循环文档中各个链接
- With HLK.Range.Font '设置链接区域的字体
- .Name = "Times New Roman"
- .Size = 16
- .Color = wdColorRed
- .Bold = True
- .Italic = True
- End With
- Next HLK
- End If
- End With
- Application.ScreenUpdating = True '打开屏幕刷新
- End Sub
详见附件及素材源帖。
 网址加链接.rar
|
