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模块中:
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
|
评论