|
楼主 |
发表于 2020-4-3 08:34
|
显示全部楼层
还是不显示哦,附件上传不了,可以麻烦您试一下嘛,感谢
Sub InsertPic()
Dim Arr, i&, k&, n&, pd&
Dim PicName$, PicPath$, FdPath$, shp As Shape
Dim Rng As Range, Cll As Range, Rg As Range, book$
On Error Resume Next
With Application.FileDialog(msoFileDialogFolderPicker) '用户选择图片所在的文件夹
.AllowMultiSelect = False '不允许多选
If .Show Then FdPath = .SelectedItems(1) Else: Exit Sub
End With
If Right(FdPath, 1) <> "\" Then FdPath = FdPath & "\"
Set Rng = Application.InputBox("请选择图片名称所在的单元格区域", Type:=8) '用户选择需要插入图片的名称所在单元格范围
Set Rng = Intersect(Rng.Parent.UsedRange, Rng) 'intersect语句避免用户选择整列单元格,造成无谓运算的情况
If Rng Is Nothing Then MsgBox "选择的单元格范围不存在数据!": Exit Sub
Application.ScreenUpdating = False
Rng.Parent.Select
Arr = Array(".jpg", ".jpeg", ".bmp", ".png", ".gif") '用数组变量记录五种文件格式
For Each Cll In Rng '遍历选择区域的每一个单元格
PicName = Cll.Text '图片名称
If Len(PicName) Then '如果单元格存在值
PicPath = FdPath & PicName '图片路径
pd = 0 'pd变量标记是否找到相关图片
For i = 0 To UBound(Arr) '由于不确定用户的图片格式,因此遍历图片格式
If Len(Dir(PicPath & Arr(i))) Then '如果存在相关文件
'ActiveSheet.Pictures.Insert(PicPath & Arr(i)).Select '插入图片并选中
'Selection.Copy
''Selection.Delete
'ActiveSheet.Pictures.Paste
'ActiveSheet.Pictures.Copy(PicPath & Arr(i)).Select '插入图片并选中
'ActiveSheet.Pictures.Paste(PicPath & Arr(i)).Select '插入图片并选中
'ActiveSheet.Range(PicPath & Arr(i)).Select
' Selection.Cut
' Range(PicPath & Arr(i)).Select
' ActiveSheet.Pictures.Paste.Select
'
'
' Set Selection = ActiveSheet.Shapes.AddShape(msoShapeRectangle, 40, 120, 280, 30)
' ActiveSheet.Shapes.AddPicture PicPath, True, True, Rng.Left, Rng.Top, Rng.Width, Rng.Height
With Selection
ActiveSheet.Shapes.AddPicture PicPath, True, True, Rng.Left, Rng.Top, Rng.Width, Rng.Height
'.ShapeRange.LockAspectRatio = msoFalse '撤销锁定纵横比
'.Top = Cll.Offset(x, y).Top + 5
'.Left = Cll.Offset(x, y).Left + 5
'.Height = Cll.Offset(x, y).Height - 10 '图片高度
'.Width = Cll.Offset(x, y).Width - 10 '图片宽度
End With
pd = 1 '标记找到结果
n = n + 1 '累加找到结果的个数
[a1].Select: Exit For '找到结果后就可以退出文件格式循环
End If
Next
If pd = 0 Then k = k + 1 '如果没找到图片累加个数
End If
Next
MsgBox "共处理成功" & n & "个图片,另有" & k & "个非空单元格未找到对应的图片。"
Application.ScreenUpdating = True
End Sub
文件夹中放图片以表格中1(1)命名就好
|
|