如何用VBA将插入的图片保存到Excel中？含尺寸调整需求

1. 让图片嵌入Excel随文档保存的修改 #

原来的Pictures.Insert方法是链接外部图片，不会把图片数据存入Excel文件。要改成Shapes.AddPicture方法，通过指定两个关键参数实现嵌入：

• LinkToFile:=msoFalse：不依赖原始图片文件
• SaveWithDocument:=msoTrue：将图片数据直接嵌入Excel，随文档一起保存

2. 调整图片为原尺寸50%的修改 #

不要固定宽高数值，先以原始尺寸插入图片（设置Width:=-1和Height:=-1），再将宽度（或高度）乘以0.5，同时锁定纵横比避免图片变形。

修改后的完整代码 #

Sub add_pictures_R2()
    Dim i%, ppath$
    Dim picShape As Shape ' 声明形状变量，方便后续操作
    
    For i = 2 To 145   
        ' 从A列单元格获取文件名，拼接图片完整路径
        ppath = "C:\Users\myname\output\" & CStr(Cells(i, 1).Value) & ".png"
        
        ' 检查图片文件是否存在
        If Len(Dir(ppath)) Then
            ' 嵌入图片而非链接，参数说明：
            ' Filename: 图片路径
            ' LinkToFile:=msoFalse: 不链接外部文件
            ' SaveWithDocument:=msoTrue: 嵌入到Excel文档
            ' Left/Top: 图片左上角对齐第i行第10列单元格的左上角
            ' Width/Height: -1表示使用图片原始尺寸
            Set picShape = ActiveSheet.Shapes.AddPicture( _
                Filename:=ppath, _
                LinkToFile:=msoFalse, _
                SaveWithDocument:=msoTrue, _
                Left:=ActiveSheet.Cells(i, 10).Left, _
                Top:=ActiveSheet.Cells(i, 10).Top, _
                Width:=-1, _
                Height:=-1)
            
            With picShape
                .LockAspectRatio = msoTrue ' 锁定纵横比，防止图片变形
                .Width = .Width * 0.5 ' 将宽度调整为原始尺寸的50%，高度会自动按比例缩放
                .Placement = xlMoveAndSize ' 图片随单元格移动和调整大小（和原来的1功能一致）
                .PrintObject = True ' 设置图片可打印
            End With
        End If
    Next
End Sub

关键说明 #

• 嵌入后的图片会增加Excel文件体积，但换电脑打开时能正常显示。
• 锁定纵横比后，只需要调整宽度或高度其中一个，另一个会自动按比例变化，避免图片拉伸变形。

内容的提问来源于stack exchange，提问作者Chemist learns to code