將InlineShape圖片保存到Word中的文件 VBA

Question

我正在嘗試使用 vba 從 Word 文檔中提取圖片並將其保存在文件中。
我不太關心 output 格式，只要它是可讀的即可。

圖片與文字對齊，因此是vba中的一個InlineShape 。

我已經嘗試使用ActiveX Data Object Library (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 數據 Object 庫”的引用。
我沒有指定ImageStream的類型以避免必須這樣做。

結果

我無法使用 Windows 照片應用程序讀取image.bmp文件，但我可以將其重新插入到 Word 文檔中或將文件轉換為 jpg（我使用 ImageMagick，但我認為這無關緊要）。

原版的	結果

• 結果圖像有奇怪的白色邊框。 我不知道他們來自哪里。
  我試圖通過在我的代碼中添加oInlineShape.Select來理解，只選擇了圖像......
• 與原始圖像相比，它的質量很差（這在上傳的圖片中可能看不到）。
  我相信這是因為我在 Word 中調整了圖像的大小。

其他可能的方法

我在舊論壇帖子中讀到 vba 代碼可以調用 Windows API 中的函數，因此可以將剪貼板內容粘貼到文件中。

我知道如何將 Shape 或 InlineShape 放入 Word 剪貼板。 但是，我不知道如何使用 vba 連接到 Windows API 以及從中使用什么 function。

非常感謝！！

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