【原】Excel VBA导出图片常见代码集

1.选中区域导出为图片

Sub 导出为图片()

Dim f$

f = "D\DRdlb.JPG"

If Dir(f) <> "" Then Kill f

Sheets("sheet1").Select

Range("A1:Q87").Select

Selection.Copy

Selection.CopyPicture '选区复制为图片

With ActiveSheet.ChartObjects.Add(0, 0, Selection.Width, Selection.Height).Chart '通过在当前工作表添加相同大小的图表的方式转存成图片

.Parent.Select

.Paste '粘贴复制后的图片

.Export "D:\DRdlb.JPG", "JPG" '导出到当前工作表目录下,以当前区域首行单元格的值命名图片

.Parent.Delete '删除该图表

End With

End Sub

2.导出为图片到文件夹

Sub 保存图片()

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

Dim nm$, n&, myFolder$

Sheet1.Activate

n = 0

myFolder = ThisWorkbook.Path & "\图片\" '指定文件夹名称

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

mc = Replace(Cells(m, 1).Address, "$", "")

nm = Format(n, "00") & "-" & mc & ".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

'Range(ad) = nm

End If

Next

MsgBox "完成"

End Sub