将嵌入图像转换为链接

Question

我正在尝试修复宏,如下所示.

它旨在将嵌入图像转换为链接(通过IncludePicture).但是,在当前状态下,图像会添加到文档的底部.显然,它远非完美.相反,宏应该逐个替换嵌入图像与链接的图像,如下所示:

怎么解决？

另请注意:应从其他文件启动宏.因此,您需要两个文档:一个是宏,一个是图像.这不好,但目前它的工作原理.

码:

Sub MakeDocMediaLinked()
    Application.ScreenUpdating = False
    Dim StrOutFold As String, Obj_App As Object, Doc As Document, Rng As Range
    Dim StrDocFile As String, StrZipFile As String, StrMediaFile As String
    With Application.Dialogs(wdDialogFileOpen)
        If .Show = -1 Then
            .Update
            Set Doc = ActiveDocument
        End If
    End With
    If Doc Is Nothing Then Exit Sub
    With Doc
        ' ID the document to process
        StrDocFile = .FullName
        StrOutFold = Split(StrDocFile, ".")(0) & "_Media"
        .Close SaveChanges:=False
    End With
    ' Test for existing output folder, create it if it doesn't already exist
    If Dir(StrOutFold, vbDirectory) = "" Then MkDir StrOutFold
    ' In case the output folder is not empty. Also, in case the file has no media
    On Error Resume Next
    ' Delete any files in the output folder
    Kill StrOutFold & "\*.*"
    ' Create a Shell App for accessing the zip archives
    Set Obj_App = CreateObject("Shell.Application")
    ' Define the zip name
    StrZipFile = Split(StrDocFile, ".")(0) & ".zip"
    ' Create the zip file, by simply copying to a new file with a zip extension
    FileCopy StrDocFile, StrZipFile
    ' Extract the zip archive's media files to the temporary folder
    Obj_App.NameSpace(StrOutFold & "\").CopyHere Obj_App.NameSpace(StrZipFile & "\word\media\").Items
    ' Delete the zip file - the loop takes care of timing issues
    Do While Dir(StrZipFile) <> ""
        Kill StrZipFile
    Loop
    ' Restore error trapping
    On Error GoTo 0
    ' Get the temporary folder's file listing
    StrMediaFile = Dir(StrOutFold & "\*.*", vbNormal)
    Documents.Open FileName:=StrDocFile
    With ActiveDocument
        ' Process the temporary folder's files
        While StrMediaFile <> ""
            .Range.InsertAfter vbCr
            Set Rng = .Paragraphs.Last.Range
            .Fields.Add Range:=Rng, Type:=wdFieldEmpty, PreserveFormatting:=False, _
                Text:="INCLUDEPICTURE """ & Replace(StrOutFold & "\" & StrMediaFile, "\", "\\") & """ \d"
            ' Get the next media file
            StrMediaFile = Dir()
        Wend
        .Fields.Update
    End With
    Application.ScreenUpdating = True
End Sub

Answer 1

您还可以解析返回的 XML 以Document.Content.XML提取所有图像。然后使用外部图像的路径更新每个源，并使用 写回 XML Document.Content.InsertXML。

写回 XML 会自动添加一个链接字段，这似乎是您的要求之一。它比使用剪贴板更快，并且不会改变形状的样式。不过，您可能需要调整代码来处理特定情况。

Private Declare PtrSafe Function CryptStringToBinaryW Lib "Crypt32" (ByVal pszString As LongPtr, ByVal cchString As Long, ByVal dwFlags As Long, ByRef pbBinary As Byte, ByRef cbBinary As Long, ByVal pdwSkip As LongPtr, ByVal pdwFlags As LongPtr) As Boolean

Public Sub Example()
  SaveAslinkedImages ActiveDocument, "c:\temp\myfile-no-img.docx"
End Sub

Public Sub SaveAslinkedImages(Doc As Document, fname As String)
  Dim objXml As Object, binData As Object, binName$, nodes, node
  Dim imgPath$, docDir$, imgDir$, i&, data() As Byte

  Set objXml = VBA.CreateObject("Msxml2.DOMDocument.6.0")
  objXml.Async = False
  objXml.validateOnparse = False

  ' parse xml document '
  objXml.LoadXML Doc.Content.XML

  ' add namespaces for SelectNodes '
  objXml.setProperty "SelectionNamespaces", _
    objXml.DocumentElement.getAttributeNode("xmlns:w").XML & " " & _
    objXml.DocumentElement.getAttributeNode("xmlns:v").XML

  ' create the  media folder '
  docDir = Left(fname, InStrRev(fname, "\") - 1)
  imgDir = Left(fname, InStrRev(fname, ".") - 1) & "_media"
  MakeDir imgDir

  ' iterate each image data '
  For Each binData In objXml.SelectNodes("//w:binData")
    binName = binData.getAttribute("w:name")

    ' get all the nodes referencing the image data '
    Set nodes = objXml.SelectNodes("//v:imagedata[@src='" & binName & "']")

    If nodes.Length Then ' if any '
      ' build image path '
      imgPath = imgDir & "\" & Mid(binName, InStrRev(binName, "/") + 1)

      ' save base64 data to file '
      DecodeBase64 binData.Text, data
      SaveBytesAs data, imgPath

      ' remove the data '
      binData.ParentNode.RemoveChild binData

      ' for each image '
      For Each node In nodes
        ' set id '
        node.ParentNode.setAttribute "id", node.ParentNode.getAttribute("o:spid")

        ' remove o namespace '
        node.ParentNode.Removeattribute "o:spid"
        node.Removeattribute "o:title"

        ' set external image source '
        node.setAttribute "src", imgPath
      Next
    End If
  Next

  ' write back the xml and save the document '
  Doc.Content.InsertXML objXml.XML
  Doc.SaveAs2 fname

End Sub

Public Sub SaveBytesAs(data() As Byte, path As String)
  Open path For Binary Access Write As #5
  Put #5, 1, data
  Close #5
End Sub

Public Sub MakeDir(path As String)
  If Len(Dir(path, vbDirectory)) Then Exit Sub
  MakeDir Left(path, InStrRev(path, "\") - 1)
  MkDir path
End Sub

Public Function DecodeBase64(str As String, out() As Byte) As Boolean
  Dim size As Long
  size = ((Len(str) + 3) \ 4) * 3
  ReDim out(0 To size - 1) As Byte
  DecodeBase64 = CryptStringToBinaryW(StrPtr(str), Len(str), 1, out(0), size, 0, 0)
  If size - 1 < UBound(out) Then ReDim Preserve out(0 To size - 1)
End Function