vba如何将单元格区域截图并保存？

zhigangchen

之前，在excelhome论坛，已经有网友给出了从excel工作表区域截图并保存的方法和代码。但是在excel 2016环境下，我试了以后，发现截图出来的图片都是空白的，研究了一下，发现是在粘贴时，图片没有粘贴到chartoject之中。因此对代码进行了改良，可以使用了。代码如下：（申明：这此代码是网上下载的，只是经过我的修改！）

Sub SaveRngToJpg()
    Dim rng As Range
    Dim ad$, m&, mc$, shp As Shape
    Dim nm$, n&, myFolder$
    Sheet1.Activate
    n = 0
    myFolder = ThisWorkbook.Path & "\图片\"     '指定文件夹名称
    Set rng = Application.InputBox("请选择单元格", "选择", Type:=8)
    rng.Select
    Selection.Copy
    ActiveSheet.Pictures.Paste
    For Each shp In ActiveSheet.Shapes
        If shp.Type = 13 Then
            If Len(Dir(myFolder, vbDirectory)) = 0 Then
                MkDir myFolder
            End If
            n = n + 1
            ad = shp.TopLeftCell.Address
            m = shp.TopLeftCell.Row
            nm = Replace(Replace(rng.Address, "$", ""), ":", "-") & ".jpg" ’此处jpg可以更改为.png或.bmp，这些格式如果压缩，图片可能更清晰一些。
            shp.CopyPicture
            With ActiveSheet.ChartObjects.Add(0, 0, shp.Width, shp.Height).Chart
                .Parent.Select '必须要选择父对象chartojbect之后再粘贴，这样才能真正的粘上去。
                .Paste
                .Export myFolder & nm, "JPG"
                .Parent.Delete
            End With
            shp.Delete
        End If
    Next
    MsgBox ("已保存到图片文件夹下")
End Sub

wormtwo

赞一个！这个不错

02761752696

谢谢分享    就是太模糊

zhigangchen

02761752696 发表于 2016-6-25 15:36
谢谢分享    就是太模糊

  nm = Replace(Replace(rng.Address, "$", ""), ":", "-") & ".jpg"          这一句，改成  nm = Replace(Replace(rng.Address, "$", ""), ":", "-") & ".bmp"       ,BMP没有压缩。

holyabc

 你的研究成果太重要了，十分感谢！！！

With ActiveSheet.ChartObjects.Add(0, 0, shp.Width, shp.Height).Chart
                .Parent.Select '必须要选择父对象chartojbect之后再粘贴，这样才能真正的粘上去。
                .Paste
                .Export myFolder & nm, "JPG"
                .Parent.Delete
            End With

m123456412

如果想要达成批量截图，那改如何操作？  怎么填写循环语句。

zzpsx

Private Sub CommandButton1_Click()
Dim my_Range As Range
Set my_Range = Selection
my_Range.CopyPicture

Dim my_Chart As Chart
Set my_Chart = ActiveSheet.ChartObjects.Add(0, 0, my_Range.Width, my_Range.Height).Chart
my_Chart.Paste
my_Chart.Export ThisWorkbook.Path & "\" & "my_Pic.jpg", "JPG"
my_Chart.Parent.Delete
End Sub


这段也需要选定后才能导出。

ycbfwl

还是没解决失真的问题，

lujkhua

ycbfwl 发表于 2018-8-22 14:47
还是没解决失真的问题，

这清晰度还能接受吧？

zyq75211

老师好，我要是不用选择区域，而是要固定某个区域怎么处理，比如A2:RW23，否则每次都需要选择比较麻烦，谢谢！