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

 

[Andrew Poulsom]

If you assign this macro to your shapes, the name of the shape will be displayed when you click it:

Sub Shape_Click()
    Dim Sh As Shape
    Set Sh = ActiveSheet.Shapes(Application.Caller)
    MsgBox Sh.Name
End Sub

The Sh object contains the Shape.

 

[High Plains Grifter]

Oh wow. That simple! Thanks, Andrew - I shall get to it and see what I can do...


... works a charm, thanks!

There is one downside... I have to remove the hyperlink from each shape so that the click event is triggered (which means that I no longer have a tooltip displaying). that said, you have enabled me to do what I wanted so I definitely should not be complaining - I'll find some way to let people know where they are clicking (the physical location of the point should be enough without the need to see the town name before you even click on it, right? - otherwise why bother having a map, not just a list of town!?) I'll see if I can persuade them to think the same way! If there is some way to make a tooltip show without a hyperlink, I would love to know about it, to save that pain.

Thanks again.
Mark

 

[Andrew Poulsom]

Can't you add text to your shapes with formulas that return what was in the ToolTips?

 

[High Plains Grifter]

Unfortunately not, as the shapes are only small, in order to fit on the map without obscuring it.

 

[Jaafar Tribak]

handling shapes with VBA can be a pain because they do not support any events.... I am thinking maybe you can try creating a small VB script on the fly and tie the script file to the hyperlink .... the script will run everytime the shape is clicked and it will contain the code you have.

 

[Jaafar Tribak]

Hi Mark,

I was intrigued to see a workaround to this problem ie: How can one have a shape with an hyperlink added to it while still running a Macro when clicking on the shape ?

If you are still interested here is a trick to accomplish the task

Workbook Example


Place the following code in the ThisWorkbook module and run the AddShapes Sub :

Option Explicit

Private WithEvents cmb As CommandBars

Private Type POINTAPI
    x As Long
    y As Long
End Type

Private Declare Function GetCursorPos Lib "user32" _
(lpPoint As POINTAPI) As Long

Private Declare Function GetCursor Lib "user32" () As Long

Private Declare Function GetAsyncKeyState Lib "user32" _
(ByVal vKey As Long) As Integer

Private Declare Function GetPixel Lib "gdi32" _
(ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long

Private Declare Function GetDC Lib "user32" _
(ByVal hwnd As Long) As Long

Private Declare Function ReleaseDC Lib "user32" _
(ByVal hwnd As Long, ByVal hdc As Long) As Long

Private Const VK_LBUTTON = &H1

Public Sub AddShapes()
    Call DeleteShapes
    Call CreateShapes
    Set cmb = Application.CommandBars
End Sub

Private Sub cmb_OnUpdate()
    Dim tPt As POINTAPI
    Dim shp As Shape
    Dim hdc As Long
    
    On Error Resume Next
    GetCursorPos tPt
    With ActiveSheet
        For Each shp In .Shapes
            If (shp.AutoShapeType) = msoShapeOval Then
                If Not Intersect(.Range(shp.TopLeftCell.Address & ":" & _
                    shp.BottomRightCell.Address), ActiveWindow.RangeFromPoint(tPt.x, tPt.y)) _
                    Is Nothing Then
                    If Not (ActiveWindow.RangeFromPoint(tPt.x, tPt.y)) Is Nothing Then
                        hdc = GetDC(0)
                        If GetPixel(hdc, tPt.x, tPt.y) = shp.Fill.ForeColor Then
                            ReleaseDC 0, hdc
                            If GetAsyncKeyState(VK_LBUTTON) And 32768 Then
                                Call ShapeMacro(shp)
                                Exit For
                            End If
                        End If
                    End If
                End If
            End If
        Next
    End With
End Sub

Private Sub ShapeMacro(shp As Shape)
    Dim t As Long, l As Long, w As Long, h As Long, Color As Long
    Dim sMsg As String
    
    With shp
        sMsg = "Left: " & .Left & vbCrLf
        sMsg = sMsg & "Top:   " & .Top & vbCrLf
        sMsg = sMsg & "Width: " & .Width & vbCrLf
        sMsg = sMsg & "Height: " & .Height & vbCrLf
        sMsg = sMsg & "Color: " & .Fill.ForeColor.RGB
        MsgBox "You clicked the shape :  " & "'" & .Name & "'" & vbCrLf & vbCrLf & sMsg
    End With
End Sub

Private Sub CreateShapes()
    Dim i As Long
    Dim shp As Shape

    For i = 1 To 20
        Randomize
        Set shp = ActiveSheet.Shapes.AddShape _
        (msoShapeOval, Int((60 - 1 + 1) * Rnd + 1) * 10, _
        Int((40 - 1 + 1) * Rnd + 1) * 10, 30, 30)
        With shp.Fill
            .ForeColor.RGB = _
            RGB(Int(255 - 1 + 1) * Rnd + 1, Int(255 - 1 + 1) * Rnd + 1, _
            Int(255 - 1 + 1) * Rnd + 1)
            .Transparency = 0
            .Solid
        End With
        ActiveSheet.Hyperlinks.Add Anchor:=shp, Address:="", _
        ScreenTip:="This is the shape : " + shp.Name
    Next
End Sub

Private Sub DeleteShapes()
    Dim shp As Shape
    
    For Each shp In ActiveSheet.Shapes
        If (shp.AutoShapeType) = msoShapeOval Then
            shp.Delete
        End If
    Next
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Set cmb = Nothing
End Sub

 

[High Plains Grifter]

Thanks, Jaafar; apologies for no reply over the weekend.

I will have a look at that, but will need to read through and work out what it does first, so there may be another pause before reply (if I can't make it work).

Thanks!
Mark

 

[High Plains Grifter]

Ok, so that works almost perfectly, Jaafar - thanks also!

I have updated everything I can to make the result the same as I desire, but for some reason, the sub cmb_OnUpdate() does not always return the correct shape (e.g. I will click on the shape representing Paris and I will be given results of Abell or Arona - always somewhere beginning with "A", it seems). The problem is that I don't really understand what this sub is doing - here is what I think it seems to be doing; could you let me know if my understanding is wrong anywhere or anything you think might be helpful for me to use it properly?

1. get the position of the mouse pointer at the moment the user clicks on a shape.
2. look at all the possible shapes on the map and check whether they are underneath the cursor
3. if a shape is found that is underneath the cursor, then ?check that the colour is the foreground colour of the shape?
4. If the left mouse button is... ?depressed?
5. THEN the thing under the mouse button must be the shape that we want to return, so do whatever you want with the shape.

This always returns a shape for me to use, but it is not always the correct shape... Is this to do with the fact that there is a relationship implied between the cells and the shapes? I'm getting a little lost with it to be honest...

I'm sorry, I am sure that you gave me a great solution and my own failure to understand is now causing you trouble!

Thanks,
Mark

 

[Jaafar Tribak]

could you let me know if my understanding is wrong anywhere or anything you think might be helpful for me to use it properly?

1. get the position of the mouse pointer at the moment the user clicks on a shape.
2. look at all the possible shapes on the map and check whether they are underneath the cursor
3. if a shape is found that is underneath the cursor, then ?check that the colour is the foreground colour of the shape?
4. If the left mouse button is... ?depressed?
5. THEN the thing under the mouse button must be the shape that we want to return, so do whatever you want with the shape.

Yes that's exactly what the code does ...Does the problem occur when you have two or more shapes very close to each other or superposed AND with the same colour ?
If so, then give each shape a unique forecolor and the issue should be resolved.

If that doesn't address the issue can you upload a workbook example to a file sharing site like (Box.com) and PM the link to me so I can take a look.