如何遍历图片？

不信这样还重名

求段代码，要求达到功能：如果A2,C2中有图片，则Exit sub,若哪个没有，则在对应的单元格中写上“A2无图片”/“C2无图片",别的单元格中的图别动。
注：表中还有别的图片，这个图片的总数怎么得到呢？如果没有图片总数如何可以遍历所有图片？{:281:}
表格大概样子如下 遍历图片.zip (13.16 KB, 下载次数: 1)

2013-4-12 21:13 上传

点击文件名下载附件

	A	B	C	D	E	F
1		Bitmap
2			Bitmap
3

hwc2ycy

没附件搞什么飞机。

hwc2ycy

1. Sub test()
   
2.     Dim shap As Object
   
3.     For Each shap In ActiveSheet.Shapes
   
4.         Debug.Print shap.Name, shap.TopLeftCell.Address(False, False)
   
5.     Next
   
6. End Sub

复制代码

看立即窗口的输出。

hwc2ycy

1. Sub 宏1()
   
2.     Dim shap As Object
   
3.     Dim pica2 As Boolean
   
4.     Dim picc2 As Boolean
   
5.     For Each shap In ActiveSheet.Shapes
   
6.         Select Case shap.TopLeftCell.Address(False, False)
   
7.             Case "A2": pica2 = True
   
8.             Case "C2": picc2 = True
   
9.         End Select
   
10.         If pica2 And pica2 Then Exit For
    
11.     Next
    
12.     If Not pica2 Then [a2] = "A2无图片"
    
13.     If Not picc2 Then [c2] = "C2无图片"
    
14. End Sub

复制代码

hwc2ycy

要写入的单元格的话，可以用字典来实现。

不信这样还重名

做了一个附件发了上来

hwc2ycy

1. Sub 宏1()
   
2. 
   
3. 
   
4.     If Not isCellHasPic("c2") Then [C2] = "C2无图片"
   
5.     If Not isCellHasPic("a2") Then [a2] = "C2无图片"
   
6. 
   
7. End Sub
   
8. 
   
9. 
   
10. Function isCellHasPic(str As String)
    
11.     On Error Resume Next
    
12.     If Range(str) Is Nothing Then Exit Function
    
13.    
    
14.     If Err.Number <> 0 Then
    
15.         MsgBox "参数无效，非有效的单元格地址"
    
16.         Exit Function
    
17.     End If
    
18.    
    
19.     Dim shap As Shape
    
20. 
    
21.     Dim dic As Object
    
22.     Set dic = CreateObject("scripting.dictionary")
    
23. 
    
24.     For Each shap In ActiveSheet.Shapes
    
25.         dic(shap.TopLeftCell.Address(False, False)) = ""
    
26.     Next
    
27.    
    
28.     If dic.exists(str) Then isCellHasPic = True
    
29.    
    
30. End Function

复制代码

hwc2ycy

1. Sub 宏1()
   
2. 
   
3. 
   
4.     If Not isCellHasPic("A2") Then
   
5.         [c2] = "C2无图片"
   
6.     Else
   
7.         [c2] = ""
   
8.     End If
   
9.         
   
10.     If Not isCellHasPic("A2") Then
    
11.         [a2] = "A2无图片"
    
12.     Else
    
13.         [a2] = ""
    
14.     End If
    
15. 
    
16. End Sub
    
17. 
    
18. 
    
19. Function isCellHasPic(str As String)
    
20.     On Error Resume Next
    
21.     If Range(str) Is Nothing Then Exit Function
    
22.    
    
23.     If Err.Number <> 0 Then
    
24.         MsgBox "参数无效，非有效的单元格地址"
    
25.         Exit Function
    
26.     End If
    
27.    
    
28.     Dim shap As Shape
    
29.     Dim dic As Object
    
30.    
    
31.     Set dic = CreateObject("scripting.dictionary")
    
32. 
    
33.     For Each shap In ActiveSheet.Shapes
    
34.         dic(shap.TopLeftCell.Address(False, False)) = ""
    
35.     Next
    
36.    
    
37.     If dic.exists(UCase(str)) Then isCellHasPic = True
    
38.    
    
39.     Set dic = Nothing
    
40. End Function

复制代码

不信这样还重名

hwc2ycy 发表于 2013-4-12 21:01

呃，终于看懂了，班亲的代码很节省字符{:091:}莫名了半天，总算是懂了，十分感谢{:021:}

hwc2ycy

用最后贴的方法，已经模块化了。
可以大批量的使用。