使用VBA宏将excel中图片按行命名导出

最近在做 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

存在问题:

  • 下载到当前目录
  • 导出速度过快,内存溢出,报 1004 错误
  • 图片有阴影黑色边框

改版图片导出:

Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub test()
    Dim shp, path
    path = ThisWorkbook.Path & "\image\"
    If Dir(path, vbDirectory) = "" Then
        MkDir (path)
    End If
    For Each shp In Sheet1.Shapes
        Call Chart2Pic(shp, path & shp.TopLeftCell.Offset(0, 2) & ".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

参考文档:

  1. VBA宏批量导出A列图片并按B列命名
  2. VBA如何提取表中图片
  3. VBA延时的三个方法--以及声明之后,使用sleep报错的解决方案(64位)

冯奎博客
请先登录后发表评论
  • latest comments
  • 总共0条评论