保存excel单元格区域到JPG文件

保存为BMP太大了，送你一个Range转JPG的函数

'函数名称：Range2JPG
'http://officefans.net/cdb 小fisher
'语法：Range2JPG(Range As Range, ByVal filename As String, Optional ByVal quality As Byte = 80) As Boolean
'说明：保存excel单元格区域到JPG文件
'参数：
'  Range - 要保存为JPG图片的单元格区域，必要参数
'  FileName - 要保存的JPG图片目标路径，必要参数
'  quality - JPG图片质量，数值越大，图片质量越高，占用字节数越多，可选参数
'            取值范围为0-100，小于0则出现溢出错误，大于100则与100效果相同
'返回值：如果保存成功，返回True，否则返回False

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


Public Function Range2JPG(Range As Range, 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
    '打开剪贴板
    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
     

        Range2JPG = Not lRes
End Function

参考:
VB6.0用GDI+保存图片为JPG、TIFF、PNG、GIF、BMP等格式
http://blog.csdn.net/laviewpbt/archive/2006/05/26/756547.aspx
gynephobia ID：laviewpbt
来自：http://www.officefans.net/cdb/viewthread.php?tid=93390&extra=page%3D1