使用 Open XML 将 Word 文档中的文本替换为 URL

问题描述

我在一个项目中遇到问题，我想用可点击的 URL 替换 Word 文档中的一些标记文本。 下面的示例代码使用了一个仅包含文本 [Webpage] 的 word 文档。

这是有问题的代码：

 Imports DocumentFormat.OpenXml
 Imports DocumentFormat.OpenXml.Packaging
    
 Public Class Form1
     Private Sub Button1_Click(sender As Object,e As EventArgs) Handles Button1.Click
    
         MsgBox(processDocument("C:\temp\testdoc.docx","[Webpage]","Google","https://www.google.com"),MsgBoxStyle.ApplicationModal + vbOKOnly,"Text replace test")
    
     End Sub
    
     Private Function processDocument(ByVal tDocFilename As String,ByVal tagText As String,ByVal repltext As String,ByVal replURL As String) As String
    
    
         Using doc As WordprocessingDocument = WordprocessingDocument.Open(tDocFilename,True)
             Dim mainPart As DocumentFormat.OpenXml.Packaging.MainDocumentPart = doc.MainDocumentPart
    
             Dim textPLaceList As IEnumerable(Of Wordprocessing.Text) = mainPart.Document.Descendants(Of Wordprocessing.Text)()
    
             Try
                 For Each textPlaceHolder As Wordprocessing.Text In textPLaceList
                     Dim parent = textPlaceHolder.Parent
                     If (TypeOf parent Is Wordprocessing.Run) Then
                         If textPlaceHolder.Text.Contains("[") And textPlaceHolder.Text.Contains("]") Then
                             Dim tmpHyperlink As New DocumentFormat.OpenXml.Wordprocessing.Hyperlink
                             tmpHyperlink.Anchor = repltext
                             tmpHyperlink.DocLocation = replURL
                             tmpHyperlink.InsertBefore(Of Wordprocessing.Hyperlink)(tmpHyperlink,textPlaceHolder.Parent)
                             textPlaceHolder.Remove()
                             Exit For
                         End If
                     End If
                 Next
                 processDocument = "OK"
             Catch ex As Exception
                 processDocument = "Could not replace text in document (" & ex.Message & ")"
             End Try
    
         End Using
    
     End Function
    
 End Class

当我尝试使用 InsertBefore 或 InsertAfter 时，我收到一条错误消息，告诉我对象的“状态”不正确。 这是什么意思？

问候彼得·卡尔斯特罗姆

解决方法

这个论坛没有太大帮助。

经过一番挖掘，我自己找到了解决方案。

制作方法如下：

Imports DocumentFormat.OpenXml
Imports DocumentFormat.OpenXml.Wordprocessing
Imports DocumentFormat.OpenXml.Packaging

Public Class Form1
    Private Sub Button1_Click(sender As Object,e As EventArgs) Handles Button1.Click

        MsgBox(processDocument("C:\temp\testdoc.docx","[Webpage]","Google","https://www.google.com"),MsgBoxStyle.ApplicationModal + vbOKOnly,"Text replace test")

    End Sub

    Private Function processDocument(ByVal tDocFilename As String,ByVal tagText As String,ByVal replText As String,ByVal replURL As String) As String

        Using doc As WordprocessingDocument = WordprocessingDocument.Open(tDocFilename,True)
            Dim mainPart As DocumentFormat.OpenXml.Packaging.MainDocumentPart = doc.MainDocumentPart

            Dim textPLaceList As IEnumerable(Of Wordprocessing.Text) = mainPart.Document.Descendants(Of Wordprocessing.Text)()

            Try
                For Each textPlaceHolder As Wordprocessing.Text In textPLaceList
                    Dim parent As Wordprocessing.Paragraph = textPlaceHolder.Parent.Parent
                    If (TypeOf parent Is Wordprocessing.Paragraph) Then
                        If textPlaceHolder.Text.Contains("[") And textPlaceHolder.Text.Contains("]") Then
                            Dim newParagraph As Paragraph = getURLParagraph(mainPart,replText,replURL)
                            parent.Parent.InsertBefore(Of Wordprocessing.Paragraph)(newParagraph,parent)
                            textPlaceHolder.Remove()
                            Exit For
                        End If
                    End If
                Next
                processDocument = "OK"
            Catch ex As Exception
                processDocument = "Could not replace text in document (" & ex.Message & ")"
            End Try

        End Using

    End Function

    Private Function getURLParagraph(ByVal mainPart As MainDocumentPart,ByVal urlLabel As String,ByVal urlText As String) As Paragraph

        Dim urlExists As Boolean
        Dim hRelation As HyperlinkRelationship = Nothing

        Dim uri As System.Uri = New Uri(urlText)

        For Each hRel As HyperlinkRelationship In mainPart.HyperlinkRelationships
            If (hRel.Uri = uri) Then
                urlExists = True
                hRelation = hRel
                Exit For
            End If
        Next

        Dim relationshipId As String
        If Not urlExists Then
            Dim rel As HyperlinkRelationship = mainPart.AddHyperlinkRelationship(uri,True)
            relationshipId = rel.Id
        Else
            relationshipId = hRelation.Id
        End If

        Dim newParagraph As Paragraph = New Paragraph(New Hyperlink(New ProofError() With {
        .Type = ProofingErrorValues.GrammarStart
    },New Run(New RunProperties(New RunStyle() With {
        .Val = “Hyperlnk”}),New Text(urlLabel))) With {
        .History = OnOffValue.FromBoolean(True),.Id = relationshipId
    })
        Return newParagraph

    End Function
End Class

问候 彼得卡尔斯特罗姆