64位office剪贴板保存为图片函数问题

cyhwy

下面代码不能保存为图片，也没有错误提示


Option Explicit

Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Private Declare PtrSafe Function GdiplusStartup Lib "GDIPlus" (token As Long, inputbuf As GdiplusStartupInput, ByVal outputbuf As Long) As Long
Private Declare PtrSafe Function GdiplusShutdown Lib "GDIPlus" (ByVal token As Long) As Long
Private Declare PtrSafe Function GdipDisposeImage Lib "GDIPlus" (ByVal Image As LongPtr) As Long
Private Declare PtrSafe Function GdipSaveImageToFile Lib "GDIPlus" (ByVal Image As Long, ByVal filename As LongPtr, clsidEncoder As GUID, encoderParams As Any) As Long
Private Declare PtrSafe Function CLSIDFromString Lib "ole32" (ByVal str As LongPtr, id As GUID) As Long
Private Declare PtrSafe Function GdipCreateBitmapFromHBITMAP Lib "GDIPlus" (ByVal hbm As Long, ByVal hPal As Long, BITMAP 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



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 = 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

剪贴板保存图片.zip (20.07 KB, 下载次数: 8)

2024-9-8 19:21 上传

点击文件名下载附件

cyhwy

怎样解决64位保存图片问题呢

lss001

cyhwy 发表于 2024-9-8 19:22
怎样解决64位保存图片问题呢

剪贴板保存图片.rar (22.34 KB, 下载次数: 13)

2024-9-8 21:59 上传

点击文件名下载附件

用函数比较繁琐，过程较简单些

cyhwy

感谢大佬
Option Explicit

Private Declare PtrSafe Function OpenClipboard _
    Lib "user32" (ByVal hwnd As Long) As Long
Private Declare PtrSafe Function CloseClipboard _
    Lib "user32" () As Long
Private Declare PtrSafe Function GetClipboardData _
    Lib "user32" (ByVal wFormat As Long) As Long
Private Declare PtrSafe Function GdiplusStartup _
    Lib "GDIPlus" (token As Long, _
    inputbuf As GdiplusStartupInput, _
    ByVal outputbuf As Long) As Long
Private Declare PtrSafe Function GdiplusShutdown _
    Lib "GDIPlus" (ByVal token As Long) As Long
Private Declare PtrSafe Function GdipDisposeImage _
    Lib "GDIPlus" (ByVal Image As LongPtr) As Long
'第二参数：Longlong
Private Declare PtrSafe Function GdipSaveImageToFile _
    Lib "GDIPlus" (ByVal Image As LongPtr, _
    ByVal filename As LongLong, _
    clsidEncoder As GUID, _
    encoderParams As Any) As Long
Private Declare PtrSafe Function CLSIDFromString _
    Lib "ole32" (ByVal str As LongPtr, _
    id As GUID) As Long
Private Declare PtrSafe Function GdipCreateBitmapFromHBITMAP _
    Lib "GDIPlus" (ByVal hbm As Long, _
    ByVal hPal As Long, _
    BITMAP As LongPtr) As Long


Private Const CF_BITMAP = 2 '对应(.bmp, .jpg, .gif)
Private Const CF_ENHMETAFILE = 14 '对应(.png, .wmf, .mix)

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

'以下参数：LongPtr
Private Type GdiplusStartupInput
    GdiplusVersion As LongPtr
    DebugEventCallback As LongPtr
    SuppressBackgroundThread As LongPtr
    SuppressExternalCodecs As LongPtr
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

Public Function ClipBitMaptoJPG(文件名$)
    Dim destfilename As String
    destfilename = Replace(文件名 & ".jpg", ".jpg.jpg", ".jpg") '指定保存文件
    Const quality As Long = 80
    Dim tSI As GdiplusStartupInput
    Dim lRes As Long, tGDIP As Long
    Dim lBitmap As LongPtr, hBmp As Long

    '尝试打开剪贴板
    If OpenClipboard(0) Then
        hBmp = GetClipboardData(CF_BITMAP)
        If hBmp = 0 Then
            ClipBitMaptoJPG = "剪贴板无数据": GoTo t
        End If
    End If
   
    tSI.GdiplusVersion = 1
    lRes = GdiplusStartup(tGDIP, tSI, 0)
    If lRes = 0 Then
        lRes = GdipCreateBitmapFromHBITMAP(hBmp, 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 = quality
            End With
            '保存图像
            lRes = GdipSaveImageToFile( _
            lBitmap, StrPtr(destfilename), tJpgEncoder, tParams)
            GdipDisposeImage lBitmap
            ClipBitMaptoJPG = "图片保存" & destfilename
        End If
        '销毁 GDI+
        GdiplusShutdown tGDIP
    End If
t:
    CloseClipboard
End Function
我改成函数了