批量截图-对工作簿下所有工作表的指定区域截图

hzp828490

每个工作表内有这么一块区域显示内容，需要将它们批量截图，并且将所有截图以对应的工作表命名，另存至新的工作表内，或者另存至原工作簿路径下的文件夹里。

之前有位朋友帮忙写了一段代码，功能都实现了，但是图片尺寸太小，清晰度差了，感觉颜色还有点失真。如下图：

原代码如下：

Sub put_jpg()
'选择区域生成本地图片
'On Error Resume Next

thispath = ActiveWorkbook.Path & "\"
Set aksht = ActiveSheet
Set Rng = Application.InputBox("请选择要变成图片的单元格区域", Type:=8)
'用户选择需要插入图片的名称所在单元格范围
'Set Rng = Intersect(Rng.Parent.UsedRange, Rng)
'If Rng Is Nothing Then MsgBox "选择的单元格范围不存在数据！": Exit Sub
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each sht1 In Sheets
    'a = Replace(Rng.Address, "$", "")
    sht1.Select
    sht1.Range(Rng.Address).Select
    Selection.CopyPicture 1, 2
    ActiveSheet.Pictures.Paste.Select
    With Selection
        .Copy
        With ActiveSheet.ChartObjects.Add(0, 0, Selection.Width, Selection.Height).Chart
            t = Timer
            While Timer < t + 1
                DoEvents
            Wend
            .Parent.Select
            .Paste
            .Export thispath & sht1.Name & ".jpg"
            .Parent.Delete
        End With
        .Delete
    End With
Next sht1
aksht.Select
MsgBox "完成！"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub


求大神帮忙看一下，哪里可以修改或者重新写一段，感激不尽，拜托拜托。

高个子

上传附件呗

wanghan519

可以试试新玩具

hzp828490

高个子 发表于 2023-2-15 12:27
上传附件呗

这是那个朋友帮忙写的代码，导出来的截图尺寸较小，自己单个截的图尺寸大很多，清晰一些

hzp828490

高个子 发表于 2023-2-15 12:27
上传附件呗

附件在楼下，大佬帮忙看下

hzp828490

wanghan519 发表于 2023-2-15 12:41
可以试试新玩具

这个是啥程序吗，WPS里面能装吗