|
|
Option Explicit
Sub test()
Dim strFileName$, strPath$, i&, k&, n&
Dim strRngText$, shp As Shape, inLineShp As InlineShape
Application.ScreenUpdating = False
strPath = ActiveDocument.Path & "\"
With ActiveDocument
For Each shp In .Shapes
If shp.Type = msoPicture Then shp.ConvertToInlineShape
Next
For i = 1 To .Tables.Count
With .Tables(i)
For k = 1 To .Rows.Count
n = 0
strRngText = Left(.Cell(k, 1).Range.Text, Len(.Cell(k, 1).Range.Text) - 2)
For Each inLineShp In .Cell(k, 2).Range.InlineShapes
n = n + 1
Call ToSaveImg(inLineShp, strPath & strRngText & n & "-.png")
Next
Next k
End With
Next i
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
|
评分
-
2
查看全部评分
-
|
楼主: witkeylaw
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2024-3-9 21:06
感谢
