如何导出图片并自动命名

gwjkkkkk

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
   

gwjkkkkk

bluesky_0 发表于 2024-3-9 18:32
跪求大神,
在32位OK,在64位报错,
我研究,改了二周,没有搞定,

请参考。。。

bluesky_0

gwjkkkkk 发表于 2024-3-9 21:07
请参考。。。

感谢

wdpfox

gwjkkkkk 发表于 2024-3-9 21:06
Option Explicit
Sub test()
    Dim strFileName$, strPath$, i&, k&, n&

如何改为提取文档中的图片？不是表格中的。

gwjkkkkk

简单修改一下即可。。。

gwjkkkkk

wdpfox 发表于 2024-3-10 22:30
如何改为提取文档中的图片？不是表格中的。

请参考附件。。。

wdpfox

gwjkkkkk 发表于 2024-3-11 19:17
请参考附件。。。

文件中有3张图片，只能导出2张，到最后一张，跳出提示“没有图片数据”，请老师看看是哪里的问题。谢谢！
当春寒料峭的时候.rar (52.93 KB, 下载次数: 6)

2024-3-12 14:15 上传

点击文件名下载附件

dongdonggege

gwjkkkkk 发表于 2024-3-11 19:17
请参考附件。。。

运行时，我的出现这样的图，文件名是“猫1-.png”，文件名不合法，然后就运行不下去了。什么原因？

dongdonggege

gwjkkkkk 发表于 2024-3-11 19:17
请参考附件。。。

文件好像没有保存，所以找不到这个文件。

gwjkkkkk

wdpfox 发表于 2024-3-12 14:02
文件中有3张图片，只能导出2张，到最后一张，跳出提示“没有图片数据”，请老师看看是哪里的问题。谢谢！ ...

我测试没有问题。。。