Excel 如何使用VBA保持从链接粘贴的图像的纵横比？

我需要帮助锁定VBA代码中图像的纵横比，该代码使用特定单元格中的信息将链接中的图像粘贴到excel文件中

我想知道的是如何锁定这些粘贴图像的纵横比。 我曾试图改变一些事情，但未能成功地保持纵横比

任何帮助都将不胜感激！谢谢 彼得

ActiveWindow.Zoom=100
出错时继续下一步
暗斑作为射程
尺寸p为对象，t为双精度，l为双精度，w为双精度，h为双精度
设置Plage=选择
lig=板状细胞（1）行
col=板状单元（1）列
nbcel=0
对于Plage中的每个细胞
如果cell.Value为“”，则nbcel=nbcel+1
下一个细胞
posColstr=InputBox（“你的照片（1,2,3…），“colonne”，1）
posCol=CInt（posColstr）
如果posCol=0，则posCol=1
对于i=0到nbcel-1
Matiere=单元格（i+lig，col）.值
细胞（i+lig，posCol）。激活
带细胞（i+lig、posCol）
t=0.Top
l=.左
w=宽度
h=.高度
以
ActiveSheet.Shapes.AddPicture文件名：=”https://websiteimagelink.com/“&Matiere&.”null.null.null.null.null.jpg“，linktofile:=msoFalse，savewithdocument:=msoCTrue，顶部：=t，左侧：=l，宽度：=70，高度：=50
ActiveSheet.Shapes（ActiveSheet.Shapes.Count）.Placement=xlMoveAndSize
接下来我

下面是一个示例，说明如何做到这一点

编辑以显示它如何适合您的代码

Sub InsertPics（）
Const MAX_WIDTH As Long=100'最大图片宽度
长度=100'最大高度时的常数最大高度
Dim Plage As范围、url、rngPic As范围
尺寸p为对象，t为双精度，l为双精度，w为双精度，h为双精度
设置Plage=选择
ActiveWindow.Zoom=100
出错时继续下一步
posColstr=InputBox（“你的照片（1,2,3…），“colonne”，1）
posCol=CInt（posColstr）
如果posCol=0，则posCol=1
对于Plage.Cells中的每个c，用户选择上的循环
Matiere=修剪（c.值）
如果Len（Matiere）>0，则“如果单元格有一个值。。。
url=”https://websiteimagelink.com/&Matiere&.null.null.null.null.null.null.jpg
设置rngPic=c.EntireRow.Cells（posCol）
InsertResizePic rngPic，url，最大宽度，最大高度”或rngPic.WIDTH，rngPic.HEIGHT
如果结束
接下来我
端接头
'从路径'pth'插入一个形状，位于单元格'c'：调整大小以便尺寸标注
'不超过'maxWidth'或'maxHeight'`
Sub-InsertResizePic（c作为范围，pth作为字符串，maxWidth作为长度，maxHeight作为长度）
尺寸fW、fH、shp
设置shp=c.Parent.Pictures.Insert（文件名：=pth）
小水电
.ShapeRange.LockAspectRatio=msoTrue“锁相对h/w”
.Placement=xlMoveAndSize
.Top=c.Top
.左=c.左
fW=.Width/maxWidth'相对于允许的最大值的尺寸
fH=.Height/maxHeight
如果fW>1或fH>1，那么它是太宽还是太高？
如果fW>=fH，则
.Width=.Width/fW'太宽而不是太高：收缩宽度
其他的
.高度=.高度/fH'收缩高度
如果结束
如果结束
以
端接头

您没有使用

w

或

h

？不，脚本使用。高度：=70，宽度：=50，按原样工作，但仅图像大小与这些尺寸相同，图像的纵横比并不都是这样，所以有时会出现扭曲。我尝试了高度：=h，宽度：=w，但这只会使图片的大小与单元格的大小相同，而不是原始的纵横比。谢谢你，你对如何将其集成到现有脚本中有什么建议吗？我曾尝试在下面的代码行中使用LockAspectRatio，但未能使其正常工作。ActiveSheet.Shapes.AddPicture文件名：=“”&Matiere&“.null.null.null.null.null.jpg”，linktofile:=msoFalse，savewithdocument:=msoCTrue，顶部：=t，左侧：=l，宽度：=70，高度：=50参见以上更新。

ActiveWindow.Zoom = 100
On Error Resume Next
Dim Plage As Range
Dim p As Object, t As Double, l As Double, w As Double, h As Double
Set Plage = Selection

lig = Plage.Cells(1).Row
col = Plage.Cells(1).Column

nbcel = 0
For Each cell In Plage
    If cell.Value <> "" Then nbcel = nbcel + 1
Next cell

posColstr = InputBox("En quelle colonne voulez-vous inserer vos photos (1, 2, 3...)?", "Colonne", 1)
posCol = CInt(posColstr)
If posCol = 0 Then posCol = 1

For i = 0 To nbcel - 1
    Matiere = Cells(i + lig, col).Value
    Cells(i + lig, posCol).Activate
    With Cells(i + lig, posCol)
        t = .Top
        l = .Left
        w = .Width
        h = .Height
    End With

    ActiveSheet.Shapes.AddPicture Filename:="https://websiteimagelink.com/" & Matiere & ".null.null.null.null.null.jpg", linktofile:=msoFalse, savewithdocument:=msoCTrue, Top:=t, Left:=l, Width:=70, Height:=50
    ActiveSheet.Shapes(ActiveSheet.Shapes.Count).Placement = xlMoveAndSize
    
    
Next i