VBA插入图片随文件保存（非引用方式）

1.1. 需求分析

接收到xxx公司项目正在使用的Excel自动生成报告的宏，可以看出，大致就是把测试截图全自动插入到报告文件中。

image.png

1.1.1. 已知问题

生成的报告文件有一个最大的问题就是当目录下的测试截图被删除时，测试报告当中的图片就会显示为空, 这显然不是我们想要的效果。

image.png

查看宏代码得知Pictures.Insert只是引用了路径下的图片，图片不能随文件一起保存，所以要解决这个问题。

        Workbooks("" & Filename & "").Activate
        Sheets("测试截图").Select
        Range("A8:R27").Select

        file = Dir(ThisWorkbook.Path & "\" & zhanMing & "\测试截图\整体覆盖RxLevel.*")
        ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\" & zhanMing & "\测试截图\" & file & "").Select 'Pictures.Insert方法，因为在文档中只存储图片的链接信息，图片不能随文件一起保存
        Selection.ShapeRange.LockAspectRatio = msoFalse
       ' Selection.ShapeRange.IncrementLeft -10
       ' Selection.ShapeRange.IncrementTop -10
        Selection.ShapeRange.Height = 285
        Selection.ShapeRange.Width = 485

1.2. 解决方案

使用Shapes.AddPicture 方法来保存文件

语法：
Shapes.AddPicture( Filename , LinkToFile , SaveWithDocument , Left , Top , Width , Height )

image.png

示例

This example adds a picture created from the file Music.bmp to myDocument.

Set myDocument = Worksheets(1) 
myDocument.Shapes.AddPicture("c:\microsoft office\clipart\music.bmp", True, True, 100, 100, 70, 70)

1.2.1. 代码的修改

1.新建一个子过程：

Sub InsertPicture(path As String, ran As Range)
'Path为文件路径
'ran为要插入的单元格区域
Set myDocument = ActiveSheet
myDocument.Shapes.AddPicture(path, True, True, ran.Left, ran.Top, ran.Width, ran.Height).Placement = xlMoveAndSize
End Sub

2.把原宏中所有类似的代码都改为以下格式


'原始代码示例
        Range("C14:D14").Select
        file = Dir(ThisWorkbook.Path & "\" & zhanMing & "\现场照片\天线侧面照片_第2小区.*")
        ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\" & zhanMing & "\现场照片\" & file & "").Select
        Selection.ShapeRange.LockAspectRatio = msoFalse
        Selection.ShapeRange.Height = 170
        Selection.ShapeRange.Width = 285

'修改后示例
        file = Dir(ThisWorkbook.path & "\" & zhanMing & "\现场照片\天线侧面照片_第2小区.*")
        Call InsertPicture(ThisWorkbook.path & "\" & zhanMing & "\现场照片\" & file & "", Range("C14:D14"))

3.测试后生成的文件大小比原来的文件大了好多，里面的图片也真正保存到Excel文件中了。

最后编辑于：2018.08.14 10:49:58