vba 如何检查单元格是否有图片？
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/2320826/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
How to check if a cell has a picture?
提问by Kevin Boyd
In Excel, I want to check if a specific cell for instance "C12" has a picture?
How could I do this?
在 Excel 中，我想检查例如“C12”的特定单元格是否有图片？
我怎么能这样做？
回答by GSerg
You do this by looping through Shapes collection of the worksheet, looking for a shape whose .TopLeftCellhas same address as your target range.
为此，您可以循环访问工作表的 Shapes 集合，查找.TopLeftCell地址与目标范围相同的形状。
回答by Dave Ellard
I had a situation where I wanted to delete pictures (In my case charts) from selected cells on a worksheet and leave others in place therefore removing all pictures was not an option. I've left behind some debugging and also some extra code to tell the user what is going on.
我有一种情况，我想从工作表上的选定单元格中删除图片（在我的案例图表中）并将其他单元格留在原地，因此删除所有图片不是一个选项。我留下了一些调试和一些额外的代码来告诉用户发生了什么。
Public Sub RemoveUnWantedGraphs()
Dim shp As Shape
Dim rangeToTest As Range
Dim c As Range
Dim shpList
'Set the rangeToTest variable to the selected cells
Set rangeToTest = Selection
'Loop Over the the selected cells
For Each c In rangeToTest
'Inner loop to iterate over the shapes collection for the activesheet
Set shpList = ActiveSheet.Shapes
For Each shp In shpList
Application.StatusBar = "Analysing:- " + c.Address + " Graphs To Find:- " & shpList.Count
'If the address of the current cell and the address
'of the shape are the same then delete the shape
If c.Address = shp.TopLeftCell.Address Then
Debug.Print "Deleting :- " & shp.Name
shp.Delete
DoEvents
End If
Next shp
Next c
Application.StatusBar = ""
MsgBox "All Shapes In Range Deleted"
End Sub
回答by dprocter
The simplest solution is to create a function that will return 1 if image exists in cell, 0 if it does not. This only works for individual cells and needs modified for multi-cell ranges.
最简单的解决方案是创建一个函数，如果单元格中存在图像，则返回 1，否则返回 0。这仅适用于单个单元格，需要针对多单元格范围进行修改。
Function CellImageCheck(CellToCheck As Range) As Integer
' Return 1 if image exists in cell, 0 if not
Dim wShape As Shape
For Each wShape In ActiveSheet.Shapes
If wShape.TopLeftCell = CellToCheck Then
CellImageCheck = 1
Else
CellImageCheck = 0
End If
Next wShape
End Function
This code can then be run using:
然后可以使用以下代码运行此代码：
Sub testFunction()
If CellImageCheck(Range("B6")) Then
MsgBox "Image exists!"
Else
MsgBox "Image does not exist"
End If
End Sub
回答by Juhi
This is quite an old thread so don't know whether my post will help anybody, but I encountered a similar problem today and after some thinking, derived solution.
这是一个很老的帖子，所以不知道我的帖子是否对任何人有帮助，但我今天遇到了类似的问题，经过一些思考，得出了解决方案。
I have first stored all range addresses where object exists, to an array and then in the second part of the code, checked each cell address in my selected range for the object against each element in array and carried out execution of tagging to an offset cell if array element address matches active cell address in selected range. Hope, it helps. Here is the code:
我首先将对象存在的所有范围地址存储到一个数组中，然后在代码的第二部分中，根据数组中的每个元素检查对象的所选范围中的每个单元格地址，并执行对偏移单元格的标记如果数组元素地址与所选范围内的活动单元格地址匹配。希望能帮助到你。这是代码：
Option Explicit
Sub tagging()
Dim rng As Range, shp As Shape, n As Integer, arr() As String, m As Integer, arrm As Variant
m = 1
n = ActiveSheet.Shapes.Count
ReDim arr(n)
For Each shp In ActiveSheet.Shapes
arr(m) = shp.TopLeftCell.Address
m = m + 1
Next
For Each rng In Selection
m = 1
For Each arrm In arr
If rng.Address = arr(m) Then
rng.Offset(0, 30).Value = "Yes"
Exit For
Else
rng.Offset(0, 30).Value = "No"
End If
If m < n Then
m = m + 1
Else
Exit For
End If
Next
Next
End Sub
回答by Kent Lau
For Each wShape In ActiveSheet.Shapes
If (wShape.Type <> 13) Then wShape.Delete ' If the shape doesn't represent a Picture, ' delete
Next wShape
