VBA_将指定范围截图保存

Sub SaveRngToJpg()

Dim rng As Range

Dim ad$, m&, mc$, shp As Shape

Dim nm$, n&, myFolder$

Sheet1.Activate

n = 0

myFolder = ThisWorkbook.Path & "\image\"

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"

shp.CopyPicture

With ActiveSheet.ChartObjects.Add(0, 0, shp.Width, shp.Height).Chart

.Parent.Select

.Paste

.Export myFolder & nm, "JPG"

.Parent.Delete

End With

shp.Delete

End If

Next

End Sub

其他文件

Sub Change()

Dim rng As Range

Dim ad$, m&, mc$, shp As Shape

Dim nm$, n&, myFolder$

n = 0

myFolder = "C:\Users\SWAT\Desktop\image\"

FileName1 = "C:\Users\SWAT\Desktop\test.xlsx"

Set dataExcel = CreateObject("Excel.Application")

dataExcel.ScreenUpdating = False

Set WorkbookA = dataExcel.Workbooks.Open(FileName1)

Set Sheet = WorkbookA.Worksheets("Sheet1")

' Sheet.Activate

Set rng = Sheet.Range("A1: B10")

MsgBox (Sheet.Range("b2"))

' rng.Select

rng.Copy

'Selection.Copy

' ActiveSheet.Pictures.Paste

Sheet.Pictures.Paste

'For Each shp In ActiveSheet.Shapes

For Each shp In Sheet.Shapes

If shp.Type = 13 Then

n = n + 1

ad = shp.TopLeftCell.Address

m = shp.TopLeftCell.Row

nm = Replace(Replace(rng.Address, "$", ""), ":", "-") & ".jpg"

shp.CopyPicture

' With ActiveSheet.ChartObjects.Add(0, 0, shp.Width, shp.Height).Chart

With Sheet.ChartObjects.Add(0, 0, shp.Width, shp.Height).Chart

.Parent.Select

.Paste

.Export myFolder & nm, "JPG"

.Parent.Delete

End With

shp.Delete

End If

Next


dataExcel.DisplayAlerts = False

Application.Calculation = xlCalculationManual

Application.CalculateBeforeSave = False

WorkbookA.Save

WorkbookA.Close

Set WorkbookA = Nothing

End Sub

推荐阅读 更多精彩内容