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

冯奎
2020-09-17 18:53:45
其他
其他

最近在做 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 As Shape, path As String, name As String
    Dim objRegEx As Object
    Dim objMH As Object

    path = ThisWorkbook.path & "\image\"
    If Dir(path, vbDirectory) = "" Then
        MkDir (path)
    End If
    Set objRegEx = CreateObject("vbscript.regexp")
    objRegEx.Pattern = "\D*"
    objRegEx.Global = True

    For Each shp In Sheets(1).Shapes
        name = shp.TopLeftCell.Offset(0, 1)
        'name = VBA.Trim(VBA.Replace(name, Chr(10), ""))
        If name <> "" Then
            name = objRegEx.Replace(name, "") '正则删除费数字
            shp.TopLeftCell.Offset(0, 1) = name '替换单元格内容
            Debug.Print name
            Call Chart2Pic(shp, path & name & ".jpg")
            'Sleep 50  '延时操作
        End If
    Next
End Sub

'导出(图片对象, 图片路径)
Sub Chart2Pic(shp As Shape, path As String)
    '将所选对象作为图片复制到剪贴板
    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