使用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, 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

参考文档：

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

'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