Run Macro using shape name when I click on that shape

[High Plains Grifter]

Hello all,

I have written a macro which "plots" points on a map. Each point is a msoShapeOval, and I add a hyperlink to each shape, so that the tooltip can display the name of the location and the score associated with that location.

That's all fine, but I have been asked to add functionality to the map so that when any shape is clicked, a display of (for instance) all the points and scores within 50 miles of the click location is returned. I thought the solution was to use the SheetFollowHyperlink() or FollowHyperlink() event, but neither of these seem to trigger when I click on any of the shapes, although hyperlinks in cells trigger the event. I am new to these events, but is this expected behaviour?

If this is not the way run a macro which takes the shape name as a variable when the user clicks on a shape, is there an alternative? (I would like to keep the tooltips on the shapes if at all possible, which makes the SelectionChange event unusable?)

All suggestions most welcome - thanks for taking the time to read this!
Mark



Here is the code for putting the points on the map.

Sub MapMan()Dim rCell As Range
Dim rRng As Range
Dim ws As Worksheet
'Dim iMAXCount As Integer
Dim iCount As Byte
Dim shp As Object
Dim pic As Object


Set ws = Sheets("All Locations")
Set rRng = Range("Counts")


ws.Unprotect


For Each shp In ws.Shapes
    If shp.Name = "WorldMap" Or shp.Name = "Button 4" Then
            'do nothing
    Else
        shp.Delete
    End If
Next


For Each rCell In rRng
        iCount = Round(rCell.Offset(0, 5).Value / Range("MaxCount").Value * 255, 0)
        Set shp = ws.Shapes.AddShape(msoShapeOval, (rCell.Offset(0, 3).Value * 7.48) - 90, (rCell.Offset(0, 4).Value * -7.48) + 957, 10, 10)
    With shp.Fill
            .ForeColor.RGB = udf_RGB(iCount, iCount, iCount, "Dragon", False)
            '.Transparency = 0.5
            .Transparency = 0
            .Solid
            .Visible = msoTrue
    End With
        shp.Line.Visible = msoFalse
        ws.Hyperlinks.Add Anchor:=shp, Address:="", ScreenTip:="    " + _
            Application.WorksheetFunction.Proper(rCell.Offset(0, -1).Value) + _
            " (" + Str(rCell.Offset(0, 5).Value) + ")"


Next
ws.Protect
End Sub

Function udf_RGB(myR As Byte, myG As Byte, myB As Byte, Optional ColourMap As String = "Black and White", Optional Reverse As Boolean = False) As Long


If Reverse = True Then
    myR = 255 - myR
    myG = 255 - myG
    myB = 255 - myB
Else
    'nothing
End If


Select Case ColourMap
    Case "Black and White"
        udf_RGB = RGB(myR, myG, myB)
    Case "Red"
        udf_RGB = RGB(255, myG, myB)
    Case "Green"
        udf_RGB = RGB(myR, 255, myB)
    Case "Blue"
        udf_RGB = RGB(myR, myG, 255)
    Case "Neon"
        udf_RGB = RGB(Application.WorksheetFunction.Min(255, (255 - myR) * 2), Application.WorksheetFunction.Min(myG * 2, 255), Application.WorksheetFunction.Max(255 - myB, 255 + (myB - 255)))
    Case "Dragon"
        udf_RGB = RGB(255, 255 - myG, 0)
    Case "Hot Coals"
        udf_RGB = RGB(Application.WorksheetFunction.Min(myR * 2, 255), Application.WorksheetFunction.Min(2 * myG, 2 * (255 - myG)), 0)
    Case "Traffic Lights"
        udf_RGB = RGB(Application.WorksheetFunction.Min(255, (255 - myR) * 2), Application.WorksheetFunction.Min(myG * 2, 255), 0)
    Case "Starburst"
        udf_RGB = RGB(Application.WorksheetFunction.Min(myR * 2, 255), Application.WorksheetFunction.Min(myR * 2, (255 - myR) * 2), 0)
End Select
End Function

 

[High Plains Grifter]

Hi Jaafar,

I tried to do that, but you have exceeded your PM space apparently and cannot receive any more..! you must be a busy guy!

 

[High Plains Grifter]

ah, well I guess there's no harm putting it here anyway: https://app.box.com/s/15qrarw58ubw691mo0dl

 

[Jaafar Tribak]

Mark,

The problem you have is what I suspected .... the code returns the wrong shape because the shape is superposed in front of another shape with the same colour.
I understand that you can't give each shape a unique color because that would defeat the purpose of the map.
The only thing I can think of in your scenario is to move the shapes to one side of the screen ( for example: each continent one side ) and then make each shape point to its respective location on the map with an arrow shape ... There would then be enough space between the shapes and the isuue should be resolved - Obviously this would be a tedious task

 

[High Plains Grifter]

Ok, yes, that would be impossibly tedious. Thank you so much for the help in any case - I have learnt quite a lot looking at the way you achieved the solution; it is just a pity that it does not work in this one instance.

Ill go back to the solution without tooltips, but really appreciate your strong attempt to fulfil exactly the request@
Thanks again,
Mark

 

[Jaafar Tribak]

Ill go back to the solution without tooltips, but really appreciate your strong attempt to fulfil exactly the request@
Thanks again,
Mark

Bear in mind that you will still have a problem when attempting to click on some of the shapes which are completely hidden behind other shapes .... forx example: the shape "Los Cristianos" is completely hidden behind the shape "San Miguel" ( both located on the Atlantic ocean )

 

[High Plains Grifter]

I'm not worried about that bit really, the macro that runs when you click on a dot shows everything within x miles, so all the results will be shown. The fact that there is a dot at the location is enough really - it would be nice to have a tooltip to orient the user to what they are seeing, but I can work around it with the results of the click.

Thanks again
Mark