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

pauline77

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

香川群子

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

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

5465465465

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

香川群子

原帖由 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

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

5465465465

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

香川群子

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

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

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


请看附件。

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

中国-龙

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

5465465465

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