VBA应用

03 图形

一键导出Excel中的图形到当前路径

关于Excel和图形(Shape)，之前都是说如何插入的！插入到单元格/插入到批注，如果Excel已经存在的图片，是不是也可以导出来到本地呢？

当然是可以的！

这里会接触到两个之前没有介绍过的文件系统操作语句：Kill 和MkDir，Kill语句删除系统指定路径的文件，MkDir语句创建新文件夹。

它的整个运行过程的逻辑很简单，简述就是三个步骤：

1、本地新建一个文件夹；
2、遍历工作簿中所有工作表内的Shapes图形；
3、保存下来。

从中会用到几个之前从没用到的语句，在VBA的实现过程的步骤中，来一一了解它！

运行视频：

源码下载：

描述：

一键导出工作簿中的所有工作表的图像（图形和图片），并保存到当前路径。

需求分析：

1、当前路径新建文件夹；
2、导出代码所在的工作簿内所有工作表内的图形。

VBA实现过程：

1.ThisWorkbook.path属性，当前工作簿的完整路径；
2.MkDir (path + 新文件夹名)，MkDir语句创建新文件夹；
3.注意这里增加一个判断，符合代码调试和优化里"减少交互和避免重复"，即如果当前已经有了用来保存图形的"新文件夹"，执行Kill ((path + 新文件夹名 + "*")，清除文件夹内的所有文件后跳转到执行导出的语句即可，不必"在新建文件夹"；
4.两个嵌套循环，对工作表循环、嵌套一个对工作表内的所有图形循环，执行保存；
5.图形的保存：

①.Sheet.Shapes：工作表内的所有图形；
②.ChartObjects.Add：创建一个新的嵌入式图表， Shp.Width, Shp.Height，位置和尺寸与原形状相同；
③.Paste：将复制的剪贴板中的形状粘贴到图表中。如果说有疑问：“复制的不就是图吗，为什么还有新建一个，然后粘贴呢？”，可以把它理解成：“工作表中嵌入的图片是依附在Excel这一载体上，当保存在本地时，需要新建一个”相框“载体，把图片放置到新的载体上。”
④.Export：将图表导出为路径 + 表名 + 图形名(Shp.Name) + .jpg的图片文件，图形名(Shp.Name) 是根据图片插入的顺序默认:图片1 、图片2、....图片n；
Shp.Name如图所示：

⑤.Parent.Delete：删除临时创建的图表对象，避免残留。

示例代码

复制成功!


Sub 导出工作表中的图片()
    '-----------------------------------------------------------------------
    '自定义数据类型
    Dim path As String
    Dim Shp, Sht
    Dim n As Long

    Application.ScreenUpdating = False

    '在当前路径下增加一个文件夹，名称为“导出图片”，赋值给path
    path = ThisWorkbook.path & "\导出图片\"

    '在当前路径是否存在文件夹，存在则清空，不存在则新建
    If Len(Dir(path, vbDirectory)) Then
        Kill (path & "*")
        GoTo A:
    Else
        MkDir (path)
        GoTo A:
    End If


'便利工作薄的每个工作表，如果表中存在图片，则导出
A:
    For Each Sht In ThisWorkbook.Sheets
        Sht.Activate
        If ActiveSheet.Shapes.Count > 0 Then
            n = 0
            For Each Shp In ActiveSheet.Shapes
                n = n + 1
                Shp.Copy
                '创建新的嵌入式图表，保存到当前路径的新建文件夹中
                With ActiveSheet.ChartObjects.Add(0, 0, Shp.Width, Shp.Height).Chart
                    .Paste
                    .Export path & Sht.Name & "-" & Shp.Name & ".jpg"
                    .Parent.Delete
                End With
            Next
        End If
    Next Sht
    Application.ScreenUpdating = True
MsgBox "导出完成"
End Sub

基础知识点：

补充内容：如果图片和sheet工作表内的某列有关系呢？

比如实例：🔗一键插入多张图片到指定单元格位置，插入图片时，图片名称是和选择的列一一相对应的，那么导出时，也希望用对应的值作为图片名称保存下来！

这时我们需要把Shp.Name做出调整。

复制成功!


'插入图片时，我们选择了单元格右侧相邻单元格保存图片
'且使图片的左边距等于其左上单元格的左边距
'图片上边距等于左上单元格上边距
.Left = C.Offset(0, 1).Left
.Top = C.Offset(0, 1).Top

'导出图片时，选择图片左侧相邻单元格的value值作为图片名称
'这里未避免非预知错误，如果图片左侧单元格有值就作为图片名称
'否则仍用图片在表格中的名称作为文件名称！
Dim oRng As Range
Set oRng = Shp.TopLeftCell.Offset(0, -1)
If oRng.Value = "" Then Shp_Name = Shp.Name Else Shp_Name = oRng.Value