[已解决]跪求一个关于图像显示的VBA，本人感激不尽

up5555 · 发表于 2012-11-12 01:04

本帖最后由 up5555 于 2012-11-12 20:36 编辑

我想实现的效果如下：1.单击某单元格显示以单元格内容命名的图片，例如A3单元格里的数据为123，点击它则打开某文件夹下的以123命名的图片。2.图片显示在单元格的右边，鼠标移开A3单元格图片不能消失，点击其他单元格时图片消失，图片不存在也不报错 (注：图片有的很长，一个屏幕不能显示完，需要向下滚动）。3.打开的图片要保持原大小。

本人纯菜鸟，为了实现这个效果我在网上找了10多个小时，都快疯了。。。其实网上也有很多类似的，但它们要么是不能保持原尺寸要么是不能以单元格内容来打开相应的图片。

我传几个例子以供参考吧
1.这个不能以单元格内容打开相应的图片,但可以保持图片的原始大小，这个需要添加一个图像控件才能运行：
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
With Image1
      Select Case ActiveCell.Address(False, False)
         Case "C4"
            P = "DC.JPG"
         Case "E4"
            P = "FG.JPG"
         Case "K5"
            P = "PR.JPG"
         Case Else
            .Visible = False
            Exit Sub
      End Select
      .Picture = LoadPicture(ThisWorkbook.Path & "\pic\" & P)
      .Visible = True
End With
With ActiveCell
      Image1.Top = .Top - Image1.Height / 2
      Image1.Left = .Left + .Width
End With
End Sub
2.这个能以单元格内容打开相应的图片,但不可以保持图片的原始大小：
对象代码：
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Call TuPian(Target, Target.Left + Target.Width + 1, Target.Top)
End Sub
模块代码：
Dim Mypath As String, Mytuname As String, Tudz As String
Dim Mytu As Shape
Dim Myshe As Worksheet

Sub auto_open()
Set Myshe = Worksheets("Sheet1")
Mytuname = "显示图片"
Mypath = ThisWorkbook.Path    '获得工作薄的路径
End Sub

Sub TuPian(ByVal tuS As Range, ByVal tuL As Long, ByVal tuT As Long, _
         Optional ByVal tuW As Long = 300, Optional ByVal tuH As Long = 200)
On Error Resume Next    '如出错,则从出错行下一行开始执行
Set Mytu = Myshe.Shapes(Mytuname)    '设置对象
'MsgBox Err.Number
If Err.Number <> 0 Then '设置对象出错,没有对象
   Set Mytu = Myshe.Shapes.AddShape(msoShapeRectangle, tuL, tuT, tuW, tuH)    '添加图,设置对象
   With Mytu
      .Name = Mytuname    '    '设置对象名称
      .Placement = xlMove '设置对象大小固定,位置随单元格移动
   End With
End If
On Error GoTo 0 ' 关闭错误陷阱。
On Error Resume Next ' 改变错误陷阱。

With Mytu
.Left = tuL    '设置图片左边距
.Top = tuT    '设置图片上边距
.Width = tuW    '设置图片宽度
.Height = tuH    '设置图片高度
.Visible = False    '设置图形隐藏
End With

If tuS.Count = 1 Then '如果单元格不为选定区域
If tuS <> "" Then '如果单元格不为空
Tudz = Mypath & "\" & tuS & ".JPG"    '图片地址
If Dir(Tudz) <> "" Then    '如果该地址文件存在
   Mytu.Fill.UserPicture Tudz    '设置图形填充图片
   Mytu.Visible = True    '设置图形显示
End If
End If
End If
End Sub
望各位高手不吝赐教，本人在此多谢了！

求帮助.rar (74.19 KB, 下载次数: 49)

zjdh · 发表于 2012-11-12 08:08

本帖最后由 zjdh 于 2012-11-12 08:19 编辑

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error Resume Next
If Target = "" Then Exit Sub
P = Target.Value & ".JPG"
ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\图片" & P).Select
With ActiveCell
Selection.Top = .Top + .Height
Selection.Left = .Left
End With
End Sub

复制代码

up5555 · 发表于 2012-11-12 15:49

zjdh 发表于 2012-11-12 08:08

额，这个点了别的单元格后上次打开的不会消失啊，搞得满屏幕都是各种图片，被图片挡住的单元格也点不到了。
求问能否改进改进

zjdh · 发表于 2012-11-12 17:55

看看你1楼的求助！你没说这个要求啊！！

你还说：......图片不能消失！

zjdh · 发表于 2012-11-12 18:25

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error Resume Next
ActiveSheet.Pictures(1).Delete
If Target = "" Then Exit Sub
P = Target.Value & ".JPG"
ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\图片" & P).Select
With ActiveCell
Selection.Top = .Top + .Height
Selection.Left = .Left
End With
End Sub

复制代码

up5555 · 发表于 2012-11-12 20:35

zjdh 发表于 2012-11-12 18:25

额，呵呵。
是我没表达清楚，已经更新了求助内容方便后来人看。唉，月底忙完了弄几本office的书来看看吧，没知识真无奈。。。{:021:}
那个。。。另外。。。能否再麻烦下，我是想把图片显示在单元格的右边，我摆弄了半天都弄不好。

如果是显示在单元格下方应用在我的表格里用起来会很不方便，之前都是用图像控件来弄，可以自定义显示的位置，所以我也不知道会出现这种情况。再次麻烦了。{:301:}

zjdh · 发表于 2012-11-12 21:10

图像控件是会让图片改变大小的，但不会改变比例关系。

zjdh · 发表于 2012-11-12 21:12

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error Resume Next
ActiveSheet.Pictures(1).Delete
If Target = "" Then Exit Sub
P = Target.Value & ".JPG"
ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\图片" & P).Select
With ActiveCell
Selection.Top = .Top + .Height
Selection.Left = .Left + .Width
End With
End Sub

复制代码

up5555 · 发表于 2012-11-12 21:20

zjdh 发表于 2012-11-12 21:12

good，再次感谢！！！
图像控件可以做得比最大的图片还大，这样就不会失真了。

zjdh · 发表于 2012-11-12 21:54

本帖最后由 zjdh 于 2012-11-12 21:58 编辑

那你就用这个吧

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error Resume Next
If Target = "" Then Image1.Visible = False: Exit Sub
P = Target.Value & ".JPG"
With Image1
.Picture = LoadPicture(ThisWorkbook.Path & "\图片" & P)
.Visible = True
End With
With ActiveCell
Image1.Top = .Top + .Height
Image1.Left = .Left + .Width
End With
End Sub

复制代码

		自动登录	找回密码
密码			注册

[已解决]跪求一个关于图像显示的VBA，本人感激不尽

相关帖子