将 InlineShape 图片保存到 Word 文件 VBA

Question

我正在尝试从 Word 文档中提取图片并将其保存在文件中，使用 vba。
我不太关心输出格式，只要它是可读的即可。

图片与文字一致，因此是vba中的InlineShape。

我已经尝试使用 ActiveX 数据对象库 (ADODB)，请参阅下面的代码。

代码

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

无需包含对“ActiveX 数据对象库”的引用。
我没有指定 ImageStream 的类型以避免必须这样做。

结果

我无法使用 Windows 照片应用程序读取 image.bmp 文件，但我可以将其重新插入到 Word 文档中或将文件转换为 jpg（我使用了 ImageMagick，但我没有认为这不重要）。

原始	结果

结果图像有奇怪的白色边框。我不知道他们来自哪里。
我试图通过在我的代码中添加 oInlineShape.Select 来理解，只选择了图像...
与原始图片相比，它的质量很差（这在上传的图片中可能看不到）。
我相信这是因为我在 Word 中调整了图像的大小。

其他可能的方法

我在旧论坛帖子中读到 vba 代码可以从 Windows API 调用函数，因此可以将剪贴板内容粘贴到文件中。

我知道如何将 Shape 或 InlineShape 放入 Word 剪贴板。但是，我不知道如何使用 vba 连接到 Windows API 以及使用它的什么功能。

非常感谢！！

Answer 1

我找了 20 年但从未找到答案，直到发现 WordXML。

你可以通过调用来测试：saveImage Selection.InlineShapes(1), "C:\tmp\test.png" 确保C盘有“tmp”目录。

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

将 InlineShape 图片保存到 Word 文件 VBA

Save InlineShape picture to file in Word VBA

vba

ms-word

代码

结果

其他可能的方法