设为首页收藏本站Access中国

Office中国论坛/Access中国论坛

 找回密码
 注册

QQ登录

只需一步,快速开始

返回列表 发新帖
查看: 4576|回复: 5
打印 上一主题 下一主题

excel表中图片引用

[复制链接]
跳转到指定楼层
1#
发表于 2011-6-11 14:11:19 | 只看该作者 回帖奖励 |倒序浏览 |阅读模式
  对这类可以用VBA吗?excel表中图片直接引用
我只有从文件夹中引用图片的一段代码,但是用起来不方便,因为图片还要重命名.现在我需要对已经在excel中的图片再次引用,大小格式什么的一样就行.
附上从文件夹批量导入的代码:
Sub 批量插入图片()
' Dir函数批量获取指定目录下所有文件名和内容
On Error Resume Next
Application.ScreenUpdating = False '关闭屏幕更新
Dim MR As Range
For Each MR In Selection
If Not IsEmpty(MR) And Dir(ActiveWorkbook.Path & "\" & MR.Value & ".jpg") <> "" Then
MR.Select
ML = MR.Left
MT = MR.Top
MW = MR.Width
MH = MR.Height
ActiveSheet.Shapes.AddShape(msoShapeRectangle, ML, MT, MW, MH).Select
Selection.ShapeRange.Fill.UserPicture _
ActiveWorkbook.Path & "\" & MR.Value & ".jpg" '当前文件所在目录下以当前单元内容为名称的.jpg图片
End If
Next
Set MR = Nothing
Application.ScreenUpdating = True '开启屏幕更新
End Sub

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有帐号?注册

x
分享到:  QQ好友和群QQ好友和群 QQ空间QQ空间 腾讯微博腾讯微博 腾讯朋友腾讯朋友
收藏收藏 分享分享 分享淘帖 订阅订阅
2#
发表于 2011-6-11 14:55:07 | 只看该作者
不妨参考以下帖子,也许能符合LZ的要求:
批量插入图片并调整大小
里面有两种做法,一种是代码运行,一种是操作技巧。
3#
 楼主| 发表于 2011-6-11 18:27:13 | 只看该作者
本帖最后由 nantong718 于 2011-6-11 18:30 编辑

回复 roych 的帖子

版主,似乎和我想要的有点出入呀.
一,我的源图片导入后还要裁剪的,不可以直接用;
二,我想引用表中的源图片,源图片那张表当作数据库一样.
4#
发表于 2011-6-15 02:47:35 | 只看该作者

excel表中图片引用 ›

本帖最后由 joyark 于 2011-6-15 03:20 编辑

回复 nantong718 的帖子

參考4樓例子
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count = 1 And Target.Column = 2 And Target.Row > 2 Then
For Each im In ActiveSheet.Pictures
If im.Top = Target(1, 2).Top Then im.Delete: Exit For
Next
pic = ThisWorkbook.Path & "\照片\" & Target & ".jpg"
If Dir(pic) = "" Then Exit Sub
Me.Pictures.Insert(pic).Select '当前文件所在目录下以单元内容为名称的.jpg图片
With Selection
ta = Target(1, 3).MergeArea.Height '(合并)单元高度
tb = Target(1, 3).MergeArea.Width '(合并)单元宽度
tc = .Height '图片高度
td = .Width '图片宽度
tm = Application.WorksheetFunction.Min(ta / tc, tb / td) '单元与图片之间长宽差异比例的最小值
.Height = tc * tm '按比例调整图片宽度
.Width = td * tm '按比例调整图片高度
.Top = Target(1, 3).Top + (ta - .Height) / 2 '垂直居中:
.Left = Target(1, 3).Left + (tb - .Width) / 2 '水平居中:
End With
Target.Select
End If
End Sub



本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有帐号?注册

x
5#
 楼主| 发表于 2011-6-16 19:09:56 | 只看该作者
回复 joyark 的帖子

高手,怎么运行没得反应呢?
6#
发表于 2011-6-16 22:53:09 | 只看该作者
回复 nantong718 的帖子

改動模2或模3
您需要登录后才可以回帖 登录 | 注册

本版积分规则

QQ|站长邮箱|小黑屋|手机版|Office中国/Access中国 ( 粤ICP备10043721号-1 )  

GMT+8, 2024-11-1 07:36 , Processed in 0.079838 second(s), 31 queries .

Powered by Discuz! X3.3

© 2001-2017 Comsenz Inc.

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