批量插入图片并调整大小

roych

       其实，这是俺在百度知道里回答的问题（O(∩_∩)O~，俺凭这个换取了一个百度水晶鼠标送给朋友了）。不过想来对大家有所帮助，就发在这里了。

1. Sub test()
   
2. '定义一个文件对话框以获取文件
   
3. Dim fd As FileDialog
   
4. '定义获取文件名的字符串
   
5. Dim fn As String
   
6. '设置为文件拾取器
   
7. Set fd = Application.FileDialog(msoFileDialogFilePicker)
   
8. With fd
   
9. '定义按钮名称和对话框标题，并设置为允许多重选择以达到批量完成的效果
   
10. .ButtonName = "浏览"
    
11. .Title = "请浏览图片文件"
    
12. .AllowMultiSelect = True
    
13. '清空全部格式，增加图片格式以免用户插入不合法的文件。
    
14. .Filters.Clear
    
15. .Filters.Add "支持的图片文件（*.JPG,*.PNG,*.GIF,*.TIFF,*.JPEG,*.BMP）", "*.JPG,*.PNG,*.GIF,*.TIFF,*.JPEG,*.BMP"
    
16. If .Show = -1 Then
    
17. '选择后，开始计算所选文件个数，并选择F1为图片插入初始单元格。如有需要，请自行改动。
    
18. For i = 1 To .SelectedItems.Count
    
19. fn = .SelectedItems(i)
    
20. Sheets(1).Range("F" & i).Select
    
21. '设置标准横高和列宽。请先插入一张图片，根据实际需要设置。
    
22. Selection.RowHeight = 89.25
    
23. Selection.ColumnWidth = 18.88
    
24. '选择并调整图片位置
    
25. ActiveSheet.Pictures.Insert(fn).Select
    
26. Selection.ShapeRange.IncrementLeft 2
    
27. Selection.ShapeRange.IncrementTop 2
    
28. '取消纵横比，以便设置所有图片大小一致。
    
29. Selection.ShapeRange.LockAspectRatio = 0
    
30. Selection.ShapeRange.Width = 112
    
31. Selection.ShapeRange.Height = 85
    
32. Next
    
33. End If
    
34. End With
    
35. End Sub

复制代码

大家喜欢的话就下载下来玩玩吧。

游客，如果您要查看本帖隐藏内容请回复

应2L的要求，加上了文件名。主要用InstrRev函数和Mid函数，基本就可以截取到文件名字符串了。
-----------------------------------------------------------------------
2016-03-29 更新：
增加2007版本
PS：微软挖了一个大坑。2007版本以上取消了Pictures集合，改为shapes.AddPicutrue了。

joyark

大家喜欢的话就下载下来玩玩吧。

joyark

自動把圖片名稱一起寫入更好

joyark

回复 roych 的帖子

如果把,自動把圖片名稱一起寫入更好

roych

joyark 发表于 2011-4-24 03:21
回复 roych 的帖子

如果把,自動把圖片名稱一起寫入更好

用fn（文件名字符串）很容易提取文件名的。。。详见更新后的附件。

joyark

回复 roych 的帖子

1.常試過2003可以2007不可以
2.不在f1開始插入圖片,可否在f3開插入圖片
3圖片名e1,可否在e3開始插入
謝謝幫忙,日後工作更方便

82077802

学习一下

joyark

roych 的帖子
1.常試過2003可以2007不可以
2.不在f1開始插入圖片,可否在f3開插入圖片
3圖片名e1,可否在e3開始插入
謝謝幫忙,日後工作更方便

xie62

学习一下

pureshadow

这个功能用技巧也可以，可惜是的只能在XP系统中操作，所以无法录制GIF了，哭一下~~