提取图片重命名

xiangheping

求大神写vba代码，提取word里的图片，并根据图片下方格内的内容重命名，放到图片88文件夹中，提取的图片图片不要变小

gwjkkkkk

Option Explicit
Sub test()
    Dim strFileName$, strSavePath$, strPath$, inLineShp As InlineShape
   
    Application.ScreenUpdating = False
   
    strPath = ActiveDocument.Path & "\"
    strSavePath = strPath & "图片88\"
    If Dir(strSavePath, vbDirectory) = "" Then MkDir strSavePath
   
    With ActiveDocument
        For Each inLineShp In .InlineShapes
            inLineShp.Select
            With Selection
                .Collapse
                .MoveDown unit:=wdLine
                .MoveEndUntil vbCr
                strFileName = .Range.Text
                ToSaveImg inLineShp, strSavePath & strFileName & ".png"
            End With
        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

gwjkkkkk

请参考。。。

xiangheping

gwjkkkkk 发表于 2024-5-28 19:57
请参考。。。

感谢大佬，没成功，只提取到最后一张图片，没命名

xiangheping

gwjkkkkk 发表于 2024-5-28 19:57
请参考。。。

开始用wps打开的，又用word试了下，可以保存，但最后那张图片没命名，就是天空那张

xiangheping

gwjkkkkk 发表于 2024-5-28 19:55
Option Explicit
Sub test()
    Dim strFileName$, strSavePath$, strPath$, inLineShp As InlineShap ...

然后还有重命名的字数多了没显示完，后面的全显示了，前面的没显示，图片多了也没提取完

zhanglei1371

xiangheping 发表于 2024-5-28 21:02
然后还有重命名的字数多了没显示完，后面的全显示了，前面的没显示，图片多了也没提取完

你用简单测试文档的代码用在实际复杂文档上，不出错才怪。
所以你应该提供最复杂的实际文档才对，而非简单的测试文档。

gwjkkkkk

xiangheping 发表于 2024-5-28 21:02
然后还有重命名的字数多了没显示完，后面的全显示了，前面的没显示，图片多了也没提取完

发个复杂的文档上来看看，我是根据你的提供的文档写的，没问题。。。

xiangheping

gwjkkkkk 发表于 2024-5-28 22:10
发个复杂的文档上来看看，我是根据你的提供的文档写的，没问题。。。

经过反复测试，发现大部分功能正常，只是还有点小问题，就是图片到了第2页就没法提取了，只能提取到第1页的，麻烦大佬有空帮忙修改下

gwjkkkkk

xiangheping 发表于 2024-5-29 06:31
经过反复测试，发现大部分功能正常，只是还有点小问题，就是图片到了第2页就没法提取了，只能提取到第1页 ...

再发个附件吧，我看下问题在哪里，凭空想象不出。。。