64位EXCEL下面如何保存剪贴板图片

YDH318

详情见附件,这是在论坛上找的VBA代码.在32位环境中运行正常.
但在64位环境中已修改兼容性,程序不报错了,但是图片不能正常保存.

Option Explicit
#If Win64 Then
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
#Else
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 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
#End If

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
                #If Win64 Then
                .Value = CByte(quality) '此处原始quality 参数为byte类型
                #Else
                .Value = VarPtr(CByte(quality)) '此处原始quality 参数为byte类型
                #End If

            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()
    Dim nm As String
    Dim MyFile As Object
    nm = "C:\ydh2199.jpg"
    Range("A1:K100").CopyPicture Appearance:=xlScreen, Format:=xlBitmap
    Select Case ClipBitMaptoJPG(nm)
        Case 0:
        Set MyFile = CreateObject("Scripting.FileSystemObject")
          If MyFile.FileExists(nm) = True Then
            MsgBox "剪贴板图片已保存"
          Else
            MsgBox "剪贴板图片保存失败"
         End If
        Case 1:
            MsgBox "剪贴板图片保存失败"
        Case 2:
            MsgBox "剪贴板中无图片"
        Case 3:
            MsgBox "剪贴板无法打开，可能被其他程序所占用"
    End Select
    End Sub

1588078/37

改为user32

oonly

这个没发解决吗?

joforn

oonly 发表于 2023-2-23 11:10
这个没发解决吗?

https://club.excelhome.net/thread-1565669-1-1.html
下载上面帖子一楼的附件，在自己的VBA工程中导入附件中的模块，调用里面的SaveClipboardToPictrue函数
比如说：if SaveClipboardToPictrue("C:\1.PNG") Then Msgbox "保存成功"

注意调用时保存文件最好是带后缀名，最好是想要保存的图片是什么格式就用什么格式的后缀名，函数会通过不同的后缀后保存对应格式的文件，所以如果后缀随便瞎打的话，有可能会报错或是被保存为默认的BMP文件