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