VBA保存剪贴板为JPG(加PrtScrn截屏)

时　间:2011-10-09 07:35:15
作　者:dbaseIIIer   ID：22003  城市：深圳
摘　要:测试环境为 office 2003 + XP
我记得有位学员问及怎用VBA保存剪贴板到JPG的,
很多天后, 煮茶 老师叫我截屏, 截屏未成, 却找到这个答案,
那位学员的问题不知去哪里了, 也懒得去找了, 希望他看到这篇吧!

我测试了, 这环境下非常成功的!
其实我还成功操作 CorelDraw, CorelPaint 保存的，不过不是人人有安装！
Excel的 ChartObject 的　.Export jpg 也试过，成功又简易的，不过一点质量都没有的，只是为了Excel的图表输出，一张图另存出来又有个白边框，又变形，我不敢拿出来说成功了的！

正　文:

测试环境为 office 2003 + XP

Option Explicit
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 Sub keybd_event Lib "user32" _
(ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo 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 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 GdipCreateBitmapFromFile Lib "GDIPlus" (ByVal filename As Long, Bitmap As Long) 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
Private Sub My_Screen_1()
    Call keybd_event(vbKeySnapshot, 0, 0, 0)
    DoEvents
End Sub
 
Private Sub My_Screen_2()
    Call keybd_event(vbKeySnapshot, 1, 1, 1)
    DoEvents
End Sub

Public Function Screen2JPG(ByVal filename As String, Optional ByVal quality As Byte = 80) As Boolean
   
    Dim tSI As GdiplusStartupInput
    Dim lRes As Long
    Dim lGDIP As Long
    Dim lBitmap As Long
    Dim hBitmap As Long
    '复制单元格区域图像
    ''''''Range.CopyPicture xlScreen, xlBitmap
    My_Screen_2
   
    '打开剪贴板
    OpenClipboard 0&
    '获取剪贴板中bitmap数据的句柄
    hBitmap = GetClipboardData(CF_BITMAP)
    '关闭剪贴板
    CloseClipboard
    '初始化 GDI+
    tSI.GdiplusVersion = 1
    lRes = GdiplusStartup(lGDIP, tSI, 0)
    
    If lRes = 0 Then
        '从句柄创建 GDI+ 图像
         lRes = GdipCreateBitmapFromHBITMAP(hBitmap, 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(quality)
            End With
            
            '保存图像
            lRes = GdipSaveImageToFile(lBitmap, StrPtr(filename), tJpgEncoder, tParams)
            
            '销毁GDI+图像
            GdipDisposeImage lBitmap
        End If
        
        '销毁 GDI+
        GdiplusShutdown lGDIP
    End If
    

        Screen2JPG = Not lRes
End Function