根据名称批量导入图片制作表单

x1991mm

各位大佬：

      大家好，由于工作内容比较繁琐，就想通过VBA批量制作表单，在论坛里查找批量制作表单的帖子，修改匹配自己的的模板，但是现在表单还缺最后一步，根据名称批量导入图片到表单里，一直没有找到对应的模板，找到的基本是在同一列里批量导入图片，肯请大佬们帮帮忙，非常感谢。
      希望取得的效果：点击生成普通表单按钮根据录入工作表的样品编号查找图片文件夹里的照片导入到普通委托模板的样品照片页R6单元格里，照片高度15cm，照片比例不变，居中放置。
   
                              录入工作表
     
                         普通委托模板工作表
        
      目前的代码如下

1. Sub 普通委托表单生成()
   
2. Dim i, irow As Long: Dim str, fp As String: Dim arr
   
3. 
   
4. Application.DisplayAlerts = False
   
5. Application.ScreenUpdating = False
   
6. t = Timer
   
7. With Application.FileDialog(msoFileDialogFolderPicker) '选择登记卡的保存位置
   
8.         .AllowMultiSelect = False
   
9.         If .Show Then
   
10.             fp = .SelectedItems(1)
    
11.         Else
    
12.             Exit Sub
    
13.         End If
    
14. End With
    
15. 
    
16. fp = fp & "\*.xls*"
    
17. str = Dir(fp)
    
18. 
    
19. 
    
20. With ThisWorkbook.Sheets("录入") '填写录入数据
    
21.     irow = .Cells(Rows.Count, 1).End(xlUp).Row
    
22.     arr = ThisWorkbook.Sheets("录入").Range("a4:ac" & irow)
    
23.     For i = LBound(arr) To UBound(arr)
    
24.         Sheets("普通委托模板").Copy
    
25.         ActiveSheet.Range("c4") = arr(i, 16)
    
26.         ActiveSheet.Range("g4") = arr(i, 1)
    
27.         ActiveSheet.Range("f23") = arr(i, 3)
    
28.         ActiveSheet.Range("l3") = arr(i, 1)
    
29.         ActiveSheet.Range("l4") = arr(i, 2)
    
30.         ActiveSheet.Range("n7") = arr(i, 3)
    
31.         ActiveSheet.Range("n9") = arr(i, 3)
    
32.         ActiveSheet.Range("n11") = arr(i, 3)
    
33.         ActiveSheet.Range("n13") = arr(i, 3)
    
34.         ActiveSheet.Range("n15") = arr(i, 3)
    
35.         ActiveSheet.Range("o3") = arr(i, 4)
    
36.         ActiveSheet.Range("o4") = arr(i, 4)
    
37.         ActiveSheet.Range("s3") = arr(i, 2)
    
38.         ActiveSheet.Range("s4") = arr(i, 7)
    
39.         ActiveSheet.Range("s5") = arr(i, 13)
    
40.         ActiveWorkbook.SaveAs Split(fp, "*")(0) & arr(i, 2) & "_" & arr(i, 7) & ".xls"
    
41.         ActiveWorkbook.Close
    
42.         k = k + 1
    
43.     Next i
    
44. End With
    
45. 
    
46. MsgBox "处理完毕！本次登记卡共" & k & "份。" & "用时：" & Timer - t & "秒"
    
47. 
    
48. Application.DisplayAlerts = True
    
49. Application.ScreenUpdating = True
    
50. End Sub
    

复制代码

批量导入图片制作表单.zip (1.34 MB, 下载次数: 7)

2023-5-31 09:49 上传

点击文件名下载附件
内涵测试图片

     

fanyoulin

x1991mm 发表于 2023-5-31 13:10
zpy2，您好，我看了您回复的帖子，发现不懂的如何修改成适用我模板的代码，不知道能不能麻烦您帮我修改一 ...

插入图片很简单，因为过于简单，所有可能大家觉的你应该会；
图片目录需要留意，注释里有说明；

zpy2

https://club.excelhome.net/forum.php?mod=viewthread&tid=1664098&fromguid=hot&extra=&mobile=

x1991mm

zpy2 发表于 2023-5-31 10:44
https://club.excelhome.net/forum.php?mod=viewthread&tid=1664098&fromguid=hot&extra=&mobile=

zpy2，您好，我看了您回复的帖子，发现不懂的如何修改成适用我模板的代码，不知道能不能麻烦您帮我修改一下，添加批量导入图片的功能。非常感谢。

liulang0808

https://club.excelhome.net/threa ... tml?_dsign=15791c27
插入图片案例，可以参考下凹

x1991mm

fanyoulin 发表于 2023-5-31 13:47
插入图片很简单，因为过于简单，所有可能大家觉的你应该会；
图片目录需要留意，注释里有说明；

fanyoulin，您好，非常感谢，我测试后完全符合预期，因为工作需要才刚学习VBA知识，目前处于牙牙学语阶段，还无法进行片段修改，只懂的改一点参数，如您给的模板导入照片大小为单元格大小，我将它大小改成单元格大小前后左右各缩减一定像素的程度。

x1991mm

liulang0808 发表于 2023-5-31 13:53
https://club.excelhome.net/thread-1441877-1-1.html?_dsign=15791c27
插入图片案例，可以参考下凹

liulang0808，您好，我有看到这个帖子，但研究了很久还是不会修改，fanyoulin刚帮我解决了问题，我也将继续学习，非常感谢您的回复。