VBA Fans

Sub InsertImg2003()
    Dim imgWidth As Integer
    Dim fixWidth As Integer
    Dim dRatio As Double
 
    ' 设置图片显示固定宽度
    fixWidth = Cells(2, 2).Width * 5
 
    ' 选择图片插入位置
    Cells(2, 2).Select
    With ActiveSheet.Pictures.Insert("C:\test.jpg")
        ' 获取图片插入后的原始宽度
        imgWidth = .ShapeRange.Width
        ' 获取拉伸比，如果固定显示高度的话用Height属性
        dRatio = fixWidth / imgWidth
        ' Excel2003中设置固定长宽比不起作用
        '.ShapeRange.LockAspectRatio = msoTrue
        ' 调整宽度
        .ShapeRange.ScaleWidth dRatio, msoFalse, msoScaleFromTopLeft
        ' 调整高度
        .ShapeRange.ScaleHeight dRatio, msoFalse, msoScaleFromTopLeft
    End With
End Sub

Sub InsertImg2007()
    Dim imgWidth As Integer
    Dim fixWidth As Integer
    Dim dRatio As Double
 
    ' 设置图片显示固定宽度
    fixWidth = Cells(2, 2).Width * 5
 
    ' 选择图片插入位置
    Cells(2, 2).Select
    With ActiveSheet.Pictures.Insert("C:\test.jpg")
        ' 获取图片插入后的原始宽度
        imgWidth = .ShapeRange.Width
        ' 获取拉伸比，如果固定显示高度的话用Height属性
        dRatio = fixWidth / imgWidth
        ' 设置固定长宽比，默认为True
        .ShapeRange.LockAspectRatio = msoTrue
        ' 调整宽度
        .ShapeRange.ScaleWidth dRatio, msoFalse, msoScaleFromTopLeft
        ' 不需要重复设置高度
        '.ShapeRange.ScaleHeight dRatio, msoFalse, msoScaleFromTopLeft
        ' Excel2007和2003不同，使用代码插入图片的位置并不位于选择的单元格
        .Left = Cells(2, 2).Left
        .Top = Cells(2, 2).Top
    End With
End Sub

Sub InsertImg2010()
    Dim imgWidth As Integer
    Dim fixWidth As Integer
    Dim dRatio As Double
 
    ' 设置图片显示固定宽度
    fixWidth = Cells(2, 2).Width * 5
 
    ' 选择图片插入位置
    Cells(2, 2).Select
    With ActiveSheet.Pictures.Insert("C:\xiugai.jpg")
        ' 获取图片插入后的原始宽度
        imgWidth = .ShapeRange.Width
        ' 获取拉伸比，如果固定显示高度的话用Height属性
        dRatio = fixWidth / imgWidth
        ' 设置固定长宽比，默认为True
        .ShapeRange.LockAspectRatio = msoTrue
        ' 调整宽度
        .ShapeRange.ScaleWidth dRatio, msoFalse, msoScaleFromTopLeft
        ' 不需要重复设置高度
        '.ShapeRange.ScaleHeight dRatio, msoFalse, msoScaleFromTopLeft
        ' Excel2010和2007不同，插入的图片位于当前选择的单元格，不需要设置位置
        '.Left = Cells(2, 2).Left
        '.Top = Cells(2, 2).Top
        ' 复制图片让文件保存的时候包含图片
        .Cut
        ActiveSheet.Pictures.Paste.Select
    End With
End Sub