VBA Excel 2010-嵌入图片和调整大小

我已经潜伏了一段时间，发现它非常有用，所以已经谢谢你的帮助了

我正在尝试编写一个宏，将单个文件中的图像嵌入到工作表中并调整它们的大小，同时在需要再次放大时保持图像的完整分辨率不变。首先，我试着：

ActiveSheet.Pictures.Insert(imageName).Select
With Selection.ShapeRange
    .Height = 100
    .Width = 100
End With

这实际上是插入了一个指向图片的链接，如果图像文件被删除或excel文件移动到另一台计算机，链接将被破坏。接下来我试着：

ActiveSheet.Shapes.AddPicture Filename:=imageName, _
    linktofile:=msoFalse, _
    savewithdocument:=msoCTrue, _
    Width:=100, _
    Height:=100

此代码也可以工作，但在插入之前，图像的大小已调整为100*100像素，因此原始文件分辨率将丢失

---

有没有办法插入图像文件，然后缩小它们的大小，以便保留原始分辨率？

首先加载图片并将其定位为原始大小，然后在第二步中根据需要调整其大小。仅指定宽度或高度以保留纵横比

Sub Test()
Dim MySht As Worksheet
Dim MyPic As Shape
Dim MyLeft As Single, MyTop As Single

    ' position in Pixel relative to top/left of sheet
    MyTop = 50
    MyLeft = 50

    ' alternatively position to the top/left of [range] C3
    MyTop = [C3].Top
    MyLeft = [C3].Left

    ' alternatively position to top/left of actual scrolled position
    MyTop = Cells(Windows(1).ScrollRow, Windows(1).ScrollColumn).Top
    MyLeft = Cells(Windows(1).ScrollRow, Windows(1).ScrollColumn).Left


    Set MySht = ActiveSheet
    Set MyPic = MySht.Shapes.AddPicture("C:\Users\MikeD\Desktop\Untitled.png", _
                msoFalse, msoTrue, MyLeft, MyTop, -1, -1)
    '      ^^^  LinkTo    SaveWith                -1 = keep size

    ' now resize pic
    MyPic.Height = 100

End Sub

---

。。。并尽量避免使用

。选择
<编码>调暗
所需的对象并使用它们。
是否删除高度和宽度设置？您可能还想使用
.shaperage.LockAspectRatio=msoTrue
谢谢，这真是太棒了！我没有意识到在插入对象时可以将其设置为变量，这正是我在下一个循环中努力使用的地方。这帮了大忙，再次感谢！在旁注上，您也可以这样分配它：set mypic=ActiveSheet.Pictures.Insert（imageName.Shaperange）（1）