excel插入的图片预先设置大小 vba

Excel 如何用vba使插入单元格的照片按预先设置的大小插入单元格内并使照片居中放置

可以使用以下VBA代码实现：

Sub InsertPicture()
    Dim picPath As String
    Dim picWidth As Single
    Dim picHeight As Single
    Dim picLeft As Single
    Dim picTop As Single
    
    '设置图片路径
    picPath = "C:\picture.jpg"
    
    '设置图片大小
    picWidth = 100
    picHeight = 100
    
    '设置图片位置
    picLeft = ActiveCell.Left
    picTop = ActiveCell.Top
    
    '插入图片
    ActiveSheet.Shapes.AddPicture Filename:=picPath, _
        LinkToFile:=msoFalse, _
        SaveWithDocument:=msoTrue, _
        Left:=picLeft, _
        Top:=picTop, _
        Width:=picWidth, _
        Height:=picHeight
        
    '将图片居中放置
    With ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
        .Left = ActiveCell.Left + (ActiveCell.Width - .Width) / 2
        .Top = ActiveCell.Top + (ActiveCell.Height - .Height) / 2
    End With
End Sub

把img 图片路径换下 , 如有帮助给个采纳谢谢

Sub InsertImage()
    Dim imgPath As String
    Dim img As Picture
    Dim rng As Range

    ' 定义图片路径
    imgPath = "C:\图片路径\图片名称.jpg"
    
    ' 设置要插入图片的单元格范围
    Set rng = Range("A1")
    
    ' 插入图片
    Set img = ActiveSheet.Pictures.Insert(imgPath)
    
    ' 将图片调整到指定大小
    With img
        .ShapeRange.LockAspectRatio = msoFalse
        .Width = rng.Width
        .Height = rng.Height
    End With
    
    ' 计算并设置图片在单元格中的位置
    With img.ShapeRange
        .Left = rng.Left
        .Top = rng.Top
        .Placement = xlMoveAndSize
    End With
    
    ' 图片居中放置
    img.ShapeRange.Align msoAlignCenters, True
    img.ShapeRange.Align msoAlignMiddles, True
End Sub

Sub 插入图片()


Dim filenames As String
Dim filefilter1 As String


filefilter1 = ("所有图片文件（*.jpg;*.bmp;*.png;*.gif）,*.jpg;*.bmp;*.png;*.gif")    '所有图片文件后面的括号为中文括号
filenames = Application.GetOpenFilename(filefilter1, , "请选择一个图片文件", , MultiSelect:=False)


'没有选中文件时，做容错处理
If filenames = "False" Then
Exit Sub
End If


'插入图片到指定的单元格
Sheet1.Pictures.Insert(filenames).Select


'图片自适应单元格大小
On Error Resume Next
Dim picW As Single, picH As Single
Dim cellW As Single, cellH As Single
Dim rtoW As Single, rtoH As Single
cellW = ActiveCell.Width
cellH = ActiveCell.Height
picW = Selection.ShapeRange.Width
picH = Selection.ShapeRange.Height
rtoW = cellW / picW * 0.95
rtoH = cellH / picH * 0.95
If rtoW < rtoH Then
    Selection.ShapeRange.ScaleWidth rtoW, msoFalse, msoScaleFromTopLeft
Else
    Selection.ShapeRange.ScaleHeight rtoH, msoFalse, msoScaleFromTopLeft
End If
picW = Selection.ShapeRange.Width
picH = Selection.ShapeRange.Height
Selection.ShapeRange.IncrementLeft (cellW - picW) / 2
Selection.ShapeRange.IncrementTop (cellH - picH) / 2


End Sub