各位大佬有空帮忙看看哪里有错，插入的图片变形了

xiangheping

Sub 插入图片()
    On Error Resume Next '有错误继续往下运行
    Application.ScreenUpdating = False
    Dim pth As String, brr
    Dim picNames As Variant
    Dim rng As Range
    Dim shp As Shape
    Dim fs As Object
    Dim folder As Object
    Dim file As Object
    pth = ThisWorkbook.Path & "\"
    ' 获取图片名称列表
    picNames = Array("作业证", "照片", "身份证", "查询证明")
    ' 删除已存在的图片
    For Each shp In Sheet1.Shapes
        If shp.Type = msoLinkedPicture Then shp.Delete
    Next
    ' 设置文件系统对象
    Set fs = CreateObject("Scripting.FileSystemObject")

    ' 循环插入图片
    For i = LBound(picNames) To UBound(picNames)
        ' 获取图片文件路径
        picPath = pth & picNames(i) & "\" & ListBox2.Text & ".jpg"
        ' 如果jpg格式的图片不存在，尝试png格式
        If Not fs.FileExists(picPath) Then
            picPath = pth & picNames(i) & "\" & ListBox2.Text & ".png"
        End If
        ' 如果找到了图片，插入到相应位置
        If fs.FileExists(picPath) Then
            Sheet1.Activate
            Set rng = Sheet1.Range(Array("A6", "G6", "A8", "G8")(i))
            With rng
                ' 插入图片
                Set shp = Sheet1.Shapes.AddPicture(picPath, msoFalse, msoCTrue, .Left, .Top, .Width, .Height)
                ' 设置图片属性
                Dim cellW As Single, cellH As Single    '单元格宽与高
                cellW = rng.MergeArea.Width  '获取单元格宽度
                cellH = rng.MergeArea.Height '获取单元格高度
                With shp
                    Dim picW As Single, picH As Single
                    Dim rtoW As Single, rtoH As Single
                    picW = .Width   '图片宽度
                    picH = .Height  '图片高度
                    rtoW = cellW / picW * 0.95   '重设图片的宽和高
                    rtoH = cellH / picH * 0.95
                    If rtoW < rtoH Then
                        .ShapeRange.ScaleWidth rtoW, msoFalse, msoScaleFromTopLeft
                    Else
                        .ShapeRange.ScaleHeight rtoH, msoFalse, msoScaleFromTopLeft
                    End If
                    picW = .Width
                    picH = .Height
                    .ShapeRange.LockAspectRatio = msoTrue          '锁定图片锁定纵横比
                    .Placement = xlMoveAndSize                     '图片的位置与大小随单元格变化而变化
                    .Left = .Left + (cellW - picW) / 2   '设置该图片的所在位置
                    .Top = .Top + (cellH - picH) / 2
                End With
            End With
        End If
    Next i
    [a1].Select
    Application.ScreenUpdating = True
End Sub

蓝桥玄霜

没有附件不能测试代码。
建议上传Excel表格附件来说明问题。

taller

1. .ShapeRange.LockAspectRatio = msoTrue    '调整图片尺寸之前，锁定图片锁定纵横比
   
2. If rtoW < rtoH Then
   
3.     .ShapeRange.ScaleWidth rtoW, msoFalse, msoScaleFromTopLeft
   
4. Else
   
5.     .ShapeRange.ScaleHeight rtoH, msoFalse, msoScaleFromTopLeft
   
6. End If
   
7. picW = .Width
   
8. picH = .Height

复制代码