wdVBA保存图片到本地API

Posted 2020-09-27 Excel VBA 小天地

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
Public Sub SavePictures()
    Call ConvertShapeToInline
    Call SavePictureByApi
End Sub

Private Sub SavePictureByApi()
    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, N As Long
    N = 0


    ‘Documents.Open ("C:\Brildo\Test.docx")
    ReDim PicName(1 To 1) As String
    For Each inSh In ActiveDocument.InlineShapes
        ‘如果是shape，此处改为activedocument.Shapes，当然inSh的声明也要改

        N = N + 1
        ReDim Preserve PicName(1 To N)
        PicName(N) = FirstName & Format(N, "0000") & ".jpg"

        Debug.Print N

        FileName = ActiveDocument.Path & "\" & PicName(N)

        If Dir(FileName) <> "" Then Kill FileName

        inSh.Range.CopyAsPicture
        ‘如果为shape，CopyAsPicture方法无效，可能因为shape本身就是pic，
        ‘所以对于shape直接select，再copy，即以图片形式装入了粘贴板，
        ‘后续操作相同。
        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 inSh
End Sub
Private Sub ConvertShapeToInline()
    Dim shp As Shape
    Dim N As Long
    If ActiveDocument.Shapes.Count = 0 Then Exit Sub
    On Error Resume Next    ‘防止一些转化失败
    For Each shp In ActiveDocument.Shapes
        Debug.Print "正在转换"; N
        N = N + 1
        shp.ConvertToInlineShape
    Next shp
    On Error GoTo 0
End Sub