注册 登录  
 加关注
   显示下一条  |  关闭
温馨提示!由于新浪微博认证机制调整,您的新浪微博帐号绑定已过期,请重新绑定!立即重新绑定新浪微博》  |  关闭

零售创新,创新那些事儿,SPSS,VBA

零售创新

 
 
 

日志

 
 
关于我

新浪微博,零售创新 研究经理,数据分析师 希望和市场研究和零售业的同事共同进步! 本博客发表的都是免费或试用的资料,如果有版权问题请发邮件wangli12a@163.com联系删除。 spss excel vba blog

网易考拉推荐

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

2009-02-17 16:21:38|  分类: VB和VBA知识 |  标签: |举报 |字号 订阅

  下载LOFTER 我的照片书  |

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

  评论这张
 
阅读(1144)| 评论(0)
推荐 转载

历史上的今天

评论

<#--最新日志,群博日志--> <#--推荐日志--> <#--引用记录--> <#--博主推荐--> <#--随机阅读--> <#--首页推荐--> <#--历史上的今天--> <#--被推荐日志--> <#--上一篇,下一篇--> <#-- 热度 --> <#-- 网易新闻广告 --> <#--右边模块结构--> <#--评论模块结构--> <#--引用模块结构--> <#--博主发起的投票-->
 
 
 
 
 
 
 
 
 
 
 
 
 
 

页脚

网易公司版权所有 ©1997-2017