将InlineShape图片保存到Word中的文件 VBA

Question

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.

Code

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.

Result

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).

Original	Result

• The result image has weird white borders. I don't know where they are coming from.
  I tried to understand by adding oInlineShape.Select in my code, only the image is selected...
• Its quality is very poor compared to the original image (this may not be visible in the uploaded pictures).
  I believe this is because I resized the image in Word.

Other possible method

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!!

Answer 1

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