[原创]EXCEL导出工作表为图片

xsxsxslch

看来对有些朋友还是有用的！

WindowXP

非常感谢,这里面高手真多呀,我正好有好多客人发的比较杂的工作表需要转成图片,这样方便多了!

不过图片好像都比较大,能否能改小一点?

WindowXP

给楼主一个函数,转成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

hbkeguojin

QUOTE:

以下是引用xsxsxslch在2008-5-7 11:23:05的发言：

用Excel做了一上将工作表导出为图片的工具，希望大家能用得上：

以下是图片信息

初始界面－－工作ING界面－－完成界面

 

真是个好东西，我正需要。但VBA代码看不到，请指教。

xsxsxslch

谢谢WindowXP提供此自定义函数，有空一定好好研究一下！

xsxsxslch

回hbkeguojin兄，贴子有注明VBA密码的，请查看！

lf59

请问这种情况下如何看代码呀？

xsxsxslch

14楼的代码：

这个真不错，不知道能否有高手能讲解一下？

[此贴子已经被作者于2008-5-12 8:01:26编辑过]

WindowXP

现在我知道一种在这种情况下看代码的方法,就是先打开VBA,然后再打开这个工具,VBA窗口是不会被隐藏的!

WindowXP

QUOTE:

以下是引用xsxsxslch在2008-5-12 8:00:03的发言：
14楼的代码：

这个真不错，不知道能否有高手能讲解一下？

这是之前收集起来的,也没有用到,也不知道怎么用,会用了别忘了告诉我怎么用的,教我一下!