如何修改VBA代码实现固定高度、自动宽度插入图片（保持原比例）

修改思路 #

要实现固定高度（80.5）插入图片并保留原宽高比，核心是先获取图片原始宽高比例，再根据固定高度计算对应宽度，最后用计算后的参数插入图片。

修改后的完整代码 #

Sub URLPicturesInsert()
    
    Dim Rng As Range, cell As Range, filename As String
    Dim Pshp As Shape
    Dim aUrls() As String
    Dim i As Long
    Dim originalWidth As Double, originalHeight As Double
    Dim picRatio As Double
    Const FIXED_HEIGHT As Double = 80.5 ' 定义固定高度常量
    
    Application.ScreenUpdating = False
    Set Rng = ActiveSheet.Range("G2:G5")
    
    On Error Resume Next
    
    For Each cell In Rng
        
        If cell.Value <> "" Then
            aUrls = Split(cell.Value, "|")
            
            For i = LBound(aUrls) To UBound(aUrls)
                filename = Trim(aUrls(i))
                
                ' 获取图片原始宽高（缇单位）并转换为Excel使用的磅单位
                With LoadPicture(filename)
                    originalWidth = .Width / 20
                    originalHeight = .Height / 20
                End With
                
                ' 计算宽高比，避免除以0的异常情况
                If originalHeight > 0 Then
                    picRatio = originalWidth / originalHeight
                Else
                    picRatio = 1 ' 异常场景默认1:1比例
                End If
                
                ' 插入图片：用固定高度+计算出的宽度，同时调整横向位置避免重叠
                Set Pshp = ActiveSheet.Shapes.AddPicture( _
                    filename:=filename, _
                    LinkToFile:=msoFalse, _
                    SaveWithDocument:=msoTrue, _
                    Left:=cell.Left + (i * FIXED_HEIGHT * picRatio), _
                    Top:=cell.Top, _
                    Width:=FIXED_HEIGHT * picRatio, _
                    Height:=FIXED_HEIGHT)
    
            Next i
            
            cell.EntireRow.RowHeight = FIXED_HEIGHT
            
            cell.Value = ""
            
        End If
        
    Next cell

Range("G2").Select
Application.ScreenUpdating = True

MsgBox "Process completed successfully", vbInformation, "Success"

End Sub

关键修改说明 #

• 新增FIXED_HEIGHT常量，统一管理固定高度值，后续调整更便捷
• 通过LoadPicture获取图片原始尺寸，转换为Excel默认的磅单位（缇转磅需除以20）
• 计算图片宽高比，基于固定高度推导对应宽度，严格保持原图比例
• 调整图片横向定位参数：原代码固定偏移80.5，现在改为按计算后的宽度偏移，避免不同比例的图片重叠

内容的提问来源于stack exchange，提问作者twelvell