|
|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
分享 Excel 批量图片导入功能，使单元格高度和宽度适应图片。
Excel 批量图片导入功能，很多插件有这个功能，大部分插件的导入功能都是使图片适应单元格的大小，
但是这点可能跟很多人的实际需求不一样，因此我单独写了一个图片导入功能，使单元格适应图片的大小。
代码缺点，需要手工替换代码中的 .png 图片格式为你 自己需要导入的 图片文件格式。
本人水平有限，主要代码依然是在论坛大神的框架上修改的，在此致谢。
花了一周时间搞的代码。
Option Explicit
Sub 导入图片()
Dim wenjian_geshu
Dim lujin
Dim tupian_name
Dim zonghe_bi
Dim hanggao
Dim tishi_kuozhangming
tishi_kuozhangming = MsgBox(vbCrLf & "请确认是否需要 修改 程序代码的 文件扩展名 ？ " & vbCrLf & vbCrLf _
& "点击 “确定” 退出程序，并修改程序扩展名；" & vbCrLf & vbCrLf _
& "点击 “取消” 继续导入图片。" & vbCrLf & vbCrLf _
, vbOKCancel)
If tishi_kuozhangming = vbOK Then Exit Sub
wenjian_geshu = 0
lujin = InputBox("请输入图片文件夹路径，可以贴入路径")
If lujin = "" Then Exit Sub
tupian_name = Dir(lujin & "\*.png", vbNormal)
'.png 格式可以更改为其他格式，用于显示其他格式的图片，
'.png 可以替换为 .* 任意文件格式，但是为了避免 ActiveSheet.Shapes.AddPicture(lujin & "\" & ActiveSheet.Cells(wenjian_geshu, 1).Text & ".png", _ 程序出错，暂时不替换
'但是可以新建不同的工作簿，再导入不同格式的图片后，将表格合并为一张表格。
'不可以在同一工作簿的不同表格中重复执行 代码，即使将 新建分页表 的 名称改为 Sheet1 也不可以，因为本人水平有限不会修改测试了。希望能有大神优化下代码。
Do
If tupian_name = "" Then '输出图片名称 到 第 1 列
Exit Do
End If
wenjian_geshu = wenjian_geshu + 1
ActiveSheet.Cells(wenjian_geshu, 1).Select '方便查看执行到哪一行了
ActiveSheet.Cells(wenjian_geshu, 1) = tupian_name '输出图片名称
Rows(wenjian_geshu).RowHeight = 409 '设置行高为 Excel 的最大值 409
Columns(5).ColumnWidth = 255 '设置列宽为 Excel 的最大值 255
Dim tupian
Set tupian = ActiveSheet.Pictures.Insert(lujin & "\" & ActiveSheet.Cells(wenjian_geshu, 1).Text)
With tupian
.ShapeRange.LockAspectRatio = msoTrue '锁定纵横比
.Placement = xlMoveAndSize '图片大小和位置随单元格的大小和位置而改变。
.Top = ActiveSheet.Cells(wenjian_geshu, 5).Top + 4
.Left = ActiveSheet.Cells(wenjian_geshu, 5).Left + 4 '两行代码设置图片左上角位置，对其单元格，距离单元格边距为 4
zonghe_bi = .Width / .Height '取得图片的 长宽比，以便后续图片的实际高度超过行高的时候，重新设置图片宽度，以保持图片缩小后的长宽比例
Cells(wenjian_geshu, 2) = Int(.Height) + 1
hanggao = Cells(wenjian_geshu, 2) + 3
If hanggao > 409 Then '不超过 409 则就使用上一行代码图片的默认长度
.Height = 403 '超过 EXCEL 最大行高 409，则设置图片 高度为 403，并根据图片纵横比 重新设置图片的长度
.Width = zonghe_bi * .Height ' 根据图片综合比 重新设置图片的长度
Else '不超过 409 则就使用上一行代码图片的默认长度
Rows(wenjian_geshu).RowHeight = hanggao + 6
End If
Cells(wenjian_geshu, 6) = .Width '图片后面的第一列即表格的第六列存储
If wenjian_geshu > 1 Then
If Cells(wenjian_geshu, 6) < Cells(wenjian_geshu - 1, 6) Then Cells(wenjian_geshu, 6) = Cells(wenjian_geshu - 1, 6)
End If
'取得列宽最大值，以便循环结束后设置最大列宽
Cells(wenjian_geshu, 1) = Left(Cells(wenjian_geshu, 1), Len(Cells(wenjian_geshu, 1)) - 4) '重新输出图片名称，去掉扩展名。
Cells(wenjian_geshu, 7) = .Height '在执行 Delete 语句 删除 链接图片之前取得修改后的图片 宽 和 高的数据
Cells(wenjian_geshu, 8) = .Width
.Delete 'Pictures.Insert只能插入图片链接，不能将图片与表格一起保存，
'故 删除图片链接，改用 Shapes.AddPicture 导入图片，使图片与表格同时保存，以上全部代码用来设置行高和列宽，及 设置 取得 图片的 宽 和 高 ，使其适应单元格的 高 和 宽
'.png 格式可以更改为其他格式，用于显示其他格式的图片，
ActiveSheet.Shapes.AddPicture(lujin & "\" & ActiveSheet.Cells(wenjian_geshu, 1).Text & ".png", _
False, _
True, _
ActiveSheet.Cells(wenjian_geshu, 5).Left + 4, _
ActiveSheet.Cells(wenjian_geshu, 5).Top + 4, _
Cells(wenjian_geshu, 8), _
Cells(wenjian_geshu, 7)).Select '在第五列导入图片
Selection.ShapeRange.LockAspectRatio = msoTrue '锁定纵横比
Selection.Placement = xlMoveAndSize '图片大小和位置随单元格的大小和位置而改变。
End With
tupian_name = Dir '再次调用 dir 执行下面的图片的循环操作，不可以有参数，
'此句为整个代码断 最重要的语句，虽然我看不懂，但是直接用吧，有用就好了，知其然而不知其所以然好了。
Loop
Columns("E:E").Select
Selection.ColumnWidth = Int(Cells(wenjian_geshu, 6) / 5.9) '设置列宽为最大图片的列宽，5.9 为图片宽度 与 Excel 表格的宽度比
Columns("A:A").Select
Columns("A:A").EntireColumn.AutoFit
Columns(6).Select
Selection.Delete Shift:=xlToLeft '设置完第 5 列的列宽后，删除存储最大列宽值的 第 6 列
Columns("F:XFD").Select
Selection.ColumnWidth = 8.11
Columns("B:D").Select
Selection.Delete Shift:=xlToLeft
Columns("C:D").Select
Selection.Delete Shift:=xlToLeft
Range("A1").Select
'可以通过删除和插入列 的代码，调整图片名称列 和 图片实际位置列 最终所在的位置列
ActiveSheet.UsedRange.Select '添加边框
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
MsgBox ("图片导入完成！")
Range("A1").Select
End Sub
|
|
/1 
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2016-1-13 22:50
楼主
