这是我的解决方案。特定于 HP 质量中心。我暂时忽略图标。
Sub ConvertHyperLinks()
'
' Macro to replace HyperLinks with embedded objects for
' report documents generated by HP Quality Center.
'
Dim numH, numT, i, j, k, m, n, rowCount, cellCount As Integer
Dim strPath() As String
Dim strFileName, strFileName2, strExt As String
Dim hName, tblCell1, reqidLabel, regId, preFixLen, preFix As String
Dim found As Boolean
Dim lngIndex As Long
numH = ActiveDocument.Hyperlinks.Count
For i = 1 To numH
found = False
hName = ActiveDocument.Hyperlinks(i).Name
strPath() = Split(hName, "\")
lngIndex = UBound(strPath)
strFileName = strPath(lngIndex)
strPath() = Split(strFileName, ".")
lngIndex = UBound(strPath)
strExt = UCase(strPath(lngIndex))
strFileName2 = OnlyAlphaNumericChars(strFileName)
'Each HyperLink is in single row/column table
'And a FIELDLABEL table contains the REQ number
'Iterate to find the current REQ number as it has been
'prepended to the filename.
'We are processess from start of doc to end
'so the REQ number applies to the immediate Attachments
'in the same document section.
numT = ActiveDocument.Tables.Count
For j = 1 To numT
tblCell1 = OnlyAlphaNumericChars(ActiveDocument.Tables(j).Rows(1).Cells(1).Range.Text)
If UCase(tblCell1) = "FIELDLABEL" Then
rowCount = (ActiveDocument.Tables(j).Rows.Count)
For k = 1 To rowCount
cellCount = (ActiveDocument.Tables(j).Rows(k).Cells.Count)
For m = 1 To cellCount
reqidLabel = OnlyAlphaNumericChars(ActiveDocument.Tables(j).Rows(k).Cells(m).Range.Text)
If reqidLabel = "ReqID" Then
regId = OnlyAlphaNumericChars(ActiveDocument.Tables(j).Rows(k).Cells(m + 1).Range.Text)
regId = "REQ" & regId
preFixLen = Len(regId)
preFix = Mid(strFileName2, 1, preFixLen)
If preFix = regId Then
found = True
Exit For
End If
End If
Next
If found Then Exit For
Next
End If
If found Then
'Continue to iterate tables to find the actual table
'containing the Link
If UCase(regId & tblCell1) = UCase(strFileName2) Then
'Select the table and move to the next document line
'that follows it.
ActiveDocument.Tables(j).Select
Selection.Collapse WdCollapseDirection.wdCollapseEnd
Selection.TypeText Text:=Chr(11)
'Outstanding is finding an Icon for the type
'of Object being embedded
'This embeds with a blank Icon.
'But the Icon caption is the Extension.
Selection.InlineShapes.AddOLEObject _
FileName:=hName, _
LinkToFile:=False, DisplayAsIcon:=True, _
IconLabel:=strExt
'IconFileName:=strFileName, IconIndex:=0,
Selection.TypeText Text:=Chr(11)
Selection.TypeText Text:=strFileName
Selection.TypeText Text:=Chr(11)
Selection.TypeText Text:=Chr(11)
Exit For
End If
End If
Next
Next
'Delete all the Hyperlinks as they are meainingless
'if the document is to be emailed.
'TODO May delete the table the link is contained in.
With ActiveDocument
For n = .Hyperlinks.Count To 1 Step -1
.Hyperlinks(n).Delete
Next
End With
End Sub