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

香川群子 · 发表于 2010-9-10 15:18

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

帮你修改了专用的代码，
不过，最好还是自己能看懂，以便将来能自己维护。

Sub AutoPicInsert()
Dim Rng As Range

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(*.*),*.*", , "Select a Picture, cancel to use thisworkbook path.")
If OpenFile = False Then
      myDir = ThisWorkbook.Path & "\"
Else
      myDir = Left(OpenFile, InStrRev(OpenFile, "\"))
End If
r = Range("照片").Row - Range("姓名").Row

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)
         On Error Resume Next

         Range("姓名").EntireRow.Find(What:=PicName, After:=Range("姓名"), LookAt:=xlWhole).Activate

         If Err.Number <> 0 Then
            Err.Clear
         Else
            c = ActiveCell.Column Mod 2
            ActiveCell.Offset(r + c, 0).Select
            Set Rng = Selection

            rh = Rng.Height
            rw = Rng.Width

            If Rng(1, 1) <> "" Then GoTo ExtToNext Else Rng(1, 1) = Filename

            ActiveSheet.Pictures.Insert(myDir & Filename).Select
            With Selection
                  .Placement = xlMoveAndSize
                  .ShapeRange.LockAspectRatio = msoFalse
                  ph = .Height
                  pw = .Width
                  tm = rh / ph '高固定
                  'tm = rw / pw '幅固定
                  'tm = IIf(rh / ph < rw / pw, rh / ph, rw / pw) '取高幅比最小
                  .Height = .Height * tm
                  .Width = .Width * tm
                  .Top = Rng.Top + (rh - .Height) / 2
                  .Left = Rng.Left + (rw - .Width) / 2
            End With
         End If
      End If
ExtToNext:
      Filename = Dir
Loop

End Sub

稍后上传附件。

[ 本帖最后由香川群子于 2010-9-10 21:57 编辑 ]

5465465465 · 发表于 2010-9-10 17:05

运行到r = Range("照片").Row - Range("姓名").Row时，提示“方法range作用于对象_global时失败，盼修改！
你真是高手，VAB真是强大，一定要向你好好学习，

香川群子 · 发表于 2010-9-10 21:56

原帖由 5465465465 于 2010-9-10 17:05 发表
运行到r = Range("照片").Row - Range("姓名").Row时，提示“方法range作用于对象_global时失败，盼修改！
你真是高手，VAB真是强大，一定要向你好好学习，

需要事先定义名称：
A1定义为“姓名”，A20定义为“照片”。

请看附件

[ 本帖最后由香川群子于 2010-9-10 21:58 编辑 ]

中国-龙 · 发表于 2010-9-11 14:12

刚才实战了一番，太强了。。。。
下一步真的想跟你学习VBA，请收我徒弟吧。我的QQ：281066463，希望不要嫌弃我。。。。

晨曦矇眬 · 发表于 2010-9-12 12:03

"我还有个要求，比如说有两列(有上千行），第一列是姓名，第二列能不能将按第一列的姓名插入照片（照片以姓名命名），对号入座。谢谢～！"
香川群子老师在五楼编的VBA好像是针对行解决问题的！
按某列插入图片最好可以选择是按A列或是按D列。。。。
麻烦香川群子老师了！

[ 本帖最后由晨曦矇眬于 2010-9-12 14:41 编辑 ]

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

原帖由 晨曦矇眬 于 2010-9-12 12:03 发表
"我还有个要求，比如说有两列(有上千行），第一列是姓名，第二列能不能将按第一列的姓名插入照片（照片以姓名命名），对号入座。谢谢～！"
香川群子老师在五楼编的VBA好像是针对行解决问题的！
按某列插入图片最好 ...

这个应该你自己学会去修改参数。
简化版如下：
红色部分参数自己根据需要修改

Sub AutoPicInsert()
Application.ScreenUpdating = False

'自己修改图片所在文件夹吧。（取消了选择对话框）
myDir = "D:\Backup\我的文档\复件\图片\"
'直接引用jpg格式。(取消了39种格式)
Filename = Dir(myDir & "*.jpg")

Do While Filename <> ""
      PicName = Left(Filename, InStrRev(Filename, ".") - 1)
      On Error Resume Next
      Range("B4").EntireColumn.Find(What:=PicName, After:=Range("B4"), LookAt:=xlWhole, SearchOrder:=xlByColumns).Activate
      '上面这句红色部分自己根据需要修改吧。现在是从B4开始按列搜索图片名称的意思。

      If Err.Number <> 0 Then
         Err.Clear
      Else
         ActiveCell.Offset(0, 4).Select
         If ActiveCell <> "" Then GoTo ExtToNext Else ActiveCell = Filename

         rt = ActiveCell.Top
         rl = ActiveCell.Left
         rh = ActiveCell.Height
         rw = ActiveCell.Width

         ActiveSheet.Pictures.Insert(myDir & Filename).Select
         With Selection
            .Placement = xlMoveAndSize
            .ShapeRange.LockAspectRatio = msoFalse
            ph = .Height
            pw = .Width
            tm = IIf(rh / ph < rw / pw, rh / ph, rw / pw) '取高幅比最小
      .Height = .Height * tm
            .Width = .Width * tm
            .Top = rt + (rh - .Height) / 2
            .Left = rl + (rw - .Width) / 2
         End With
      End If
ExtToNext:
      Filename = Dir
Loop
Range("A1").Select
Application.ScreenUpdating = True
End Sub

请看附件。

================
话说，你的文件单元格位置太小，导入图片后不容易看清楚呢。
大概需要重新设置才好。

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

晨曦矇眬 · 发表于 2010-9-13 12:35

由衷感谢香川群子老师！

香川群子 · 发表于 2010-9-13 21:48

原帖由 晨曦矇眬 于 2010-9-13 12:35 发表
由衷感谢香川群子老师！

您在以上的宏，我试了，有这么几点尚不能满足我的要求（其中红色部分的参数修改我基本琢磨清楚了）请帮助：
1.图片好像只能插入四行就不往下走了。
2.插入的图片，改变图片所在单元格的宽度时，图片会随着单元格的大小而变；但是改变单元格的高度时，图片却没有随之变化。希望达到图片随单元格的高度及宽度同时变化。
多次麻烦，实在抱歉！

回答1：
图片如果只能插入4行，就不走下去了，
我猜测可能的原因是：你在文件中的名称和实际文件夹中符合名称的图片，完全符合的只有4个。

回答2：
我目前的代码，考虑到图片的宽和高度最好和原来的比例保持一致。
所以，改变高度时不能完全跟随变化。

只要把代码改成下面这样就行了。

Sub AutoPicInsert()
Application.ScreenUpdating = False

myDir = "D:\Backup\我的文档\复件\图片\"
Filename = Dir(myDir & "*.jpg")

Do While Filename <> ""
      PicName = Left(Filename, InStrRev(Filename, ".") - 1)
      On Error Resume Next
      Range("B4").EntireColumn.Find(What:=PicName, After:=Range("B4"), LookAt:=xlWhole, SearchOrder:=xlByColumns).Activate

      If Err.Number <> 0 Then
         Err.Clear
      Else
         ActiveCell.Offset(0, 4).Select
         If ActiveCell <> "" Then GoTo ExtToNext Else ActiveCell = Filename
         '上面这句的代码是，如果想要插入图片的单元格是空单元格，就插入图片，并写入图片名称。
   '而如果已经写入了图片文件名称内容，vba则判断该图片文件已经被用过，不需要重复插入图片。

   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
      End If
ExtToNext:
      Filename = Dir
Loop
Range("A1").Select
Application.ScreenUpdating = True
End Sub

晨曦矇眬 · 发表于 2010-9-14 08:50

感谢香川老师的热情帮助，问题完全解决！
现在插入的图片完全与单元格的大小变化同步了！

[ 本帖最后由晨曦矇眬于 2010-9-14 15:36 编辑 ]

中国-龙 · 发表于 2010-9-14 19:02

现在用起来真是爽极了。。。。
这两天好好的在研究这段代码，只是苦于基础差，没搞的太明白。。。。
还烦请香川教师能不能在代码后面加些简单的注释。。。。万分感谢

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

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

感谢

收个徒弟吧！

问题解决，感谢香川群子老师！

评分

感谢香川老师的热情帮助，问题完全解决！

感谢香川教师的热情帮助