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

香川群子

原帖由 中国-龙 于 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

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

香川群子

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

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

请看附件

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

中国-龙

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

晨曦矇眬

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

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

香川群子

原帖由 晨曦矇眬 于 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 发表
由衷感谢香川群子老师！

您在以上的宏，我试了，有这么几点尚不能满足我的要求（其中红色部分的参数修改我基本琢磨清楚了）请帮助：
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 15:36 编辑 ]

中国-龙

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