我记得有位学员问及怎用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