我目前正在使用以下代码来更新应用程序中的所有链接:
Sub AddSources()
Dim pubPage As Page
Dim pubShape As Shape
Dim hprlink As Hyperlink
Dim origAddress() As String
Dim exportFileName As String
exportFileName = "TestResume"
Dim linkSource As String
linkSource = "TestSource2"
For Each pubPage In ActiveDocument.Pages
For Each pubShape In pubPage.Shapes
If pubShape.Type = pbTextFrame Then
For Each hprlink In pubShape.TextFrame.TextRange.Hyperlinks
If InStr(hprlink.Address, "http://bleaney.ca") > 0 Then
origAddress = Split(hprlink.Address, "?source=")
hprlink.Address = origAddress(0) + "?source=" + linkSource
End If
Next hprlink
End If
Next pubShape
Next pubPage
ThisDocument.ExportAsFixedFormat pbFixedFormatTypePDF, "C:" + exportFileName + ".pdf"
End Sub
问题是当我更新链接时,它们会丢失格式。如何保留超链接的格式?我尝试查看复制和粘贴方法,但似乎我真正需要的是选择性粘贴,它不存在于超链接对象的 Range 属性中。
尝试添加以下行以捕获颜色和下划线,然后在地址更改后将其重新设置
Sub AddSources()
Dim pubPage As Page
Dim pubShape As Shape
Dim hprlink As Hyperlink
Dim origAddress() As String
Dim exportFileName As String
Dim undline AS Long
Dim clr AS Long
exportFileName = "TestResume"
Dim linkSource As String
linkSource = "TestSource2"
For Each pubPage In ActiveDocument.Pages
For Each pubShape In pubPage.Shapes
If pubShape.Type = pbTextFrame Then
For Each hprlink In pubShape.TextFrame.TextRange.Hyperlinks
If InStr(hprlink.Address, "http://bleaney.ca") > 0 Then
undline = hprlink.Range.Font.Underline
clr = hprlink.Range.Font.Color
origAddress = Split(hprlink.Address, "?source=")
hprlink.Address = origAddress(0) + "?source=" + linkSource
hprlink.Range.Font.Color = clr
hprlink.Range.Font.Underline = undline
End If
Next hprlink
End If
Next pubShape
Next pubPage
ThisDocument.ExportAsFixedFormat pbFixedFormatTypePDF, "C:" + exportFileName + ".pdf"
End Sub