'选定起始单元格后,按一定行数(1-n)自动往返插入各种格式的图片,
'并在单元格中写入插入图片的名称。
Pf = "ai,"
Pf = Pf &"bmp,bmz"
Pf = Pf &"cdr,cgm,"
Pf = Pf &"dib,dwg,dxf,"
Pf = Pf &"emf,emz,eps,exf,exif,"
Pf = Pf &"fpx,"
Pf = Pf &"gfa,gif,"
Pf = Pf &"hdr,"
Pf = Pf &"ico,"
Pf = Pf &"jfif,jpe,jpeg,jpg,"
Pf = Pf &"pcd,pct,pcx,pcz,pict,png,psd,"
Pf = Pf &"raw,rle,"
Pf = Pf &"svg,"
Pf = Pf &"tga,tif,tiff,"
Pf = Pf &"ufo,"
Pf = Pf &"wdp,wmf,wmz,"
K = InputBox("插入行数,1=按列挿入", "插入行数", 1)
If K = "" Then Exit Sub
Dim Rng As Range: Set Rng = ActiveCell
OpenFile = Application.GetOpenFilename("Picture Files(*.*),*.*", , "打开目标文件夹后选择任一图片即可指定文件夹。或按取消则会将当前文件所在文件夹认作指定文件夹。")
If OpenFile = False Then
myDir = ThisWorkbook.Path &"\"
Else
myDir = Left(OpenFile, InStrRev(OpenFile, "\"))
End If
Filename = Dir(myDir)
Application.ScreenUpdating = False
Do While Filename <>""
If InStr(Pf, LCase(Right(Filename, Len(Filename) - InStrRev(Filename, ".")))) >0 Then
Rng.Cells(1 + n \ K, n Mod K + 1).Select
ActiveCell = Left(Filename, InStrRev(Filename, ".") - 1)
ActiveSheet.Pictures.Insert(myDir &Filename).Select
With Selection
.Placement = xlMoveAndSize
.ShapeRange.LockAspectRatio = msoFalse
.Top = ActiveCell.Top
.Left = ActiveCell.Left
.Height = ActiveCell.Height
.Width = ActiveCell.Width
End With
n = n + 1
End If
Filename = Dir
Loop
Application.ScreenUpdating = True
Rng.Select
End Sub
欢迎分享,转载请注明来源:内存溢出
评论列表(0条)