请问如何批量插入图片呢？

pauline77 · 发表于 2010-8-7 11:33

就是怎么样才能要把几十张图片插入同一列或同一行，图片的尺寸要保持一致，且正好填满一个单元格？麻烦各位解答，谢谢了！

香川群子 · 发表于 2010-8-7 14:56

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

[ 本帖最后由香川群子于 2010-9-9 19:39 编辑 ]

lhx120824 · 发表于 2010-8-7 19:32

真该好好学学vba。功能太强大了。

5465465465 · 发表于 2010-9-8 11:15

试验了一下，确实很好用，高手。。。。。但我还有个要求，比如说有两行，第一行是姓名，第二行能不能将按第一行的姓名插入照片（照片以姓名命名），对号入座。谢谢～！

香川群子 · 发表于 2010-9-8 15:21

原帖由 5465465465 于 2010-9-8 11:15 发表
试验了一下，确实很好用，高手。。。。。但我还有个要求，比如说有两行，第一行是姓名，第二行能不能将按第一行的姓名插入照片（照片以姓名命名），对号入座。谢谢～！

Sub 选择范围后按姓名插入照片()
Dim Rng As Range
Set Rng = Selection

k = MsgBox("Yes=按姓名行下插入，No=按姓名列右挿入,Cancel=直接覆盖插入", vbYesNoCancel)
If k = vbYes Then
      r = 1: c = 0
ElseIf k = vbNo Then
      r = 0: c = 1
Else
      r = 0: c = 0
End If

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,"
Picformat = Pf & "wdp,wmf,wmz,"

OpenFile = Application.GetOpenFilename("Picture Files(*.*),*.*", , "打开目标文件夹后选择任一图片即可指定文件夹。或按取消则会将当前文件所在文件夹认作指定文件夹。")
If OpenFile = False Then
      myDir = ThisWorkbook.Path & "\"
Else
      myDir = Left(OpenFile, InStrRev(OpenFile, "\"))
End If

Application.ScreenUpdating = False

Filename = Dir(myDir)

Do While Filename <> ""
      If InStr(Picformat, LCase(Right(Filename, Len(Filename) - InStrRev(Filename, ".")))) > 0 Then
         PicName = Left(Filename, InStrRev(Filename, ".") - 1)
         Rng.Select
         On Error Resume Next
         Selection.Find(What:=PicName, After:=ActiveCell,LookAt:=xlWhole).Activate

         If Err.Number <> 0 Then
            Err.Clear
         Else
            ActiveSheet.Pictures.Insert(myDir & Filename).Select
            With Selection
                  .Placement = xlMoveAndSize
                  .ShapeRange.LockAspectRatio = msoFalse
                  .Top = ActiveCell.Offset(r, c).Top
                  .Left = ActiveCell.Offset(r, c).Left
                  .Height = ActiveCell.Offset(r, c).Height
                  .Width = ActiveCell.Offset(r, c).Width
            End With
         End If

      End If
      Filename = Dir
Loop
Rng.Select

End Sub

[ 本帖最后由香川群子于 2010-9-9 18:28 编辑 ]

5465465465 · 发表于 2010-9-9 16:37

本想没人回贴呢，太激动了。。。｜
我的问题是这样的:我有100个人，第一行是姓名，第二行要从指定文件夹中插入相应的图片。就是做个判断，某人对应插入其照片。

5465465465 · 发表于 2010-9-9 16:49

我录制了一个宏，为什么出现错误呢？万分感谢了

香川群子 · 发表于 2010-9-9 19:33

原帖由 5465465465 于 2010-9-9 16:49 发表
我录制了一个宏，为什么出现错误呢？万分感谢了

因为我原来的宏代码，没有考虑到插入图片后的图片序号增加，因此反复使用时会出错。
现在已经改为直接选择刚插入的图片，进行处理。所以问题已经解决了。

实际上5楼代码就是专为你的要求设计的。

请看附件。

[ 本帖最后由香川群子于 2010-9-9 19:35 编辑 ]

中国-龙 · 发表于 2010-9-9 22:39

非常感谢香川群子对我无私的帮助，谢谢了！
其实这项工作困扰我很长时间了，只因水平太低，想弄，却一直弄不好。现在合盘提出，希望您在百忙之中给予指点迷津。

5465465465 · 发表于 2010-9-10 11:26

中国-龙就是我，昨晚回家，用户名和密码忘了

		自动登录	找回密码
密码			免费注册

请问如何批量插入图片呢？

使用vba批量导入同一文件夹下的图片，并按列排序放置，大小对准单元格。

再请教个问题

这样试试看

感谢

再请教个问题

终极提问

说明