zoukankan      html  css  js  c++  java
  • 20170706wdVBA保存图片到本地API

    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:BrildoTest.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
    

      

  • 相关阅读:
    基于Centos 7 vue+nginx+docker 的前端项目部署
    uni-app学习随笔
    微服务和Docker
    Ado.Net
    数据库(SQLServer)
    JavaScript
    CSS样式
    HTML前端标签
    vue中 拖动元素边框 改变元素宽度
    vue学习笔记14
  • 原文地址:https://www.cnblogs.com/nextseven/p/7129072.html
Copyright © 2011-2022 走看看