新解决方案

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

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

自动编写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

Answer 2

这是您的代码误入歧途的地方： -

With ActiveDocument
            .Range.InsertAfter vbCr
            Set Rng = .Paragraphs.Last.Range

您正在文档的末尾插入一个回车符（实际上插入一个新的空白段落），然后在该段落中添加一个字段。显然，你想把这个领域放在其他地方。

同时，如果您想删除链接，您应该让代码执行此操作。我无法弄清楚你的代码是否尝试了这个方向，但是假设它从链接中提取了图片的路径。因此，在放弃其路径后，应该找到并删除该链接，并将该字段插入其位置。

Answer 3

这是我的尝试。我确实假设文档中的形状是Inline Shape。我在计算机上用内联形状嘲笑了这个。

重要先决条件

我正在使用Scripting.FileSystemObject和Scripting.Dictionary的早期绑定。为了使代码无其他更改，请添加对Microsoft Scripting Runtime的引用。

工作原理

代码遍历所选文档中的每个形状，并将每个形状保存到本地文件夹。保存每个形状后，将删除形状。从这里，InlineShape的文件名（键）和范围（值）将保存到字典中。对每个形状完成此过程后，通过迭代字典来添加具有INCLUDEPICTURE详细信息的字段，以获取所需的值。

<强>代码

Option Explicit

Sub SOExample()
On Error GoTo Errhand:
    Application.ScreenUpdating = False

    Dim FileName        As String
    Dim doc             As Document
    Dim rng             As Range ' Used to keep track of where the shape was before being deleted
    Dim shp             As Word.InlineShape 'I think you want to iterate inline shapes which generally are pictures
    Dim i               As Long ' Counter
    Dim fso             As FileSystemObject ' used for File Operations/etc
    Dim tmpPics         As String: tmpPics = GetDesktop & "Temp Pics" 'default folder on the desktop for temp storage
    Dim picData()       As Byte ' To hold picture information
    Dim pos             As Variant
    Dim fileNumb        As Long

    'This section was untouched
    With Application.Dialogs(wdDialogFileOpen)
        If .Show = -1 Then
            .Update
            Set doc = ActiveDocument
        End If
    End With

    'Make sure we have an object to work with
    If doc Is Nothing Then Exit Sub

    'Get a reference to FSO
    Set fso = New FileSystemObject

    'Delete files or create folder where needed
    If fso.FolderExists(tmpPics) Then
        fso.DeleteFile (tmpPics & "\*"), True
    Else
        fso.CreateFolder tmpPics
    End If

    'Create a dictionary to store the file name and range
    'We need to do one pass through each image and save them, then delete the sheet
    'As we go we are going to add the filename into our dictionary as the key, and -
    'add the range of the remove image as the value. We use that range later to add the INCLUDEPICTURE portion
    Dim mydict As New Scripting.Dictionary: Set mydict = New Scripting.Dictionary

    'iterate each inlineShape...you may need to alter this as I'm unsure if this is the only type needed
    'To be extracted. Sections of code grabbed from:
    'https://stackoverflow.com/questions/6512392/how-to-save-word-shapes-to-image-using-vba
    For Each shp In doc.InlineShapes
        fileNumb = FreeFile
        i = i + 1

        'Build a temporary file name for our temp folder
        FileName = tmpPics & "\Image " & CStr(i) & ".emf"

        'Write the file as an EMF file
        Open FileName For Binary Access Write As fileNumb
        picData = shp.Range.EnhMetaFileBits
        pos = 1

        Put fileNumb, pos, picData
        Close fileNumb

        Set rng = shp.Range

        'Add the details to our dictionary for iteration later
        'I'm not adding the text here as, at least for me, adding this field adds another shape
        'On the next iteration, it was trying to apply the same steps...creating what I'm assuming is an inifinite loop
        If Not mydict.Exists(FileName) Then mydict.Add FileName, rng
        shp.Delete
        Set rng = Nothing
    Next

    Dim var As Variant

    'Go through our dictionary, and add the fields into our document
    For Each var In mydict.Keys
        doc.Fields.Add Range:=mydict(var), _
                       Text:="INCLUDEPICTURE """ & Replace(var, "\", "\\") & """ \d"
    Next


CleanExit:
    Application.ScreenUpdating = True
    Exit Sub

Errhand:
    Debug.Print Err.Number, Err.Description
    Select Case Err.Number
        'Add error handler here

    End Select

    Resume CleanExit

End Sub

'A small helper function to get a path to the desktop
Private Function GetDesktop() As String
    Dim oWSHShell As Object: Set oWSHShell = CreateObject("WScript.Shell")
    GetDesktop = oWSHShell.SpecialFolders("Desktop") & "\"
    Set oWSHShell = Nothing
End Function

Answer 4

通过查找每个图像并将链接放在其位置，此代码将实现您想要的效果。请注意，如果保存修改后的文档，原始文件将被覆盖。有关详细信息，请参阅代码中的注释。 代码现在也适用于重复项

Option Explicit
Const IMAGEBASENAME = "image"
Const IMAGEEXTENSION = ".jpeg" 'Images in .zip file are all .jpg

Sub MakeDocMediaLinked()
    Dim StrOutFold As String
    Dim Obj_App As Object
    Dim Doc As Document
    Dim Rng As Range
    Dim StrDocFile As String
    Dim StrZipFile As String
    Dim StrMediaFile As String
    Dim objShape As InlineShape
    Dim imgNum As Integer
    Dim imgCount As Integer
    Dim imgName As String
    Dim imgNames As New Collection
    Dim i As Integer
    Dim doDir As Boolean

    Application.ScreenUpdating = False
    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
        StrDocFile = .FullName    ' ID the document to process
        StrOutFold = Split(StrDocFile, ".")(0) & "_Media"
        .Close SaveChanges:=False
    End With
    If Dir(StrOutFold, vbDirectory) = "" Then MkDir StrOutFold    ' Test for existing output folder, create it if it doesn't already exist
    '*
    '* Delete any files in the output folder. On Error Resume Next not used
    '*
    If Dir(StrOutFold & "\*.*", vbNormal) <> "" Then 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
    Do While Dir(StrZipFile) <> ""     ' Delete the zip file - the loop takes care of timing issues
        Kill StrZipFile
    Loop
    StrMediaFile = Dir(StrOutFold & "\*.*", vbNormal)     ' Get the temporary folder's file listing
    Documents.Open FileName:=StrDocFile
    With ActiveDocument
        imgCount = .InlineShapes.Count
        For imgNum = 1 To imgCount
            '*
            '* Get the (next) image
            '*
            Set objShape = .InlineShapes(imgNum)
            '*
            '* Get the original full path of the image
            '*
            imgName = objShape.AlternativeText
            '*
            '* Look for possible duplicate
            '*
            '* Add the ordinal number as the item and the path as the key to avoid duplicates
            '* If we get an error here then the image is a duplicate of a previous one
            '* The ordinal number in imgNames identifies the image to use in the _Media folder
            '*
            i = imgNames.Count  'Current count
            doDir = True    ' Assume no duplicate
            On Error Resume Next
            imgNames.Add imgNum, imgName
            On Error GoTo 0    'Always reset error handling after Resume
            If i = imgNames.Count Then    'Duplicate found, build the duplicate's file name
                StrMediaFile = IMAGEBASENAME & imgNames(imgName) & IMAGEEXTENSION
                doDir = False    'Do not read a new file
            End If
            '*
            '* Get the range where we want the link to appear
            '*
            Set Rng = objShape.Range
            '*
            '* Delete the image from the document
            '*
            objShape.Delete
            '*
            '* Replace the image with a link to a saved disk image in the *_Media folder
            '*
            .Fields.Add Range:=Rng, Type:=wdFieldEmpty, PreserveFormatting:=False, _
                        Text:="INCLUDEPICTURE """ & Replace(StrOutFold & "\" & StrMediaFile, "\", "\\") & """ \d"
            If doDir Then StrMediaFile = Dir()    ' Get the next media file since we had no duplicate this time
        Next imgNum
        .Fields.Update
    End With
    Set imgNames = Nothing
    Application.ScreenUpdating = True
End Sub

Answer 5

一种方法是使用Selection.Copy将图像复制到剪贴板，然后将其另存为PNG。然后使用Document.InlineShapes.AddPicture的外部链接替换图像。

要处理重复的图像，请散列每个图像并跟踪计算的代码。我还会在之前重新缩放形状以保持原始分辨率。

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

Public Sub SaveAsExternImages(doc As Document, fname As String)
  Dim sh As InlineShape, rg As Range, docDir, imgDir, imgPath, imgHash
  Dim hDib, scaleW, scaleH, i As Long
  Dim imgPaths As New Collection
  Dim imgs As New Collection

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

  ' clean clipboard '
  Call OpenClipboard: Call EmptyClipboard: Call CloseClipboard

  ' select images '
  For Each sh In doc.InlineShapes
    Select Case sh.Type
      Case wdInlineShapeLinkedPicture, wdInlineShapePicture
        imgs.Add sh
    End Select
  Next

  ' handle each image '
  For Each sh In imgs

    ' store/reset the scale '
    scaleW = sh.ScaleWidth
    scaleH = sh.ScaleHeight
    sh.ScaleWidth = 100
    sh.ScaleHeight = 100

    ' copy shape to the clipboard '
    sh.Select
    doc.Application.Selection.Copy

    ' get clipboard as DIB (device independent bitmap) '
    If OpenClipboard() Then Else Err.Raise 9, , "OpenClipboard failed"
    hDib = GetClipboardData(8)  ' 8 = CF_DIB = BITMAPINFO '
    If hDib Then Else Err.Raise 9, , "GetClipboardData failed"

    ' get image hash code from DIB (CRC32) '
    imgHash = GetDIBHashCode(hDib)

    ' save as PNG if hash not already present in the collection '
    If TryGetValue(imgPaths, imgHash, imgPath) = False Then
      i = i + 1
      imgPath = SaveDIBtoPNG(hDib, imgDir & "\image" & i & ".png")
      imgPath = Mid(imgPath, Len(docDir) + 2) ' make relative '
      imgPaths.Add imgPath, CStr(imgHash)
    End If

    ' dispose clipboard '
    Call EmptyClipboard
    Call CloseClipboard

    ' replace the shape with a linked picture and restore the scale '
    Set rg = sh.Range
    sh.Delete
    doc.Application.ChangeFileOpenDirectory docDir ' set relative folder '
    Set sh = doc.InlineShapes.AddPicture(imgPath, True, False, rg)
    sh.ScaleWidth = scaleW
    sh.ScaleHeight = scaleH
  Next

  doc.SaveAs2 fname
End Sub

新解决方案

方法

对于每个InlineShape（反向工作），如果，则为wdInlineShapePicture

将其复制到临时文档
将临时文档另存为.docx
将临时文档复制为.zip文件
将*.zip/word/media文件夹的内容解压缩到临时文件夹
将该文件夹中的唯一文件移动并重命名为目标文件夹
删除形状
创建一个链接到新处理文件的字段，其形状曾是

代码

Option Explicit

Sub Example()

    MakeDocMediaLinked ActiveDocument

End Sub

Sub MakeDocMediaLinked(ByRef Doc As Document)

' iterate through each image

Dim i As Long
Dim shapeCollection As InlineShapes
Dim tempDoc As Document
Dim fso As New FileSystemObject  ' early binding; add a reference to Microsoft Scripting Runtime (scrrun.dll)
Dim oShell As New Shell32.Shell  ' early binding; add a reference to Microsoft Shell Controls and Automation (shell32.dll)
Dim currentMediaFileNameSource As String
Dim currentMediaFileNameNew As String
Dim shp As InlineShape
Dim rngToRemove As Range, rngToInsertInto As Range

Const tempDocFilePathDoc As String = "C:\test\temp.docx"
Const tempDocFilePathZip As String = "C:\test\temp.zip"
Const tempMediaFolderPath As String = "C:\test\temp\"
Const destMediaFolderPath As String = "C:\test\images\"

MakePath tempMediaFolderPath ' make the temporary folder in which to store an image, if it doesn't already exist
MakePath destMediaFolderPath ' make the images folder in which to store the images, if it doesn't already exist

Set tempDoc = Application.Documents.Add(Visible:=False) ' create the temp doc, hide it
tempDoc.SaveAs2 FileName:=tempDocFilePathDoc ' save the temp doc

Set shapeCollection = Doc.InlineShapes

For i = shapeCollection.Count To 1 Step -1 ' working backwards through the collection
    Set shp = shapeCollection(i)
    If shp.Type = wdInlineShapePicture Then
        tempDoc.Range.Delete ' clear the temp doc
        tempDoc.Range.FormattedText = shp.Range.FormattedText ' copy the image into the temp doc
        tempDoc.Save ' save the temp doc
        fso.CopyFile tempDocFilePathDoc, tempDocFilePathZip ' copy the temp doc and rename to a temp zip file (will overwrite existing zip)
        oShell.NameSpace(tempMediaFolderPath).CopyHere oShell.NameSpace(tempDocFilePathZip & "\word\media\").Items ' copy the one media file to a destination
        currentMediaFileNameSource = Dir(tempMediaFolderPath) ' get the name of the media file
        currentMediaFileNameNew = "media-" & i & Mid(currentMediaFileNameSource, InStrRev(currentMediaFileNameSource, ".")) ' names the files media-4.jpeg, media-3.png, etc.
        fso.CopyFile tempMediaFolderPath & currentMediaFileNameSource, destMediaFolderPath & currentMediaFileNameNew ' copy and rename the file into the destination folder
        fso.DeleteFile tempMediaFolderPath & currentMediaFileNameSource, True ' delete the temporary file
        Set rngToRemove = shp.Range ' set the range that we will be removing, i.e. the shape range
        Set rngToInsertInto = shp.Range ' set the range that we will be inserting the field into, i.e. the start of the shape range (1)
        rngToInsertInto.Collapse wdCollapseStart ' set the range that we will be inserting the field into, i.e. the start of the shape range (2)
        rngToRemove.Delete ' remove the shape
        Doc.Fields.Add Range:=rngToInsertInto, Type:=wdFieldEmpty, PreserveFormatting:=False, _
        Text:="INCLUDEPICTURE """ & Replace(destMediaFolderPath & currentMediaFileNameNew, "\", "\\") & """ \d" ' 4. add the field, we refer to destMediaFolderPath & currentMediaFileNameNew in the field definition
    End If
Next i

tempDoc.Close SaveChanges:=False ' close the temp doc

fso.DeleteFile tempDocFilePathZip, True ' delete the temporary zip
fso.DeleteFile tempDocFilePathDoc, True ' delete the temporary doc
fso.DeleteFolder Left(tempMediaFolderPath, Len(tempMediaFolderPath) - 1), True ' delete the temporary folder

Set fso = Nothing
Set oShell = Nothing

End Sub

Sub MakePath(ByVal tempPath As String)

Dim fso As New FileSystemObject

Dim path() As String
Dim path2() As String
Dim i As Long

Do While Right(tempPath, 1) = "\" ' remove any ending slashes
    tempPath = Left(tempPath, Len(tempPath) - 1)
Loop

path = Split(tempPath, "\")
ReDim path2(LBound(path) To UBound(path))

i = LBound(path)
path2(i) = path(i)
If Not fso.FolderExists(path2(i) & "\") Then Exit Sub ' if the drive doesn't even exist, then exit
For i = LBound(path) + 1 To UBound(path)
    path2(i) = path2(i - 1) & "\" & CleanPath(path(i))
    If Not fso.FolderExists(path2(i) & "\") Then fso.CreateFolder path2(i)
Next i

Set fso = Nothing

End Sub

Function CleanPath(ByVal tempPath As String)

Dim i As Long
Dim invalidChars As Variant

invalidChars = Array("/", ":", "*", "?", """", "<", ">", "|")

For i = LBound(invalidChars) To UBound(invalidChars)
    tempPath = Replace(tempPath, invalidChars(i), " ")
Next i

CleanPath = tempPath

End Function

后

图像文件夹

文件（显示字段）

Answer 7

约翰，又一次尝试。运行测试文档和我的文档也可以。

使代码2通过。我发现有时原始.jpg文件将保存为.zip文件中的.jpeg文件有时.png文件也会以.jpeg的形式保存在.zip文件中。我没有努力找出原因。相反，我修改了我的代码以应对这一事实。这是处理任意数量重复的结果。

'********************************************************************
'* Replace original images with links to locally extracted images
'* Ver. 1.02 2017-10-04 peakpeak
'*
Option Explicit
Const IMAGEBASENAME = "image"
Const JPEG = "jpeg"
Const JPG = "jpg"
Sub MakeDocMediaLinked()
    Dim Doc As Document
    Dim Rng As Range
    Dim StrOutFold As String
    Dim StrDocFile As String
    Dim StrZipFile As String
    Dim imgName As String
    Dim StrMediaFile As String
    Dim imgNum As Integer
    Dim imgCount As Integer
    Dim i As Integer
    Dim ordinalNum As Integer
    Dim imgOrdinals As New Collection
    Dim objShape As InlineShape
    Dim Obj_App As Object

    Application.ScreenUpdating = False
    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
        StrDocFile = .FullName    ' ID the document to process
        StrOutFold = Split(StrDocFile, ".")(0) & "_Media"
        .Close SaveChanges:=False
    End With
    If Dir(StrOutFold, vbDirectory) = "" Then MkDir StrOutFold    ' Test for existing output folder, create it if it doesn't already exist
    '*
    '* Delete any files in the output folder. On Error Resume Next not used
    '*
    If Dir(StrOutFold & "\*.*", vbNormal) <> "" Then 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
    Do While Dir(StrZipFile) <> ""     ' Delete the zip file - the loop takes care of timing issues
        Kill StrZipFile
    Loop
    StrMediaFile = Dir(StrOutFold & "\*.*", vbNormal)     ' Get the temporary folder's file listing
    Documents.Open FileName:=StrDocFile
    With ActiveDocument
        imgCount = .InlineShapes.Count
        '*
        '* Pass 1, collect ordinal numbers for all unique images
        '*
        ordinalNum = 1
        For imgNum = 1 To imgCount
            Set objShape = .InlineShapes(imgNum)
            imgName = objShape.AlternativeText  'Contains the full path to the original inserted image
            i = imgOrdinals.Count               'Current count of image ordinals
            On Error Resume Next
            imgOrdinals.Add ordinalNum, imgName    'Error if duplicate
            On Error GoTo 0                 'Always reset error handling after Resume
            If i <> imgOrdinals.Count Then ordinalNum = ordinalNum + 1 'Ordinal added
        Next imgNum
        '*
        '* Pass 2, replace images with links
        '*
        For imgNum = 1 To imgCount
            '*
            '* Get the (next) image
            '*
            Set objShape = .InlineShapes(imgNum)
            '*
            '* Get the original full path of the image
            '*
            imgName = objShape.AlternativeText  'Contains the full path to the original inserted image
            '*
            '* Original extension and extension in the .zip file might differ due to internal algorithms in Word
            '* Get the image file name in *_Media folder based on its ordinal number and regardless of original extension
            '*
            StrMediaFile = Dir(StrOutFold & "\" & IMAGEBASENAME & imgOrdinals(imgName) & ".*", vbNormal)
            '*
            '* Get the range where we want the link to appear
            '*
            Set Rng = objShape.Range
            '*
            '* Delete the image from the document
            '*
            objShape.Delete
            '*
            '* Replace the image with a link to a saved disk image in the *_Media folder
            '*
            .Fields.Add Range:=Rng, Type:=wdFieldEmpty, PreserveFormatting:=False, _
                        Text:="INCLUDEPICTURE """ & Replace(StrOutFold & "\" & StrMediaFile, "\", "\\") & """ \d"
        Next imgNum
        .Fields.Update
    End With
    Set imgOrdinals = Nothing
    Application.ScreenUpdating = True
End Sub

将嵌入图像转换为链接

7 个答案:

新解决方案

方法

代码

后

图像文件夹

文件（显示字段）