[已解决]通过单元格的值动态的显示图片

yty773436272 · 发表于 2013-4-13 15:18

我有两个存放图片的文件夹：分别是“图片前”和“图片后”，这个两个文件夹内有四个存放不同年份的图片，每个年份图片文件夹内一定会有相同名称的图片名称，如“图片前--2010文件夹内有花这张图片；同样图片后--2010文件夹内也有花这张图片”，我现在想通过“B3”单元格来控制图片文件内的年份，通过“F3”单元格来控制相同年份里相同名称的图片，选择这两个条件后，动态的显示图片，求高手帮忙解决一下

图片文件.zip (809.33 KB, 下载次数: 29)

爱疯 · 发表于 2013-4-13 16:03

根据两个条件，确定某个图片，是吗？

让图片的文件名含有条件，只判断文件名不是方便些吗？

yty773436272 · 发表于 2013-4-13 16:14

爱疯发表于 2013-4-13 16:03
根据两个条件，确定某个图片，是吗？

让图片的文件名含有条件，只判断文件名不是方便些吗？

对，就是根据年份和图片名称来显示图片，因为不同年份的图片它会相同名称的，只有同年份的图片的名称是唯一值

爱疯 · 发表于 2013-4-13 22:02

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$B$3" Or Target.Address = "$F$3" Then
Dim rng As Range, p$, f$, y%, n$, A(), i%
ActiveSheet.Pictures.Delete
p = ThisWorkbook.Path
y = [b3]
n = [f3]
A = Array("图片前", "图片后", "A6", "H6")
'加载图片
For i = 0 To 1
Set rng = Range(A(i + 2))
rng.ClearContents
f = p & "" & A(i) & "" & y & "" & n & ".jpg"
If Dir(f) <> "" Then
ActiveSheet.Shapes.AddPicture Filename:=f, _
LinkToFile:=True, SaveWithDocument:=True, _
Left:=rng.Left, Top:=rng.Top, _
Width:=324, Height:=244
Else
rng = "指定文件不存在"
End If
Next i
End If
End Sub

复制代码

图片文件2.rar (794.75 KB, 下载次数: 30)

yty773436272 · 发表于 2013-4-13 22:54

爱疯发表于 2013-4-13 22:02
根据实际情况再看吧

朋友，当我选定年份时，后面的图片名称能不能只显示该年份的图片名称，如当我选择“2010”时，F3单元格数据有效性内只有“树河，花”这两个选择，现在里面有很多选项，不好找，麻烦朋友帮我改进一下，谢谢啦

爱疯 · 发表于 2013-4-13 22:59

本帖最后由爱疯于 2013-4-13 23:08 编辑

yty773436272 发表于 2013-4-13 22:54
朋友，当我选定年份时，后面的图片名称能不能只显示该年份的图片名称，如当我选择“2010”时，F3单元格数 ...

可不可能，所有图片放到一个文件夹？

每个图片名包括3个部分：前或后 + 年份 + 名称

如前-2011-花.jpg、后-2012-11.jpg等等

yty773436272 · 发表于 2013-4-13 23:13

爱疯发表于 2013-4-13 22:59
可不可能，所有图片放到一个文件夹？

每个图片名包括3个部分：前或后 + 年份 + 名称

那至少也要两个文件夹，图片前和图片后，然后在图片前和图片后内加年份和图片名称，能确定其唯一值，这样也可以，但是当我选择2010时，图片名称单元格只显示2010图片的名称

爱疯 · 发表于 2013-4-13 23:21

yty773436272 发表于 2013-4-13 23:13
那至少也要两个文件夹，图片前和图片后，然后在图片前和图片后内加年份和图片名称，能确定其唯一值，这样 ...

如果按5楼，
图片前路径里有11.jpg
图片后路径里无11.jpg

那F3的菜单里，有没有11.jpg

yty773436272 · 发表于 2013-4-13 23:24

爱疯发表于 2013-4-13 23:21
如果按5楼，
图片前路径里有11.jpg
图片后路径里无11.jpg

有，随便哪个文件夹内有的，另外一个没有也要显示出来，如图片前2010文件夹内有“树河”，图片后内没有，只要选择2010,都显示出来，

爱疯 · 发表于 2013-4-14 00:01

Private Sub Worksheet_Change(ByVal Target As Range)
Dim d As Object
Dim rng As Range
Dim p$, f$, y%, n$, A(), i%
p = ThisWorkbook.Path
y = [b3] '选择年份
n = [f3] '选择名称
A = Array("图片前", "图片后", "A6", "H6")
'可能一：重建数据有效性
If Target.Address = "$B$3" Then
Dim k, t, str$
'收集
Set d = CreateObject("scripting.dictionary")
For i = 0 To 1
f = Dir(p & "" & A(i) & "" & y & "")
Do While f <> ""
Debug.Print f
d(f) = d(f) + 1
f = Dir
Loop
Next i
k = d.keys: t = d.items
'验证
For i = 0 To UBound(t)
If t(i) < 2 Then d.Remove k(i)
Next i
str = Join(d.keys, ",")
'加载
With Range("F3").Validation
.Delete
Application.EnableEvents = False
If str <> "" Then
.Add Type:=xlValidateList, Formula1:=str
Range("F3") = "..."
Else
Range("F3") = "无图片"
End If
Application.EnableEvents = True
End With
End If
'可能二：加载图片
f = ""
If Target.Address = "$F$3" Then
ActiveSheet.Pictures.Delete
For i = 0 To 1
Set rng = Range(A(i + 2))
f = p & "" & A(i) & "" & y & "" & n
ActiveSheet.Shapes.AddPicture Filename:=f, _
LinkToFile:=True, SaveWithDocument:=True, _
Left:=rng.Left, Top:=rng.Top, _
Width:=324, Height:=244
Next i
End If
End Sub

复制代码

图片文件3.rar (795.87 KB, 下载次数: 20)

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