VBA 全自动使用DLL 的各种封装方法 - 完全公开源码和方法（如用VSTO就什么都不用学）

gumption83

收藏学习，慢慢消化

YDH318

Option Explicit
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Private Const CF_BITMAP = 2 '对应 Format:=xlBitmap  xlBitmap 对应 Bitmap (.bmp, .jpg, .gif).
Private Const CF_ENHMETAFILE = 14 '对应 Format:=xlPicture  xlPicture 对应 Drawn picture (.png, .wmf, .mix).  '来源 https://msdn.microsoft.com/en-us/library/microsoft.office.interop.excel.xlcopypictureformat.aspx

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
SuppressExternalCodecs 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 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 GdipCreateBitmapFromHBITMAP Lib "GDIPlus" (ByVal hbm As Long, ByVal hPal As Long, BITMAP As Long) As Long

Public Function ClipBitMaptoJPG(ByVal destfilename As String, Optional ByVal quality As Integer = 80) As Integer
'*****该函数用于取出剪贴板中图片转换为jpg文件另存到指定路径****
'参数说明：
'     destfilename:要保存的jpg文件的完整路径，必要参数；
'     quality: jpg文件的质量，0-100之间的数值，数值越大，图片质量越高
'返回值：
'     0-保存成功；1-保存失败；2-剪贴板中无位图数据；3-无法打开剪贴板

    Dim tSI As GdiplusStartupInput
    Dim lRes As Long
    Dim lGDIP As Long
    Dim lBitmap As Long
    Dim hBmp As Long
   
    '尝试打开剪贴板
    If OpenClipboard(0) Then
        '尝试取出剪贴板中位图的句柄
        hBmp = GetClipboardData(CF_BITMAP)
        '如果hBmp为0，说明剪贴板中没有存放图片
        If hBmp = 0 Then
            ClipBitMaptoJPG = 2
            CloseClipboard
            Exit Function
        End If
        CloseClipboard
    Else   '如果openclipboard返回0(False)，说明剪贴板被其他程序所占用
        ClipBitMaptoJPG = 3
        Exit Function
    End If
   
    '初始化 GDI+
    tSI.GdiplusVersion = 1
    lRes = GdiplusStartup(lGDIP, tSI, 0)
     
    If lRes = 0 Then
        '从句柄创建 GDI+ 图像
        lRes = GdipCreateBitmapFromHBITMAP(hBmp, 0, lBitmap)
         
        If lRes = 0 Then
            Dim tJpgEncoder As GUID
            Dim tParams As EncoderParameters
            
            '初始化解码器的GUID标识
            CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
            
            '设置解码器参数
            tParams.Count = 1
            With tParams.Parameter ' Quality
                '得到Quality参数的GUID标识
                CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .GUID
                .NumberOfValues = 1
                .type = 4
                .Value = VarPtr(CByte(quality)) '此处原始quality 参数为byte类型
            End With
            
            '保存图像
            lRes = GdipSaveImageToFile(lBitmap, StrPtr(destfilename), tJpgEncoder, tParams)
            If lRes = 0 Then
                ClipBitMaptoJPG = 0  '转换成功
            Else
                ClipBitMaptoJPG = 1  '转换失败
            End If
            
            '销毁GDI+图像
            GdipDisposeImage lBitmap
        End If
         
        '销毁 GDI+
        GdiplusShutdown lGDIP
    End If
End Function

Sub test_ClipBitMaptoJPG()
    Range("A1:K100").CopyPicture Appearance:=xlScreen, Format:=xlBitmap
    Select Case ClipBitMaptoJPG("C:\211.jpg")
        Case 0:
            MsgBox "剪贴板图片已保存"
        Case 1:
            MsgBox "剪贴板图片保存失败"
        Case 2:
            MsgBox "剪贴板中无图片"
        Case 3:
            MsgBox "剪贴板无法打开，可能被其他程序所占用"
    End Select
End Sub


能将此代码用VB6.0封装在DLL不，50元酬谢

YDH318

其它的代码 剪贴板图片文件压缩保存代码已通过VB6.0封装成DLL
中余下这一句封装不进行
Range("A1:K23").CopyPicture Appearance:=xlScreen, Format:=xlBitmap
求大祸指点？
另 参数如何从VBA调用中进行传递，也请指点一下。
这一句代码用VB6.0封装代码要怎么写

hb-yy

留个记号……

jy03342543

感谢法师的分享,学习一下。

ddmc

标记下 ，谢谢了

lcmphy

好贴！辛苦各位了！

上善若水12345

记号,记号,留下学习

leejp615

mark一下，以后提升了再学习

powerremain

这个留个记号