VBA Excel 2010 - 嵌入图片和调整大小
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/22073463/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
VBA Excel 2010 - Embedding Pictures and Resizing
提问by awenborn
I've been lurking for a while and found it very helpful, so thanks for the help already!
我已经潜伏了一段时间，发现它非常有帮助，所以已经感谢您的帮助！
I'm trying to write a macro to embed images into a worksheet from individual files and resize them, whilst keeping the full resolution of the image intact should it need to be enlarged again. First of all I tried:
我正在尝试编写一个宏，将图像从单个文件嵌入到工作表中并调整它们的大小，同时在需要再次放大时保持图像的完整分辨率不变。首先我试过：
ActiveSheet.Pictures.Insert(imageName).Select
With Selection.ShapeRange
.Height = 100
.Width = 100
End With
This essentially inserted a link to the picture and if the image file was removed or the excel file moved to another computer, the link would be broken. Next I tried:
这实际上插入了图片链接，如果删除了图像文件或将 excel 文件移动到另一台计算机，则链接将被破坏。接下来我尝试：
ActiveSheet.Shapes.AddPicture Filename:=imageName, _
linktofile:=msoFalse, _
savewithdocument:=msoCTrue, _
Width:=100, _
Height:=100
This code also works, but the image is resized to 100 * 100 pixels before insertion, so the original file resolution is lost.
这段代码也能用，但是插入前图像被调整为100 * 100像素，所以原始文件分辨率丢失了。
Is there any way to insert image files and thenscale them down in size, so that the original resolution is retained?
有什么办法可以插入图片文件，然后按比例缩小，从而保留原来的分辨率？
回答by MikeD
You first load and position the picture in its original size, and in a second step resize it as desired. You only specify EITHER width or heigth to retain the aspect ratio.
您首先以原始大小加载和定位图片，然后在第二步中根据需要调整其大小。您只需指定宽度或高度即可保留纵横比。
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
... and try to avoid .Select... Dimthe objects you need and use them.
...并尽量避免.Select...Dim您需要并使用它们的对象。
