I am trying to extract a picture from a Word document and save it in a file, using vba.
I don't really care about the output format, as long as it is readable.
The picture is in line with text and is therefore an InlineShape
in vba.
I have tried something using the ActiveX Data Object Library (ADODB), see code below.
Dim oInlineShape As InlineShape, _
ImageStream
Set oInlineShape = ActiveDocument.InlineShapes(1)
Set ImageStream = CreateObject("ADODB.Stream")
With ImageStream
.Type = 1
.Open
.Write oInlineShape.Range.EnhMetaFileBits
.savetofile ActiveDocument.Path & "\image.bmp"
.Close
End With
Set ImageStream = Nothing
There is no need to include the reference to the "ActiveX Data Object Library".
I have not specified ImageStream
's type to avoid having to do so.
I cannot read the image.bmp
file using the Windows Photos App, but I can insert it back into the Word document or convert the file to a jpg (I used ImageMagick but I don't think it matters).
oInlineShape.Select
in my code, only the image is selected...I read in old forum threads that the vba code can call functions from the Windows API and therefore can paste the clipboard contents to a file.
I know how to put a Shape or InlineShape in the Word clipboard. However, I do not know how to connect to the Windows API using vba and what function from it to use.
Many many thanks!!
I looked for 20 years but never found answer, until discovering WordXML.
You can test by calling: saveImage Selection.InlineShapes(1), "C:\tmp\test.png" Make sure there is a "tmp" directory on the C drive.
Private Sub saveImage(shp As InlineShape, path As String)
Dim s As String
Dim i As Long
Dim j As Long
Dim r As Range
Set r = shp.Range.Duplicate
r.start = r.start - 1
r.End = r.End + 1
''shp.range.WordOpenXML does not always contain the binary data
''s = shp.Range.WordOpenXML
s = r.WordOpenXML
i = InStr(s, "<pkg:binaryData>") + 16
If i = 16 Then
MsgBox "No binary data found"
Exit Sub
End If
j = InStr(i, s, "</pkg:binaryData>")
s = Mid$(s, i, j - i)
Dim DecodeBase64() As Byte
Dim objXML As Object 'MSXML2.DOMDocument
Dim objNode As Object 'MSXML2.IXMLDOMElement
Set objXML = CreateObject("MSXML2.DOMDocument")
'create node with type of base 64 and decode
Set objNode = objXML.createElement("b64")
objNode.DataType = "bin.base64"
objNode.Text = s
DecodeBase64 = objNode.nodeTypedValue
Set objNode = Nothing
Set objXML = Nothing
Open path For Binary As #1
Put #1, 1, DecodeBase64
Close #1
End Sub