将工作表中的shape或chart对象另存为图像文件

上一篇 / 下一篇 2007-01-27 19:15:41 / 个人分类：Excel & VBA

SavePic过程

语法：
Sub SavePic(shp, picFormat, sFileName)
将工作表中的chart或shape对象（包括图表、形状、艺术字、图片等）以指定格式（GIF，JPG或PNG）另存为图像文件。

参数：
shp Object类型，必需，应该指定为shape或chart对象。
picFormat   Enum类型，必需，指定输出文件的格式
        pic_GIFformat = 1
        pic_JPGformat = 2
        pic_PNGformat = 3
SFileName   String类型，必需，指定目标文件名。

示例：
本示例将sheet1工作表中的所有shapes编号以GIF格式保存到E:\images目录下：
For i=1 to sheet1.Shapes.count
SavePic sheet1.Shapes(i), pic_GIFformat = 1, "E:\images\pic" & i & ".gif"
Next

示例二：在Excel右键菜单中加入“导出为图片文件”菜单项，用户选择目标文件名和格式。示例下载

具体代码如下：

'将下列代码复制到Excel VBA模块中：
'小fisher首次发表于Office精英俱乐部（http://www.officefans.net）

Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
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 IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long

Public iClipBoardFormatNumber As Long
Dim selType As String
Dim targetFile As String
Dim fd As CommonDialog

Enum picFormat
    pic_GIFformat = 1
    pic_JPGformat = 2
    pic_PNGformat = 3
End Enum

Sub savePic(shp As Object, picFormat As picFormat, sFileName As String)
    Dim nClipsize As Long
    Dim hMem As Long
    Dim lpData As Long
    Dim sdata() As Byte
    selType = TypeName(shp)
    Select Case selType
        Case "ChartArea"
            shp.Parent.Export FileName:=sFileName
            Exit Sub
        Case Else
            shp.Copy
    End Select

    OpenClipboard 0&
    If iClipBoardFormatNumber = 0 Then
        For i = 40000 To 60000
            If IsClipboardFormatAvailable(i) And IsClipboardFormatAvailable(i + 1) And IsClipboardFormatAvailable(i + 2) And IsClipboardFormatAvailable(i + 3) Then
                iClipBoardFormatNumber = i
                Exit For
            End If
        Next
    End If
On Error GoTo myerror:
    hMem = GetClipboardData(iClipBoardFormatNumber + picFormat)
    If CBool(hMem) Then
        nClipsize = GlobalSize(hMem)
        lpData = GlobalLock(hMem)
        If lpData <> 0 Then
            ReDim sdata(0 To nClipsize) As Byte
            CopyMemory sdata(0), ByVal lpData, nClipsize
            Open sFileName For Binary As #1
                Put #1, , sdata
            Close #1
        End If
        GlobalUnlock hMem
    End If

    EmptyClipboard
    CloseClipboard
    Exit Sub
myerror:
    GlobalUnlock hMem
    EmptyClipboard
    CloseClipboard
    MsgBox "export failed!"
End Sub

导入论坛引用链接收藏分享给好友管理举报

TAG:

查看全部评论