将EXCEL的选定区域保存为图片

raulerini

思路：先利用CopyPicture方法，将区域复制为图片。
然后粘贴为图片。再插入一个chart对象，利用chart对象的Export方法，将复制的图片单独存到本地硬盘上。

参考代码如下：

1. 
   
2. Sub 截取图片()
   
3.     Dim myPic As Shape, pic As Shape       '定义变量
   
4.     Dim rng       As Range
   
5.     For Each pic In ActiveSheet.Shapes
   
6.         If pic.Type = msoPicture Then pic.Delete    '遍历工作表，删除图像格式的对象
   
7.     Next
   
8. '通过application的inputbox方法来选择单元格区域
   
9. Set rng = Application.InputBox("请选择需要截取的屏幕范围：", "截取范围", Type:=8)  
   
10.      rng.CopyPicture xlScreen, xlBitmap     '复制区域为图像
    
11.     ActiveSheet.Paste Destination:=ActiveSheet.Range("A1")    '粘贴复制的图像到当前的工作表中
    
12.     Set myPic = ActiveSheet.Shapes(1)      '将复制的图像赋值给变量myPic
    
13. '插入一个图表，图表位于A1左上角（坐标0,0)，长宽等于复制的图像的长宽
    
14. With ActiveSheet.ChartObjects.Add(0, 0, myPic.Width, myPic.Height).Chart   
    
15.         myPic.Copy                         '复制图像
    
16.         .Paste                             '粘贴至图表中
    
17. '利用application的另存为对话框获取存储的路径,默认文件名为myExcelPic，格式为JPG格式
    
18. SaveName = Application.GetSaveAsFilename(InitialFileName:="MyExcelPic", filefilter:="图片文件(*.JPG),*.JPG")
    
19.                If SaveName <> "False" Then .Export SaveName, "JPG"    '不允许按"取消"按钮，否则将不会执行输出为图像的动作
    
20.         .Parent.Delete                     '删除图表的父对象————图表区对象（也即是删除整个图表）
    
21.     End With
    
22.     myPic.Delete                           '临时复制的图像也一并删除
    
23.     Set myPic = Nothing                    '销毁对象变量
    
24.     Set rng = Nothing
    
25. End Sub
    

复制代码

Book1.rar (10.23 KB, 下载次数: 78)

2011-1-19 20:14 上传

点击文件名下载附件

龙猫

我来学习学习

ULCY

路过，学习学习

hai0625

发现个问题，如果选择的区域里面已经有图片了，这个VBA就没法执行完了，就会把本身的图片输出到路径。
能否把代码更新一下，非常感谢！