Office中国论坛/Access中国论坛

标题: 批量插入图片并调整大小 [打印本页]
作者: roych    时间: 2011-4-23 19:46
标题: 批量插入图片并调整大小
本帖最后由 roych 于 2016-3-29 09:25 编辑

       其实，这是俺在百度知道里回答的问题（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    时间: 2011-4-24 03:16
大家喜欢的话就下载下来玩玩吧。
作者: joyark    时间: 2011-4-24 03:20
自動把圖片名稱一起寫入更好
作者: joyark    时间: 2011-4-24 03:21
回复 roych 的帖子

如果把,自動把圖片名稱一起寫入更好
作者: roych    时间: 2011-4-24 03:55
joyark 发表于 2011-4-24 03:21
回复 roych 的帖子

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

用fn（文件名字符串）很容易提取文件名的。。。详见更新后的附件。
作者: joyark    时间: 2011-4-24 05:19
回复 roych 的帖子

1.常試過2003可以2007不可以
2.不在f1開始插入圖片,可否在f3開插入圖片
3圖片名e1,可否在e3開始插入
謝謝幫忙,日後工作更方便
作者: 82077802    时间: 2011-4-24 07:10
学习一下
作者: joyark    时间: 2011-4-24 07:37
roych 的帖子
1.常試過2003可以2007不可以
2.不在f1開始插入圖片,可否在f3開插入圖片
3圖片名e1,可否在e3開始插入
謝謝幫忙,日後工作更方便
作者: xie62    时间: 2011-4-24 07:40
学习一下
作者: pureshadow    时间: 2011-4-24 11:59
这个功能用技巧也可以，可惜是的只能在XP系统中操作，所以无法录制GIF了，哭一下~~
作者: roych    时间: 2011-4-24 12:13
回复 joyark 的帖子

1、2003版本部分对象或者方法可能在2007版本里已经没有了（刚刚在2007录制宏后，发现没有相应的代码）。但2007版本可以打开2003版本，如果不希望2007弹出安全信息提示的话，可以处理完后再删除宏，另存文件即可。
2、3将里面的相应的代码修改成：
                    Sheets(1).Range("E" & i+2) = Mid(fn, InStrRev(fn, "\") + 1, InStrRev(fn, ".") - InStrRev(fn, "\"))
                    Sheets(1).Range("F" & i+2).Select
作者: roych    时间: 2011-4-24 12:59
回复 pureshadow 的帖子

截几个屏，写点嘛，小妖姐姐……汉字我还是看得懂滴。
作者: gxy1000    时间: 2011-4-24 14:50
看看学习学习
作者: zww3008    时间: 2011-4-29 23:27
谢谢
作者: pureshadow    时间: 2011-4-30 12:16
回复 roych 的帖子

解决了，Win7和XP有点不同而已。
作者: 余方方    时间: 2011-4-30 12:51
好东西，谢谢分享
作者: wzh    时间: 2011-5-2 19:59
学习学习！
作者: wgh3g    时间: 2011-5-3 21:51
学习
作者: roych    时间: 2011-5-5 15:36
joyark 发表于 2011-4-24 05:19
回复 roych 的帖子

1.常試過2003可以2007不可以

在选中单元格的前提下，Office 2010（俺用的是英文正版，详见视频录像）是可以用滴。如果出现无法对齐的情况，请删除原先所有图片，点选单元格后再点击按钮试试
[attach]45482[/attach]
作者: joyark    时间: 2011-5-5 22:47
問題:
1.能否鼠标指到图片自动放大
2.鼠标在工作表其地方还原图片大小
作者: joyark    时间: 2011-5-5 22:54
回复 roych 的帖子

問題:
1.能否鼠标指到图片自动放大
2.鼠标在工作表其地方还原图片大小
在2010使用非常好用
加上放大功能更完美或在圖片名稱插批註插入圖片
有時間看看謝謝
作者: joyark    时间: 2011-5-5 23:07
本帖最后由 joyark 于 2011-5-5 23:11 编辑

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    恢复
End Sub

Private Sub Worksheet_Activate()    '激活这个工作表时，给每个代码增加宏
    宏
End Sub
Sub 放大()
    Application.ScreenUpdating = False
    恢复
    With Sheet1.Shapes(Application.Caller)
        .ZOrder msoBringToFront
        .Width = 240
        .Height = 150
        .TopLeftCell.RowHeight = 150
    End With
    Application.ScreenUpdating = True
End Sub


Sub 恢复()
    Application.ScreenUpdating = False
    Dim shp As Shape
    For Each shp In Sheet1.Shapes
        With shp
            If .Type = 13 Then
                .Width = 80
                .Height = 50
                .TopLeftCell.RowHeight = 50
            End If
        End With
    Next
    Application.ScreenUpdating = True
End Sub


Sub 宏()
    Dim shp As Shape
    Application.ScreenUpdating = False
    For Each shp In Sheet1.Shapes
        With shp
            If .Type = 13 Then
                .OnAction = "放大"
            End If
        End With
    Next
    Application.ScreenUpdating = True
End Sub

作者: roych    时间: 2011-5-6 22:18
回复 joyark 的帖子

O(∩_∩)O~，你稍稍改改应该就很好了，我就不处理啦。。
作者: joyark    时间: 2011-5-12 22:24
問題:
1.能否插入圖片後(自動使用指定宏)
作者: c101    时间: 2011-5-13 15:51
谢谢分享
作者: 方漠    时间: 2011-5-13 17:19
谢谢分享. 收藏.
N久没上来过了.呵呵
作者: mnwv    时间: 2011-5-30 16:08
很感兴趣，学习一下
作者: nantong718    时间: 2011-6-11 17:43
学习一下呀
作者: caoguangyao    时间: 2011-6-11 18:14
学习,抄下
作者: wuzhanye    时间: 2011-6-14 09:09
不错，谢谢楼主分享
作者: fine88888888    时间: 2011-6-14 09:54
gf看看
作者: annalisa    时间: 2011-7-3 23:27
回复 pureshadow 的帖子

請問怎麼可以從=a1:a4變為顯示內容? 我試了很多次都不成功....謝謝指教
作者: Reywb3M    时间: 2011-7-23 07:40
顶一下吧
作者: mbsky6    时间: 2011-8-3 07:59
学习一下 还有注释 不错的代码 谢谢
作者: starsdust    时间: 2011-9-9 08:37
看看
作者: 冰心8549    时间: 2011-9-16 22:04
学习一下
作者: iamee    时间: 2011-9-25 01:19
谢谢
作者: 轻风    时间: 2011-9-29 14:09
学一下
作者: emile    时间: 2011-10-13 14:33
这个非常有用啊，已经遇到两次麻烦了
作者: augwyc    时间: 2011-10-14 10:33
好好研究一下
作者: Losers    时间: 2011-10-29 16:56
该如何用，详细操作用么
作者: roych    时间: 2011-10-29 19:07
Losers 发表于 2011-10-29 16:56
该如何用，详细操作用么

按下Alt+F8调出宏界面，点击运行即可。以下为2010英文本操作界面：
[attach]47139[/attach]
点击里面的运行（Run）
[attach]47140[/attach]
你可能需要先对VBA有所了解再看这个帖子可能会好些。或者看看小妖在回帖中的Excel技巧。
作者: gzkrmch    时间: 2011-11-24 11:33
谢谢分享
作者: zhengjie    时间: 2011-11-27 09:45
xiazai 学习
作者: 1210600510    时间: 2011-12-21 14:04
1111111111
作者: liuhz2006    时间: 2011-12-25 10:40
下来玩玩吧。
作者: feifeiwuheng    时间: 2012-1-17 08:00
一直在找这个，终于找到了··
作者: feifeiwuheng    时间: 2012-1-17 08:24
请问，怎么让图片成横排的排列呢，名称在图片的下面呢?  谢谢！
作者: roych    时间: 2012-1-17 09:00
feifeiwuheng 发表于 2012-1-17 08:24
请问，怎么让图片成横排的排列呢，名称在图片的下面呢?  谢谢！

类似地，只是把插入位置改改就好了。具体需要看实际需要而定。
作者: efcndi    时间: 2012-1-17 09:44
看看
作者: feifeiwuheng    时间: 2012-1-18 09:13
我不会VBA语言，昨天改了一下，就乱七八糟了，能帮忙改下吗？或者告诉怎么改！谢谢！
作者: feifeiwuheng    时间: 2012-1-18 09:58
就是图片从A1到M1排列，图片名称从A2到M2排列。（13个 图片一排）
第二排图片从A3到M3排，名称从A4到M4。
  谢谢！
作者: wgh3g    时间: 2012-1-18 11:52
收藏了
作者: 无名点水    时间: 2012-2-7 23:34
回复半天也没反应
作者: xiangjm123    时间: 2012-2-25 23:16
谢谢楼主分享，辛苦了。
作者: hlw2008    时间: 2012-3-12 14:23
谢谢，学习中
作者: 小雨饰品    时间: 2012-3-24 01:58
喜欢的话就下载下来玩玩
作者: 小雨饰品    时间: 2012-3-24 02:02
非常 想下载就是下不了
作者: 小雨饰品    时间: 2012-3-24 02:04
谢谢楼主分享，辛苦了。
作者: xsu001    时间: 2012-3-27 21:32
谢谢
作者: 游戏人生    时间: 2012-3-31 22:49
学习一下
作者: accesswj    时间: 2012-3-31 23:45
ookokokokok
作者: 迷城    时间: 2012-4-26 20:55
非常的好
作者: jingan    时间: 2012-4-29 11:34
好东东，学习
作者: xujianxi    时间: 2012-5-24 09:58
正在寻找的资源
作者: umi23    时间: 2012-6-11 10:41
正是喝点是上上
作者: yufong    时间: 2012-6-13 14:42
1.常試過2003可以2007不可以
2.不在f1開始插入圖片,可否在f3開插入圖片
3圖片名e1,可否在e3開始插
作者: zzst2006    时间: 2012-8-9 12:42
学习学习，不知道能不能学会
作者: wufeng980114    时间: 2012-8-24 08:00
好东西啊
作者: m8088    时间: 2012-8-28 09:58
ghfghjkkyulkyulkyu
作者: licho    时间: 2013-3-8 15:39
刚在网上发了类似的主题,不知会被管理员
作者: roych    时间: 2013-3-9 12:48
licho 发表于 2013-3-8 15:39
刚在网上发了类似的主题,不知会被管理员

发布什么主题？广告贴常常是删无赦并禁言的。
作者: cumtlaw    时间: 2013-5-21 15:42
很好的东西。
作者: hnfgcjh    时间: 2013-6-2 04:33
学习一下
作者: hnfgcjh    时间: 2013-6-2 04:34
学习一下
作者: 岭南王子    时间: 2013-6-2 15:39
顶起，看看再说!
作者: huang1314    时间: 2013-6-6 13:42
学习一下
作者: yanwei82123300    时间: 2013-8-5 08:18
谢谢分享
作者: ynjxw    时间: 2014-3-7 17:44
see
作者: MFDXT    时间: 2014-4-8 11:39
能用技巧也可以，可惜是的只能在XP系统中操作
作者: zpy2    时间: 2014-7-7 05:36
不错！！！谢谢了！
作者: yanghua1900363    时间: 2014-9-21 12:42
一睹为快
作者: liumporite    时间: 2014-9-24 15:09
DDDDDDDDDDDDDDDDDDDDDD
作者: lamber    时间: 2015-2-3 15:12
下载看看
作者: utngrihii    时间: 2015-3-7 19:23
玩一下
作者: sophie247_wei    时间: 2015-3-16 15:09
学学学学学
作者: fxdk    时间: 2015-4-12 22:12
迫不及待
作者: 。。。。。。    时间: 2015-5-27 17:11
66666
作者: 凌风飘    时间: 2015-8-1 17:37
不知道是不是自己急需要得
作者: YXH_YXH    时间: 2015-8-3 17:28
多谢分享！！！！！！！！！
作者: ACC学徒    时间: 2015-10-23 21:35
下载下来玩玩
作者: 三毛流浪记    时间: 2015-10-25 14:10
666
作者: declanjun    时间: 2015-12-25 15:50
下载学习下
作者: jin88878    时间: 2015-12-27 13:11
这是我一直在找的，感谢大神
作者: Metoo    时间: 2016-3-1 00:53
刚才正好帮人写了一个

  1. Private Sub tsheet4()

  3.     Dim MyPcName As String
  4.     Dim RG As Range, SP As Shape, i%

  6.     For i = 2 To 5

  8.         Set RG = Cells(i, 3)
  9.         MyPcName = ActiveSheet.Cells(i, 1).Value & ".jpg"

  11.             With ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\111" & MyPcName)

  13.             With .ShapeRange
  14.                 .LockAspectRatio = msoFalse
  15.                 .Width = RG.Width
  16.                 .Height = RG.Height
  17.             End With
  18.             .Placement = xlMoveAndSize
  19.             .Top = RG.Top
  20.             .Left = RG.Left

  22.         End With
  23.         
  24.     Next i

  26. End Sub
复制代码
作者: pwj2009    时间: 2016-4-5 23:59
感谢！分享
作者: 纸鸽    时间: 2016-4-7 16:17
我来看看
作者: 浅痕    时间: 2016-4-9 21:27
kan yi kan
作者: sunwrsun    时间: 2016-5-11 20:10
看看
作者: koutx    时间: 2017-1-6 20:44
图纸插入，调整大小，清晰度等，都是糜麻烦事啊。



欢迎光临 Office中国论坛/Access中国论坛 (http://www.office-cn.net/) Powered by Discuz! X3.3