今年大火的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行代码释放对象变量占用的系统资源。