|
|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
Option Explicit
Sub test()
Dim strFileName$, strPath$, ar(), r&, i&, n&, strRngText$, shp
Application.ScreenUpdating = False
strPath = ActiveDocument.Path & "\图片\"
If Dir(strPath, vbDirectory) = "" Then MkDir strPath
With ActiveDocument
For Each shp In .Shapes
If shp.Type = msoPicture Then
r = r + 1
ReDim Preserve ar(1 To r)
ar(r) = shp.Name
End If
Next
For i = 1 To UBound(ar)
.Shapes(ar(i)).ConvertToInlineShape
Next i
For Each shp In .InlineShapes
shp.Select
If Selection.Information(wdWithInTable) = True Then
With Selection
.Collapse
n = ActiveDocument.Range(0, .End).Tables.Count
strRngText = ActiveDocument.Tables(n).Range.Cells(1).Range.Text
strRngText = Left(strRngText, Len(strRngText) - 2)
ToSaveImg shp, strPath & strRngText & ".png"
End With
End If
Next
End With
Application.ScreenUpdating = True
Beep
End Sub
Function ToSaveImg(ByVal objShp As InlineShape, ByVal strFullPath As String)
Const TAG_S = "<pkg:binaryData>"
Const TAGE = "</pkg:binaryData>"
Dim objNode As Object, IngStart&, IngEnd&, bytImage() As Byte, strXML$, rngShp As Range
strXML = objShp.Range.WordOpenXML
IngStart = InStr(strXML, TAG_S)
If IngStart = 0 Then
MsgBox "没有图片数据"
Exit Function
Else
IngStart = IngStart + Len(TAG_S)
IngEnd = InStr(IngStart, strXML, TAGE)
strXML = Mid$(strXML, IngStart, IngEnd - IngStart)
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 Function
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2024-7-1 15:56
楼主
