VBA随机将文件夹中的图片插入excel表格指定位置中

langui19

完成后示意效果

利用随机将文件夹中的图片插入excel表格指定位置中。
利用VBA随机将“F:\新建文件夹\意见栏”中的某一个图片插入工作簿“隐蔽工程验收表”中的“空白表”的“验收意见栏”cells(18,4)单元格中。完成后的效果与“隐蔽工程”的示意效果大致一样。

langui19

验收意见应该是确定，一点都不变化，太假。我想把验收意见多写几个版本随机填进去。

mzbao

1. Sub test()
   
2.     Dim myPath$, myFile$, fileArr(), k%, s%, pngPath$
   
3.    
   
4.     myPath = ThisWorkbook.Path & "\意见栏"
   
5.     myFile = Dir(myPath & "*.png")
   
6.     ReDim fileArr(1)
   
7.     Do While myFile <> ""
   
8.        k = k + 1
   
9.        ReDim Preserve fileArr(0 To k - 1)
   
10.        fileArr(k - 1) = myFile
    
11.     myFile = Dir
    
12.     Loop
    
13.     s = Int(Rnd() * k)
    
14.     pngPath = myPath & fileArr(s)
    
15.    
    
16.     Set pic = ThisWorkbook.Worksheets("空白表").Shapes.AddPicture(pngPath, False, True, Range("D18").Left, Range("D18").Top, -1, -1)
    
17.    
    
18. End Sub

复制代码

langui19

mzbao 发表于 2019-3-21 15:36

能不能在excel中弄成宏，传上来。我把代码复制进去，运行有错误  “运行时错误-2147467259(80004005)方法'AddPicture'作用于对象'Shapes'时失败”错误的图片请见最上面的问题。

mzbao

前面代码 myPath = ThisWorkbook.Path & "\意见栏\"  被网站自动吃掉一个"\"，所以不对了。

langui19

mzbao 发表于 2019-3-21 22:33
前面代码 myPath = ThisWorkbook.Path & "\意见栏\"  被网站自动吃掉一个"\"，所以不对了。

收到，非常感谢

langui19

langui19 发表于 2019-3-21 22:39
收到，非常感谢

我换一个工作表插入验收意见，插入的图片总是不对。麻烦帮忙看看。图片应该出现在 "D43"   ,每次插入到其他的位置 大概在"C33"   

Sub 自动插入意见栏图片()

   Dim myPath$, myFile$, fileArr(), k%, s%, pngPath$, gzbmc$, dygmc$

   myPath = "F:\新建文件夹\新建文件夹\意见栏\"     '定义意见栏的图片路径
    myFile = Dir(myPath & "*.png")              '定义意见栏图片名及路径
    gzbmc = "检验批检查记录竖表"              '需填入验收意见的工作表名称
    dygmc = "D43"                       '在cells（d43)单元格中填入验收意见

    '---------------------------插入验收意见-------------------
    ReDim fileArr(1)
    Do While myFile <> ""                  '此循环赋值意见栏里的图片名及路径给数组
       k = k + 1
       ReDim Preserve fileArr(0 To k - 1)
       fileArr(k - 1) = myFile
    myFile = Dir
    Loop
    s = Int(Rnd() * k)    '生成随机数字
    pngPath = myPath & fileArr(s)    '随机的图片名及路径定义给变量
    Set pic = ThisWorkbook.Worksheets(gzbmc).Shapes.AddPicture(pngPath, False, True, Range(dygmc).Left, Range(dygmc).Top, -1, -1)


End Sub

langui19

mzbao 发表于 2019-3-21 22:33
前面代码 myPath = ThisWorkbook.Path & "\意见栏\"  被网站自动吃掉一个"\"，所以不对了。

我换一个工作表插入验收意见，插入的图片总是不对。麻烦帮忙看看。图片应该出现在 "D43"   ,每次插入到其他的位置 大概在"C33"   

Sub 自动插入意见栏图片()

   Dim myPath$, myFile$, fileArr(), k%, s%, pngPath$, gzbmc$, dygmc$

   myPath = "F:\新建文件夹\新建文件夹\意见栏\"     '定义意见栏的图片路径
    myFile = Dir(myPath & "*.png")              '定义意见栏图片名及路径
    gzbmc = "检验批检查记录竖表"              '需填入验收意见的工作表名称
    dygmc = "D43"                       '在cells（d43)单元格中填入验收意见

    '---------------------------插入验收意见-------------------
    ReDim fileArr(1)
    Do While myFile <> ""                  '此循环赋值意见栏里的图片名及路径给数组
       k = k + 1
       ReDim Preserve fileArr(0 To k - 1)
       fileArr(k - 1) = myFile
    myFile = Dir
    Loop
    s = Int(Rnd() * k)    '生成随机数字
    pngPath = myPath & fileArr(s)    '随机的图片名及路径定义给变量
    Set pic = ThisWorkbook.Worksheets(gzbmc).Shapes.AddPicture(pngPath, False, True, Range(dygmc).Left, Range(dygmc).Top, -1, -1)


End Sub

langui19

mzbao 发表于 2019-3-21 22:33
前面代码 myPath = ThisWorkbook.Path & "\意见栏\"  被网站自动吃掉一个"\"，所以不对了。

新表格插入位置不对。
Set pic = ThisWorkbook.Worksheets(gzbmc).Shapes.AddPicture(pngPath, False, True, Range(dygmc).Left, Range(dygmc).Top, -1, -1)其中dygmc="D43"

打开“检验批附表”运行宏时，图片插在C33的位置，打开“检验批检查记录竖表”运行宏时，图片插在D42的位置，不是要求的D44位置；麻烦帮我把代码改一下，顺便将上述语句大致说明一下。