VBA 选取图片

chunyanghua2002

各位大拿： 下面的这个程序 我想  "打开目标文件夹后选择任一图片即可指定文件夹 选定多个图片。或按取消则会将当前文件所在文件夹认作指定文件夹，但可以选择多个图片。" 如何修改？我的目的是打开文件夹时候，可以选择性的插入图片，而不是插入此文件夹的全部图片，谢谢指教！！ Sub 单元格自动插入图片()     '选定起始单元格后，按一定行数(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