objetos - vba word object model

Convertir imágenes incrustadas en vinculadas

Question

Estoy tratando de arreglar la macro, que se muestra a continuación.

Está destinado a convertir imágenes incrustadas en vinculadas (a través de IncludePicture). Sin embargo, en su estado actual, las imágenes se agregan en la parte inferior del documento. Obviamente, está lejos de ser perfecto. En cambio, macro debería reemplazar las imágenes incrustadas con las vinculadas, una por una, como se muestra aquí:

¿Como arreglarlo?

Además, tenga en cuenta: Macro debe iniciarse desde otro archivo. Entonces, necesita dos documentos: uno con macro y otro con imágenes. No es bueno, pero así es como funciona actualmente.

Código:

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

Aquí es donde su código se extravía:

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

Está insertando un retorno de carro al final del documento (que en realidad inserta un nuevo párrafo en blanco) y luego agrega un campo en ese párrafo. Obviamente, quieres el campo en otro lugar.

Mientras tanto, si desea eliminar los enlaces, debe dejar que su código lo haga. No he podido averiguar si su código hace un intento en esa dirección, pero supongo que extrae la ruta de la imagen del enlace. Entonces, el enlace debe ubicarse y eliminarse después de abandonar su ruta, y el campo insertado en su lugar.

Answer 2

Aquí está mi intento. Supuse que las formas en el documento serían una Inline Shape . Me burlé de esto en mi computadora con formas en línea.

Prerrequisitos importantes

Estoy utilizando el enlace anticipado de Scripting.FileSystemObject y Scripting.Dictionary . Para que esto funcione sin otros cambios en el código, agregue una referencia al Microsoft Scripting Runtime.

Cómo funciona

El código itera a través de cada forma en el documento elegido y guarda cada forma en una carpeta local. Una vez que se guarda cada forma, la forma se elimina. Desde aquí, el nombre de archivo (clave) y el rango (valor) de InlineShape se guardan en un diccionario. Después de que se haya realizado este proceso para cada forma, el campo con los detalles INCLUDEPICTURE se agrega al iterar a través del diccionario para obtener los valores necesarios.

Código

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://.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 3

Una forma sería copiar la imagen en el portapapeles con Selection.Copy y guardarla como PNG desde allí. Luego reemplace la imagen con un enlace externo con Document.InlineShapes.AddPicture .

Para manejar las imágenes duplicadas, controle cada imagen y realice un seguimiento del código calculado. También reescalaré la forma antes y después para mantener la resolución original.

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

Funciones / procedimientos relacionados:

Private Declare PtrSafe Function CLSIDFromString Lib "ole32" (ByVal lpsz As LongPtr, pclsid As Byte) As Long
Private Declare PtrSafe Function RtlComputeCrc32 Lib "ntdll" (ByVal start As Long, ByRef data As Any, ByVal Size As Long) As Long
Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As Boolean
Private Declare PtrSafe Function GlobalSize Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function OpenClipboard Lib "user32" (Optional ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As LongPtr
Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function GdiplusStartup Lib "gdiplus" (token As LongPtr, cfg As Any, ByVal hook As LongPtr) As Long
Private Declare PtrSafe Function GdiplusShutdown Lib "gdiplus" (ByVal token As LongPtr) As Long
Private Declare PtrSafe Function GdipCreateBitmapFromGdiDib Lib "gdiplus" (ByVal hdr As LongPtr, ByVal data As LongPtr, img As LongPtr) As Long
Private Declare PtrSafe Function GdipSaveImageToFile Lib "gdiplus" (ByVal img As LongPtr, ByVal path As LongPtr, riid As Byte, ByVal cfg As LongPtr) As Long
Private Declare PtrSafe Function GdipDisposeImage Lib "gdiplus" (ByVal img As LongPtr) As Long
Private Function GetDIBHashCode(hDib) As Long
Dim pDib As LongPtr, bmSize As Long, sz As Long
pDib = GlobalLock(hDib)
If pDib Then Else Err.Raise 9, , "GlobalLock failed"
GetDIBHashCode = RtlComputeCrc32(0, ByVal pDib, GlobalSize(hDib))
GlobalUnlock hDib
End Function
Private Function SaveDIBtoPNG(hDib, filePath As String) As String
Dim cfg(0 To 7) As Long, clsid(0 To 15) As Byte, pDib As LongPtr, hGdi As LongPtr, hImg As LongPtr
CLSIDFromString StrPtr("{557CF406-1A04-11D3-9A73-0000F81EF32E}"), clsid(0) '' PNG encoder ''
cfg(0) = 1& '' GdiplusVersion ''
pDib = GlobalLock(hDib) '' lock BITMAPINFOHEADER + image bytes ''
If pDib Then Else Err.Raise 9, , "GlobalLock failed"
If GdiplusStartup(hGdi, cfg(0), 0) Then Err.Raise 9, , "GdiplusStartup failed"
If GdipCreateBitmapFromGdiDib(pDib, pDib + 40, hImg) Then Err.Raise 9, , "GdipCreateBitmapFromGdiDib failed"
If GdipSaveImageToFile(hImg, StrPtr(filePath), clsid(0), 0) Then Err.Raise 9, , "GdipSaveImageToFile failed"
If GdipDisposeImage(hImg) Then Err.Raise 9, , "GdipDisposeImage failed"
If GdiplusShutdown(hGdi) Then Err.Raise 9, , "GdiplusShutdown failed"
GlobalUnlock hDib
SaveDIBtoPNG = filePath
End Function
Private Function TryGetValue(obj As Collection, Key, outValue) As Boolean
On Error Resume Next
outValue = obj.Item(CStr(Key))
TryGetValue = Err.Number = 0
End Function
Private Sub MakeDir(path)
If Len(Dir(path, vbDirectory)) = False Then
MkDir path
ElseIf Len(Dir(path & "/")) Then
Kill path & "/*"
End If
End Sub

Answer 4

Al ubicar cada imagen y colocar el enlace en su posición, este código logrará lo que desea. Tenga en cuenta que el archivo original se sobrescribirá si guarda el documento modificado. Ver mis comentarios en el código para más información. El código ahora también funciona para duplicados

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

También puede analizar el XML devuelto por Document.Content.XML para extraer todas las imágenes. Luego actualice cada fuente con la ruta de la imagen externa y vuelva a escribir el XML con Document.Content.InsertXML .

Escribir de nuevo el XML agrega automáticamente un campo vinculado que parece ser uno de sus requisitos. Es más rápido trabajar con el portapapeles y no altera el estilo de la forma. Sin embargo, es posible que deba modificar el código para manejar casos específicos.

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 6

John, otro intento más. Funciona bien con su documento de prueba y mis documentos también.

Hizo pasar el código 2 Descubrí que a veces los archivos .jpg originales se guardan como archivos .jpeg en el archivo .zip. También a veces los archivos .png se guardan en el archivo .zip como .jpeg. No puse ningún esfuerzo en descubrir por qué. En cambio, modifiqué mi código para hacer frente a este hecho. Aquí está el resultado que manejará cualquier cantidad de duplicados.

''********************************************************************
''* 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

Answer 7

Nueva solución

Método

Para cada InlineShape (trabajando en reversa), si es una wdInlineShapePicture

1. Cópialo en un documento temporal
2. Guarde el documento temporal como .docx
3. Copie el documento temporal como un archivo .zip
4. Extraiga el contenido de la carpeta *.zip/word/media en una carpeta temporal
5. Mueva y cambie el nombre del único archivo en esa carpeta a la carpeta de destino
6. Eliminar la forma
7. Cree un campo que enlace al archivo recién procesado, donde solía estar la forma

Código

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

Después

carpeta de imágenes

documento (que muestra los campos)