最近在做 excel
导入时,遇到一个问题,
如何将 excel
中的图片按行导出,并按照另一列内容命名,
在网上找了许多办法,发现使用 VBA
可以快速处理出来,
使用 VBA
宏循环每行数据,将图片复制导出下来:
记录一下使用过程,便于之后使用:
1、首先将文件转储成 .xlsm
格式
2、打开文件,同时按住 Alt
+ F11
3、点击菜单 (工具 -> 宏 )输入名字创建
原始图片导出:
Sub test()
Dim x, p
p = ThisWorkbook.Path & "\"
For Each x In Sheet1.Shapes
Call Chart2Pic(x, p & x.TopLeftCell.Offset(0, 1) & ".jpg")
Next
End Sub
'导出(图片对象, 图片路径)
Sub Chart2Pic(x, f)
x.CopyPicture Appearance:=xlScreen, Format:=xlBitmap '将所选对象作为图片复制到剪贴板
With ActiveSheet.ChartObjects.Add(0, 0, x.Width, x.Height).Chart '创建嵌入式图表
.Parent.Select
.Paste '将剪贴板中的图表数据粘贴到指定的图表中
.Export Filename:=f '以图形格式导出图表
.Parent.Delete
End With
End Sub
存在问题:
改版图片导出:
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub test()
Dim shp, path, name
path = ThisWorkbook.path & "\image\"
If Dir(path, vbDirectory) = "" Then
MkDir (path)
End If
For Each shp In Sheet1.Shapes
name = shp.TopLeftCell.Offset(0, 2)
name = Trim(Replace(name, Chr(10), "")) '删除空格及回车
shp.TopLeftCell.Offset(0, 2) = name '替换单元格内容
Call Chart2Pic(shp, path & name & ".jpg")
Sleep 50 '延时操作
Next
End Sub
'导出(图片对象, 图片路径)
Sub Chart2Pic(shp, path)
'将所选对象作为图片复制到剪贴板
shp.CopyPicture Appearance:=xlPrinter, Format:=xlPicture
'创建嵌入式图表
With ActiveSheet.ChartObjects.Add(0, 0, shp.Width, shp.Height).Chart
.Parent.Select
.Paste '将剪贴板中的图表数据粘贴到指定的图表中
'去掉Chart边框
ActiveSheet.Shapes(ActiveSheet.Shapes.Count).Line.Visible = msoFalse
'去掉Chart填充
ActiveSheet.Shapes(ActiveSheet.Shapes.Count).Fill.Visible = msoFalse
'以图形格式导出图表
.Export Filename:=path
.Parent.Delete
End With
End Sub
参考文档:
'Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub test()
Dim shp, path, name
For Each sht In ThisWorkbook.Worksheets
path = ThisWorkbook.path & "\images\" & sht.name & "\"
If Dir(path, vbDirectory) = "" Then
MkDir (path)
End If
For Each shp In sht.Shapes
name = shp.TopLeftCell.Offset(0, -2)
name = Trim(Replace(name, Chr(10), "")) '删除空格及回车
shp.TopLeftCell.Offset(0, -2) = name '替换单元格内容
Call Chart2Pic(shp, path & name & ".jpg")
'Sleep 50 '延时操作
Next
Next
End Sub
'导出(图片对象, 图片路径)
Sub Chart2Pic(shp, path)
'将所选对象作为图片复制到剪贴板
shp.CopyPicture Appearance:=xlPrinter, Format:=xlPicture
'创建嵌入式图表
With ActiveSheet.ChartObjects.Add(0, 0, shp.Width, shp.Height).Chart
.Parent.Select
.Paste '将剪贴板中的图表数据粘贴到指定的图表中
'去掉Chart边框
ActiveSheet.Shapes(ActiveSheet.Shapes.Count).Line.Visible = msoFalse
'去掉Chart填充
ActiveSheet.Shapes(ActiveSheet.Shapes.Count).Fill.Visible = msoFalse
'以图形格式导出图表
.Export Filename:=path
.Parent.Delete
End With
End Sub
本文为冯奎原创文章,转载无需和我联系,但请注明来自冯奎博客fengkui.net
最新评论