ChatGPT搞砸了~，如何使用VBA导出Word文档中的图片

今年大火的ChatGPT似乎无所不能，但是它的确不是万能的，咱们来试试。

提供的代码根本无法运行，继续问，换了个代码，非常不幸的是–还是不能用。

Word VBA中并没有内置的方法可以直接导出图片，ChatGPT没有正确的答案也是可以理解的。

示例代码如下。

Sub ExportInlineShps()
    Dim i As Integer
    Dim iShpCnt As Integer
    Dim arrScale()
    With ActiveDocument
        iShpCnt = .InlineShapes.Count
        If iShpCnt > 0 Then
            ReDim arrScale(1 To 2, 1 To iShpCnt)
            For i = 1 To iShpCnt
                With .InlineShapes(i)
                    arrScale(1, i) = .ScaleHeight
                    arrScale(2, i) = .ScaleWidth
                    .ScaleHeight = 0.1
                    .ScaleWidth = 0.1
                End With
            Next
            For i = 1 To iShpCnt
                sSaveImg .InlineShapes(i), .Path & "\" & i & ".png"
            Next
            For i = 1 To iShpCnt
                With .InlineShapes(i)
                    .ScaleHeight = arrScale(1, i)
                    .ScaleWidth = arrScale(2, i)
                End With
            Next
        Else
            MsgBox "文档中没有图片"
        End If
    End With
End Sub

【代码解析】
第6行代码获取活动文档中图片对象（InlineShape）的个数。
第7行代码判断是否存在图片对象，如果不存在图片，第27行代码将显示提示消息框。
第8行代码重新声明数组arrScale用于保存图片对象的缩放比例。
第9~16行代码将图片对象的缩放比例保存在数组arrScale中，并设置图片对象的缩放比例为0.1。

注意：Word文档中的图片较多时，部分图片对象的.Range.WordOpenXML属性返回值中缺少Base64格式的图片内容（如果路过的高手知道其原因，请留言赐教。），导致无法导出图片。根据目前测试，减小文档图片显示尺寸，可以解决图片无法导出的问题，并且不影响导出图片的分辨率。

第17~19行代码调用sSaveImg过程导出图片对象。
第20~25行代码恢复图片显示比例。

Sub sSaveImg(ByVal objShp As InlineShape, ByVal strFullPath As String)
    Const TAG_S = "<pkg:binaryData>"
    Const TAG_E = "</pkg:binaryData>"
    Dim objNode As Object 'MSXML2.IXMLDOMElement
    Dim lngStart As Long, lngEnd As Long
    Dim bytImage() As Byte
    Dim strXML As String
    Dim rngShp As Range
    strXML = objShp.Range.WordOpenXML
    lngStart = InStr(strXML, TAG_S)
    If lngStart = 0 Then
        MsgBox "无法定位图片数据"
        Exit Sub
    Else
        lngStart = lngStart + Len(TAG_S)
        lngEnd = InStr(lngStart, strXML, TAG_E)
        strXML = Mid$(strXML, lngStart, lngEnd - lngStart)
        Set objNode = CreateObject("MSXML2.DOMDocument").createElement("b64")
        objNode.DataType = "bin.base64"
        objNode.Text = strXML
        bytImage = objNode.nodeTypedValue
        Open strFullPath For Binary As #1
        Put #1, 1, bytImage
        Close #1
        Set objNode = Nothing
    End If
End Sub

【代码解析】
第一个参数为InlineShape，即Word中的图片，第二个图片是图片文件的全路径。
第2~3行代码定义图片对象XML起始标签和结束标签。
第9行代码获取图片对象的XML代码。
第10行代码查找XML起始标签。
如果无法定位XML起始标签，第12行代码将显示提示消息框。
如果成功定位XML起始标签，第13行代码将获取图片对象（Base64编码）的起始位置。
第16行代码查找XML结束标签。
第17行代码提取图片对象（Base64编码）的XML代码。
第18行代码创建MSXML2.DOMDocument对象，并增加一个节点。
第19行代码设置数据类型为bin.base64。
第20行代码将图片对象（Base64编码）的XML代码赋值给节点。
第21行代码读取结点的nodeTypedValue属性，并保存在Byte数组中。
第22~24行代码将图片对象保存为硬盘文件。
第25行代码释放对象变量占用的系统资源。