在工作表中批量插入同一文件夹下图片到单元格中并对准

香川群子

注意，8楼代码已经完全改变思路，效率更高更可靠。
本楼代码可以无视，仅作学习参考用。


Sub PicBatchIn()
    K = InputBox("请输入插入图片换行数，默认10张", "插入图片换行数", 10) '指定插入满10张图片后换行。当然可以根据需要改成k=5或者k=20之类的。
   If K = "" Then K = 1 '如果选择ESC退出输入对话框，则把k值设定为1，即在同一列中按行插入。
   
   Dim r As Range: Set r = ActiveCell  '指定当前单元格为开始插入图片的位置。
   
    OpenFile = Application.GetOpenFilename("Picture Files(*.jpg),*.jpg", , "Get Picture from here!")  '找到目标文件夹，并随便选取一张jpg图片。

    '如果图片格式不是*.jpg，请修改代码，如同下面：
    'OpenFile = Application.GetOpenFilename("Picture Files(*.bmp),*.bmp", , "Get Picture from here!")  '找到目标文件夹，并随便选取一张bmp图片。

    If OpenFile = False Then Exit Sub '如果选择为空或ESC，则结果为错误退出此vba过程。
    Application.ScreenUpdating = False '暂停屏幕刷新
   
    L = InStrRev(OpenFile, "\") '查找最后一个文件夹特定字符\
    myDir = Left(OpenFile, L) '抽取所选文件夹字符，如"D:\Documents\"
    P = Dir(myDir & "*.jpg") '用Dir命令寻找jpg图片。（或改为bmp图片）
  ActiveSheet.Pictures.Insert (myDir & P) '插入第一张图片
   '下面部分代码，是为了找到现在工作表中自动赋值的图片序号
   Dim Shp As Shape
    For Each Shp In ActiveSheet.Shapes '遍历所有工作表中图形
        ShpNm = Shp.Name '得到每个图形的名称
        PicNo = Val(Mid(ShpNm, InStr(ShpNm, " "), Len(ShpNm))) '查找空格并取其后的数值为图片序号。
        If PicNo > m Then m = PicNo '使N变量保持为较大值，直至遍历循环结束，即可找到最大值。
    Next
   
    Do While P <> "" '循环直至结束。
        r.Cells(1 + n \ k, n Mod k + 1).Select '选择将要插入图片的单元格，并按照指定k参数换行
        '即把n除以k以后的整数部分作为换行顺序值，而n对于k的余数部分作为列顺序值。
        If U = 0 Then U = 1 Else ActiveSheet.Pictures.Insert (myDir & P) '除第一张以外，每次插入新图片
            
              ActiveSheet.Shapes.Range("图片 " & m + n).Select '选择刚才插入的图片，已有图片序号m+新插入数n。
        'ActiveSheet.Shapes.Range("Picture " & m + n).Select '在英文版中的代码图片=Picture。
      
        '以下是确定让图片顶部、左侧位置以及图片高、宽对准单元格
      With Selection
            .Top = r.Cells(1 + N \ K, N Mod K + 1).Top
            .Left = r.Cells(1 + N \ K, N Mod K + 1).Left
            .ShapeRange.LockAspectRatio = msoFalse '设置图片格式为高宽不按比例变化。
       .Height = r.Cells(1 + N \ K, N Mod K + 1).Height
            .Width = r.Cells(1 + N \ K, N Mod K + 1).Width
            .Placement = xlMoveAndSize '设置图片格式为跟随单元格大小变化。
        End With
        n = n + 1 '图片序号+1
        P = Dir '用Dir命令继续下一张图片，直至内容为空
    Loop
    Application.ScreenUpdating = True '打开屏幕刷新
    r.Select '回到起始单元格。
End Sub

再次提醒，本代码不如8楼的代码好 ！！！
==========================================

在这里，n \ k 是 int(n/k)的简写。


现在的代码，已经解决了同一工作表中，新插入图片序号不为1的问题。

另外，实际上，如果最初把换行列数的k值定为1的话，
宏运行的结果，就可以变成了在同一列里按行排序插入的结果了……

而如果定义的换行k值大于文件夹中图片数量，当然就变成了在同一行里按列插入的结果了。

If U = 0 Then U = 1 Else ActiveSheet.Pictures.Insert (myDir & P) '除第一张以外，每次插入图片

对上面这句代码解释如下：
If U = 0 Then
     U = 1 ‘处理第一张图片时，不需要再作图片插入，但要做好首件U标记。
Else
     ActiveSheet.Pictures.Insert (myDir & P)      '如果首件U标记已经不为0时则要插入图片
End If

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

lb_bn

谢谢楼主分享经验.

LangQueS

支持

其他参考：（保持图片长宽比并适应单元大小）

★利用有效性信息批量调用信息和图片★        http://club.excelhome.net/thread-529975-1-1.html

香川群子

对1楼代码，做了一些小的改进。

飞云楼主

支持支持

lbl016

原帖由 香川群子 于 2010-9-12 11:22 发表


当然可以，请参考这里。
http://club.excelhome.net/viewth ... p;page=2#pid4215756

如果你自己还不会调整，
那么请你上传你的基本框架的附件，
我可以帮你弄好的。

请香川群子老师帮我写下代码好吗？

lbl016

请香川群子老师帮我写下代码好吗？

jamesjyeh

真是高高手  解决了我的一个大问题
谢谢分享

binhe88888

先做个记号

香川群子

Sub 单元格自动插入图片()
    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(*.*),*.*", , "Get Picture from here!")

    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(Pf, LCase(Right(Filename, Len(Filename) - InStrRev(Filename, ".")))) > 0 Then
            Rng.Cells(1 + n \ K, n Mod K + 1).Select
            ActiveCell = Filename '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-12 09:44 编辑 ]