EXCEL VBA 导入图片自适应大小

  Sub into_pic()

    On Error Resume Next           '忽略错误继续执行VBA代码,避免出现错误消息

    '图片路径

    pic_url = "d:\我的文档\桌面\"

    '图片所在的列

    pic_column_num = "C"

    '图片宽度

    pic_width = 100

    '图片高度

    pic_height = 100

    '表格宽度

    Range_width = 22

    '表格高度

    Range_Height = 100

    '款号所在起始的列

    k_id_column_start_num = "A"

    '颜色所在起始的列

    k_color_column_start_num = "B"

    '款号所在起始的行

    k_id_column_start_row = 2

    For i = k_id_column_start_row To 65535

    buffer_val = Range(k_id_column_start_num & i).Value

    buffer_color_val = Range(k_color_column_start_num & i).Value

    If buffer_val <> "" Then

    ActiveSheet.Range(pic_column_num & i).Select

    pic_urls = pic_url & "\" & buffer_val & buffer_color_val & ".jpg"

    cColumn = ActiveCell.Column '所在列数

    rRow = ActiveCell.Row '所在行数

    'MsgBox (cColumn)

    'MsgBox (rRow)

    'Rows(i & ":" & i).RowHeight = Range_Height

    'Columns(pic_column_num & ":" & pic_column_num).ColumnWidth = Range_width

    ' With ActiveSheet.Pictures.Insert(pic_urls)

    With Sheets("Sheet1").Pictures.Insert(pic_urls) '可用

    .ShapeRange.LockAspectRatio = msoFalse

    .Placement = xlMoveAndSize

    '.ShapeRange.Top = Selection.Top

    '.ShapeRange.Left = Selection.Left

    .ShapeRange.Left = Range(pic_column_num & i).Left

    .ShapeRange.Top = Range(pic_column_num & i).Top

    '.ShapeRange.Width = pic_width

    '.ShapeRange.Height = pic_height

    '.ShapeRange.Height = Range(pic_column_num & i).Height

    .ShapeRange.Height = Range(pic_column_num & i).Height

    .ShapeRange.Width = Range(pic_column_num & i).Width

    ''''''''''''''''''''''''''

    '  Sub Test()

    '        With Sheets("Sheet1").Pictures.Insert("d:\我的文档\桌面\52058.JPG ") '可用

    '                  .ShapeRange.LockAspectRatio = msoFalse

    '                  .Placement = xlMoveAndSize

    '                  .ShapeRange.Left = Range("b2 ").Left

    '                  .ShapeRange.Top = Range("b2 ").Top

    '                  .ShapeRange.Height = Range("b2:b5 ").Height

    '                  .ShapeRange.Width = Range("b2:c2 ").Width

    '          End With

    '  End Sub

    ''''''''''''''''''''''''''

    End With

    End If

    Next i

    End Sub

    早期的文件代码，不自动缩放

    Sub into_pic()

    On Error Resume Next           '忽略错误继续执行VBA代码,避免出现错误消息

    '图片路径

    pic_url = "d:\我的文档\桌面\mu\pic"

    '图片所在的列

    pic_column_num = "C"

    '图片宽度

    pic_width = 100

    '图片高度

    pic_height = 100

    '表格宽度

    Range_width = 22

    '表格高度

    Range_Height = 100

    '款号所在起始的列

    k_id_column_start_num = "A"

    '颜色所在起始的列

    k_color_column_start_num = "B"

    '款号所在起始的行

    k_id_column_start_row = 2

    For i = k_id_column_start_row To 65535

    buffer_val = Range(k_id_column_start_num & i).Value

    buffer_color_val = Range(k_color_column_start_num & i).Value

    If buffer_val <> "" Then

    ActiveSheet.Range(pic_column_num & i).Select

    pic_urls = pic_url & "\" & buffer_val & buffer_color_val & ".jpg"

    cColumn = ActiveCell.Column

    rRow = ActiveCell.Row

    With ActiveSheet.Pictures.Insert(pic_urls)

    .Top = Selection.Top

    .Left = Selection.Left

    .ShapeRange.LockAspectRatio = msoFalse

    .ShapeRange.Width = pic_width

    .ShapeRange.Height = pic_height

    End With

    Rows(i & ":" & i).RowHeight = Range_Height

    Columns(pic_column_num & ":" & pic_column_num).ColumnWidth = Range_width

    End If

    Next i

    End Sub