VBA如何在Excel粘贴表单图片前调整其尺寸

你现有代码已经内置了等比例调整图片宽度的逻辑，只需根据需求调整参数或修改少量代码即可实现自定义尺寸控制：

1. 快速调整：直接修改调用参数 #

你调用TransferToSheet时传入的第三个参数就是图片的目标宽度（单位：磅），直接修改该数值即可调整图片尺寸，示例：

Private Sub CommandButton1_Click()
 ' 第三个参数改为200，即粘贴后的图片宽度为200磅，高度会按原比例自动缩放
 TransferToSheet Me.Image1, Plan2, 200
End Sub

原代码中ShapeRange.LockAspectRatio = msoTrue已经设置了锁定图片纵横比，调整宽度时高度会自动等比例缩放，不会出现拉伸变形。

2. 按固定高度调整：修改TransferToSheet逻辑 #

如果需要按高度为基准调整尺寸，可修改TransferToSheet过程的参数和赋值逻辑，示例修改后代码：

Private Sub CommandButton1_Click()
 ' 第四个参数传入目标高度150磅
 TransferToSheet Me.Image1, Plan2, , 150
End Sub

Private Sub TransferToSheet(picControl, sht As Worksheet, Optional picWidth As Long, Optional picHeight As Long)
 Const TemporaryFolder = 2
 Dim fso, p
 Set fso = CreateObject("scripting.filesystemobject")
 p = fso.GetSpecialFolder(TemporaryFolder).Path & "\" & fso.gettempname
 SavePicture picControl.Picture, p
 
 ' 修复原代码插入对象的语法错误，使用工作表Shapes.AddPicture插入
 With sht.Shapes.AddPicture(Filename:=p, LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=0, Top:=0, Width:=-1, Height:=-1)
  .LockAspectRatio = msoTrue
  ' 优先按传入的宽度调整，没有传宽度则按高度调整
  If picWidth > 0 Then
   .Width = picWidth
  ElseIf picHeight > 0 Then
   .Height = picHeight
  End If
  ' 可选：将图片对齐到活动单元格位置
  .Top = ActiveCell.Top
  .Left = ActiveCell.Left
 End With
   
 fso.DeleteFile p
 Unload Me
End Sub

3. 适配活动单元格尺寸 #

如果需要让图片刚好适配当前选中的单元格大小，可直接读取活动单元格的宽高作为调整基准：

With sht.Shapes.AddPicture(Filename:=p, LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=ActiveCell.Left, Top:=ActiveCell.Top, Width:=-1, Height:=-1)
 .LockAspectRatio = msoTrue
 ' 以单元格宽度为上限调整
 If .Width > ActiveCell.Width Then .Width = ActiveCell.Width
 ' 如果高度超出单元格范围则再按高度适配
 If .Height > ActiveCell.Height Then .Height = ActiveCell.Height
End With

内容的提问来源于stack exchange，提问作者Pedro