|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
Sub 批量插入图片成功版()
On Error Resume Next
Dim tmpRge As Range '定义单元格
Set SH = Sheets("Sheet2")
SH.Select
For Each SP In SH.Shapes '删除表中原来所有的图片
SP.Delete
Next
Set FSO = CreateObject("Scripting.FileSystemObject")
ARRGS = Split("BMP,RLE,PNG,JPG,", ",") '//可以增加
For i = 1 To SH.Range("A65536").End(3).Row '//自己确定行数
If SH.Cells(i, 1) = "" Then Exit For
SH.Range("D" & i).Select '选中这个单元格
For X = 0 To UBound(ARRGS)
STR1 = ThisWorkbook.Path & "\" & Trim(SH.Cells(i, 1)) & "." & ARRGS(X)
If FSO.FileExists(STR1) = True Then
SH.Pictures.Insert(STR1).Select
With Selection
.Placement = xlMoveAndSize
.ShapeRange.LockAspectRatio = msoFalse
.Top = ActiveCell.Top + 5
.Left = ActiveCell.Left + 5
.Height = ActiveCell.Height - 10
.Width = ActiveCell.Width - 10
End With
Exit For '//插入后不在寻找文件
End If
Next X
Next i
End Sub
' PATHJPG = ThisWorkbook.Path & "\照片\" & Trim(SH1.Cells(IROW, ICOL).Value) & ".JPG" '//自己将JPG改成PNG
' Set OB_FILE = CreateObject("Scripting.FileSystemObject")
' If OB_FILE.FileExists(PATHJPG) = True Then
' SH1.Range(SH1.Cells(IROW - 6 + X * 2, ICOL - 14).Address).Select '//选中单元格
' SH1.Pictures.Insert(PATHJPG).Select '//选中:插入图片
' With Selection
' .Placement = xlMoveAndSize '//指定对象附加到其下层单元格的方式。
' .ShapeRange.LockAspectRatio = msoFalse '//形状在调整大小时其原始比例保持不变
' .Top = ActiveCell.Top '//上下左右的距离
' .Left = ActiveCell.Left
' .Height = ActiveCell.Height
' .Width = ActiveCell.Width
' End With
' End If
|
|