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