Sub ResizePictureKeepAspectRatio()
    Dim shp As InlineShape
    Dim newWidth As Single
    Dim currentHeight As Single
    Dim currentWidth As Single
    Dim aspectRatio As Single
    
    ' 设置新的宽度（单位：厘米）
    newWidth = CentimetersToPoints(4.7)
    
    ' 检查是否有选中的图片
    If Selection.InlineShapes.Count > 0 Then
        Set shp = Selection.InlineShapes(1)
        
        ' 获取当前的高度和宽度（单位：磅）
        currentWidth = shp.Width
        currentHeight = shp.Height
        
        ' 计算纵横比
        aspectRatio = currentHeight / currentWidth
        
        ' 调整图片宽度并保持纵横比
        With shp
            .Width = newWidth
            .Height = newWidth * aspectRatio
        End With
    End If
End Sub