Excel - Identify Shapes by Content

[trackmike]

You guys have helped me in the past with already solved problems, thank you! This time, however, I haven't been able to find a solution yet.

I have spreadsheets with a number of 16x16 .bmp shapes. Some examples are a red checkmark, a blue checkmark, or a red A with a circle around it. I would like to only delete the checkmarks, while leaving the other shapes intact. Before, the addin we use to insert the shapes would include the file name as alternative text, so I used to use that to differentiate the shapes. However, a software update removed that feature. The shapes are not given identifying names either; just a sequential "Picture 1", "Picture 2", etc. As far as I can tell, Excel does not maintain any information about the source of the shape once it is inserted.

Is there any way I could generate a unique identifier for the different shapes? Some function where, say, running the red checkmark returns "0465", and the red circled A would return "9210", and I could use that identifier to delete only the checkmarks? Or have I missed some method of identifying the source of the .bmp used to insert the shape?

[Kenneth Hobs]

Welcome to the forum!

Attach a file so that we can test. Click the Go Advanced button in lower right of a reply, then the Manage Attachments hyperlink below the reply box, and then Browse and Upload.

[trackmike]

Thanks Kenneth! I've uploaded a test file containing two examples to be deleted, and two examples to keep.

[Paul_Hossler]

I don't think there is any way to reliably tell the shapes apart once they're on the sheet

Maybe by looking upstream and seeing how they're put on the sheet and where they come for, they can be 'tagged' somehow

Please tell us that also

[Kenneth Hobs]

Doing this as-is may be near impossible as Paul said.

You can use this to see if backgroundstyple would help. After a run, view the results in VBE's Immediate window.

Sub Main()  
  Dim s As Shape
  For Each s In ActiveSheet.Shapes
    Debug.Print s.Name,
    'https://msdn.microsoft.com/en-us/library/office/ff862530.aspx
    Debug.Print s.BackgroundStyle
  Next s
End Sub

[trackmike]

The addin used to insert the images is a third-party program, which is password protected and digitally signed. I can circumvent the password, but I cannot make any changes to the vba project without breaking the digital signature, which then breaks other parts of our software suite if the vba project is unsigned. We also have probably several thousand documents created after the change which broke my old sub. I'll give the background style a try tomorrow!

Would it be possible to break a shape down into its pixels (since they're only 16x16), get the hex color of each pixel, and sum them, or something like that?

[Kenneth Hobs]

Getting late so I don't have time to explore post #6. I would start with something like this maybe. http://stackoverflow.com/questions/1...rs-of-an-image

[Paul_Hossler]

Would it be possible to break a shape down into its pixels (since they're only 16x16), get the hex color of each pixel, and sum them, or something like that?

I thought of something similar to that, but again I don't think it'd be reliable: someone could stretch the shape accidently, or for all I know the zoom factor might affect the pixel count

[trackmike]

Okay, I have a semi-solution after following Kenneth's rabbit hole! It works for any zoom level, but resized images do not work. I'm willing to accept a solution that assumes images are not resized. It is a bit slow, taking usually a second or two, but it's much faster than doing it by hand!

I started with the GetPixelColorFromExcelShape module from https://www.mrexcel.com/forum/excel-...-function.html

I then wrote the following (I didn't write the array search myself, I adapted it from some other code I previously found for a related project, but I don't have any source to properly credit I'm afraid):

Sub DeleteAllTickmarks()'
' Keyboard Shortcut: Ctrl+Shift+T
'
    If MsgBox("This will delete ALL Engagement checkmarks in this workbook!" & Chr(10) & "All other tickmarks such as PY, A, or 1 will be left intact." & Chr(10) & "Proceed?", vbYesNo, "Confirm Delete") = vbYes Then
        
        Dim Tickmark As Shape
        Dim wSheet As Worksheet
        Dim ToDelete(2) As String
        
        ToDelete(0) = "42106672"
        ToDelete(1) = "44281002"
        ToDelete(2) = "42111145"
        
        For Each wSheet In ActiveWorkbook.Worksheets
            For Each Tickmark In wSheet.Shapes
                'Determine whether or not to delete
                'MsgBox (GenerateImageID(Tickmark))  'Used to find values to delete
                If IsInArray(CStr(GenerateImageID(Tickmark)), ToDelete) Then
                    Tickmark.Delete
                End If
                
            Next Tickmark
        Next wSheet
    End If
End Sub
Function PixelColor(thisShape As Shape, xyCoord As Integer) As Long
    
    Dim tPt As POINTAPI
    Dim tPicSize As Size
    tPt.x = xyCoord
    tPt.y = xyCoord
    PixelColor = GetPixelColorFromExcelShape(thisShape, tPt, tPicSize)
End Function


Function GenerateImageID(thisShape As Shape) As Long


    Dim shapeSize As Long
    Dim primeNumbers(1 To 16) As Long
    Dim i As Integer
    
    primeNumbers(1) = 1
    primeNumbers(2) = 2
    primeNumbers(3) = 3
    primeNumbers(4) = 5
    primeNumbers(5) = 7
    primeNumbers(6) = 11
    primeNumbers(7) = 13
    primeNumbers(8) = 17
    primeNumbers(9) = 19
    primeNumbers(10) = 23
    primeNumbers(11) = 29
    primeNumbers(12) = 31
    primeNumbers(13) = 37
    primeNumbers(14) = 41
    primeNumbers(15) = 43
    primeNumbers(16) = 47
    
    shapeSize = 16
    GenerateImageID = 0
    
    For i = 1 To 16
        GenerateImageID = GenerateImageID + PixelColor(thisShape, i) / primeNumbers(i)
    Next i
    
End Function
Private Function IsInArray(searchVar As Variant, thisArray As Variant) As Boolean
Dim arrayElement As Variant
On Error GoTo IsInArrayError:
    For Each arrayElement In thisArray
        If arrayElement = searchVar Then
            IsInArray = True
            Exit Function
        End If
    Next arrayElement
Exit Function
IsInArrayError:
On Error GoTo 0
IsInArray = False
End Function

[trackmike]

I have to make one more post so I can post the link to the source code I used!