Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 25740|回复: 35

[分享] 用VBA批量导入图片并按原比例缩放填充单元格

  [复制链接]
发表于 2011-1-11 09:22 | 显示全部楼层 |阅读模式
本帖最后由 阿童木 于 2011-1-11 09:23 编辑

如动画所示,该代码批量导入图片后能够按照原比例缩放以填充单元格
批量导入图片.gif

参考代码如下:
  1. Sub 图片导入()
  2.     '将图片导入。
  3.     '图片按照原比例存储,按照原比例存储
  4.     On Error Resume Next
  5.     Dim R&
  6.     Dim Pic As Object
  7.     '先删除所有可能存在的图片
  8.     For Each Pic In Sheet1.Shapes
  9.         If Pic.Name <> Sheet1.Shapes("按钮 97").Name Then
  10.             Pic.Delete
  11.         End If
  12.     Next
  13.     For R = 2 To Range("A65536").End(xlUp).Row
  14.         '插入图片
  15.         Set Pic = Sheet1.Pictures.Insert(ThisWorkbook.Path & "\pic" & Cells(R, 1) & ".jpg")
  16.         '锁定高宽比
  17.         Pic.ShapeRange.LockAspectRatio = True
  18.         '看高宽比。如果图片高宽比高,那么调整到单元格高度,否则调整到单元格宽度
  19.         '我们看到的右键格式菜单里的东西都是针对ShapeRange而言的,所以要用ShapeRange来设定
  20.         With Pic.ShapeRange
  21.             '如果图片高宽比比单元格大,说明图片太高,只需调整图片高度
  22.             If .Height / .Width > Cells(R, 4).Height / Cells(R, 4).Width Then
  23.                 .Height = Cells(R, 4).Height
  24.                 '调整位置
  25.                 .Top = Cells(R, 4).Top
  26.                 .Left = Cells(R, 4).Left + (Cells(R, 4).Width - .Width) / 2
  27.             '如果图片高宽比比单元格小,说明图片太宽,只需调整图片宽度
  28.             Else
  29.                 .Width = Cells(R, 4).Width
  30.                 '调整位置
  31.                 .Left = Cells(R, 4).Left
  32.                 .Top = Cells(R, 4).Top + (Cells(R, 4).Height - .Height) / 2
  33.             End If
  34.         End With
  35.     Next R
  36. End Sub
复制代码

附件下载: 批量导入图片.rar (295.43 KB, 下载次数: 511)

评分

参与人数 2 +19 收起 理由
mn860429 + 9 精品文章
过儿 + 10 很不错

查看全部评分

excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
发表于 2011-1-11 09:26 | 显示全部楼层
回复

使用道具 举报

发表于 2011-1-11 09:27 | 显示全部楼层
回复

使用道具 举报

发表于 2011-1-11 09:39 | 显示全部楼层
提示: 作者被禁止或删除 内容自动屏蔽
回复

使用道具 举报

发表于 2011-1-11 09:55 | 显示全部楼层
谢谢楼主,非常感谢!
回复

使用道具 举报

发表于 2011-1-11 10:01 | 显示全部楼层
谢谢 阿童木 分享
回复

使用道具 举报

发表于 2011-1-12 10:39 | 显示全部楼层
学习一下
回复

使用道具 举报

发表于 2011-1-12 12:30 | 显示全部楼层
谢谢分享,非常有用~
回复

使用道具 举报

发表于 2011-1-12 14:16 | 显示全部楼层
学习啊       厉害
回复

使用道具 举报

发表于 2011-1-24 10:17 | 显示全部楼层
我买了!!!!!!!!!!!!!
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-28 22:53 , Processed in 0.899169 second(s), 11 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表