WOED中按标题拆分图片，并将图片另存，以标题命名

40525299999

这个问题困扰了很久了，不知道有没有办法实现，望大神指点
按标题拆分图片.rar (1.03 MB, 下载次数: 13)

2019-3-9 14:49 上传

点击文件名下载附件

word结构如下，每个标题下面有若干图片

最终输出为每个图片单独保存，并以所在标题命名，重复的自动加序号

duquancai

办法是有的，用WordVBA代码实现。只指路，不爬山。

daibao88

用WordVBA代码实现

40525299999

有偿，请加QQ10086501

182197315

Private Type GUID
   Data1 As Long
   Data2 As Integer
   Data3 As Integer
   Data4(0 To 7) As Byte
End Type
Private Type GdiplusStartupInput
   GdiplusVersion As Long
   DebugEventCallback As Long
   SuppressBackgroundThread As Long
   SuppresexternalCodecs As Long
End Type
Private Type EncoderParameter
   GUID As GUID
   NumberOfValues As Long
   type As Long
   Value As Long
End Type
Private Type EncoderParameters
   Count As Long
   Parameter As EncoderParameter
End Type
Private Declare Function GdiplusStartup Lib "GDIPlus" (token As Long, inputbuf As GdiplusStartupInput, ByVal outputbuf As Long) As Long
Private Declare Function GdiplusShutdown Lib "GDIPlus" (ByVal token As Long) As Long
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "GDIPlus" (ByVal hbm As Long, ByVal hpal As Long, Bitmap As Long) As Long
Private Declare Function GdipDisposeImage Lib "GDIPlus" (ByVal Image As Long) As Long
Private Declare Function GdipSaveImageToFile Lib "GDIPlus" (ByVal Image As Long, ByVal FileName As Long, clsidEncoder As GUID, encoderParams As Any) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal str As Long, id As GUID) As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Const CF_BITMAP = 2
Sub 标题()
Dim tSI As GdiplusStartupInput
Dim lRes As Long
Dim lGDIP As Long
Dim lBitmap As Long
Dim hBitmap As Long
Dim FileName As String
Dim inSh As InlineShape
Dim i%, k%, j%, n%, Tit(), Pos(), myPath$
Dim aDoc As Document, myRange As Range, aRange As Range
Set aDoc = ActiveDocument
myPath = ActiveDocument.Path & "\"
GN:
If myRange Is Nothing Then
    Set myRange = aDoc.Content
Else
    Set myRange = aDoc.Range(myRange.End, aDoc.Content.End)
End If
With myRange.Find
    .ClearFormatting
    .Forward = True
    .Font.Bold = True
    .Format = True
    Do While .Execute
        k = k + 1
        ReDim Preserve Tit(1 To k)
        ReDim Preserve Pos(1 To k)
        Tit(k) = Replace(myRange.Text, Chr(13), "")
        Pos(k) = myRange.End
        GoTo GN
    Loop
End With
For i = 1 To UBound(Pos)
    If i < UBound(Pos) Then
        Set aRange = aDoc.Range(Pos(i), Pos(i + 1))
    Else
        Set aRange = aDoc.Range(Pos(i), aDoc.Content.End)
    End If
    n = aRange.InlineShapes.Count
'    j = 0
    For Each inSh In aRange.InlineShapes
        j = j + 1
        FileName = ThisDocument.Path & "\" & Tit(i) & "_" & j & ".jpg"
        inSh.Range.CopyAsPicture
        OpenClipboard 0&
        hBitmap = GetClipboardData(CF_BITMAP)
        CloseClipboard
        tSI.GdiplusVersion = 1
        lRes = GdiplusStartup(lGDIP, tSI, 0)
        If lRes = 0 Then
             lRes = GdipCreateBitmapFromHBITMAP(hBitmap, 0, lBitmap)
            If lRes = 0 Then
                Dim tJpgEncoder As GUID
                Dim tParams As EncoderParameters
                CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
                tParams.Count = 1
                With tParams.Parameter
                    CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .GUID
                    .NumberOfValues = 1
                    .type = 4
                    .Value = VarPtr(100)
                End With
                lRes = GdipSaveImageToFile(lBitmap, StrPtr(FileName), tJpgEncoder, tParams)
                GdipDisposeImage lBitmap
            End If
            GdiplusShutdown lGDIP
        End If
    Next
Next
Set aDoc = Nothing
End Sub