将嵌入图像转换为链接

您还可以解析返回的XMLDocument.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