本帖最后由 阿童木 于 2011-1-11 09:23 编辑
如动画所示,该代码批量导入图片后能够按照原比例缩放以填充单元格
参考代码如下:
- Sub 图片导入()
- '将图片导入。
- '图片按照原比例存储,按照原比例存储
- On Error Resume Next
- Dim R&
- Dim Pic As Object
- '先删除所有可能存在的图片
- For Each Pic In Sheet1.Shapes
- If Pic.Name <> Sheet1.Shapes("按钮 97").Name Then
- Pic.Delete
- End If
- Next
- For R = 2 To Range("A65536").End(xlUp).Row
- '插入图片
- Set Pic = Sheet1.Pictures.Insert(ThisWorkbook.Path & "\pic" & Cells(R, 1) & ".jpg")
- '锁定高宽比
- Pic.ShapeRange.LockAspectRatio = True
- '看高宽比。如果图片高宽比高,那么调整到单元格高度,否则调整到单元格宽度
- '我们看到的右键格式菜单里的东西都是针对ShapeRange而言的,所以要用ShapeRange来设定
- With Pic.ShapeRange
- '如果图片高宽比比单元格大,说明图片太高,只需调整图片高度
- If .Height / .Width > Cells(R, 4).Height / Cells(R, 4).Width Then
- .Height = Cells(R, 4).Height
- '调整位置
- .Top = Cells(R, 4).Top
- .Left = Cells(R, 4).Left + (Cells(R, 4).Width - .Width) / 2
- '如果图片高宽比比单元格小,说明图片太宽,只需调整图片宽度
- Else
- .Width = Cells(R, 4).Width
- '调整位置
- .Left = Cells(R, 4).Left
- .Top = Cells(R, 4).Top + (Cells(R, 4).Height - .Height) / 2
- End If
- End With
- Next R
- End Sub
复制代码
附件下载:
批量导入图片.rar
(295.43 KB, 下载次数: 511)
|