MouseMove on autoshape rather than form/command button

[steven_francis]

I have spent ages putting together a nice map which changes colour based on performance figures, all put together from autoshapes which currently can be any one of three colours (but could be more). Unfortuantly I have been asked to see if I cant make these have a pop-up showing some top line figures and while I could have a command button hidden in the centre of each map segment with MouseMove Event they are rather strange shapes and I was hoping to use the MouseMove event on the autoshapes themselves but have got no where on this - two questions from this...

Is it possible to map MouseMove onto an autoshape?

If not is it possible to create a form/command button from the autoshape instead? I have tried downloading a few programmes that state they should do this but so far they have not managed to produce anything importable - not sure if this is the version of VB doing something strange (V6.3).

Any ideas would be welcome

Thanks,

Steven

 

[GlennUK]

{snip}

If not is it possible to create a form/command button from the autoshape instead? {snip}

If you right-click your auto-shape, do have a menu option of Assign Macro?

 

[steven_francis]

Unfortunatly the Assign Macro is only for an On Click command as far as I can tell - I did try placing MouseMove in there instead of On Click but it doesn't pick it up. I think I am stuck with getting this to work in this format but as the map is wanted I will have to bodge something together as best I can!
Still the map is pretty and impresses so that will get me some praise...

 

[GlennUK]

Ah, I see. Sorry you couldn't do what you wanted. I'll have a think about this over the weekend in case there's an alternative method.

 

[Greg Truby]

Since I'm not Jafaar or Tom, who could probably actually figure out a way to trap a mouse move on a shape -- I would probably just try making the autoshape a hyperlink to a cell underneath the shape and stuff the "top line numbers" into the screen tip. Not gonna give you a lot of flexibility and I don't know if you can make it more than one line -- but perhaps it's better'n nothing...

 

[erik.van.geit]

Hi, steven_francis
Welcome to the Board !!!!!

This post is meant to provide you some ideas. I'm not sure that it will lead to a solution, but it seems to me it could.
see http://www.allapi.net/apilist/mouse_event.shtml

I've put together some code which is not accurate: I'm missing the point when it comes to recalculate the cursorposition to compare it with the "left" and "top" of the shapes.
It needs to run constantly. Instead of selecting A1 to end the code, you can choose another condition.

STEPS:
add a button to start the Sub "CursorPosition"
add a TextBox ("named TextBox1")

click button and see what happens when you move the mouse

Option Explicit

Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
  
Private Declare Function GetDeviceCaps Lib "gdi32" ( _
  ByVal hDC As Long, ByVal nIndex 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 Type POINTAPI
  x As Long
  y As Long
End Type

Const LOGPIXELSX As Long = 88
Const LOGPIXELSY As Long = 90
Const PointsPerInch = 72
Dim lnghDC As Long
Dim lngCurrentZoom As Long


Sub CursorPosition()
Dim MousePT As POINTAPI
Dim x As Double, y As Double
Dim xA1 As Long, yA1 As Long

    With TopLeftPoint(Range("A1"))
    xA1 = .x
    yA1 = .y
    End With

MsgBox "Just Select A1 to Stop the macro running"

    Do Until ActiveCell.Address = "$A$1"
        GetCursorPos MousePT
        x = (MousePT.x - xA1) / lngCurrentZoom
        y = (MousePT.y - yA1) / lngCurrentZoom
        Application.StatusBar = "X:=" & Format(x, "000") & " Y:=" & Format(y, "000")
        findShape x, y
        DoEvents
    Loop

Application.StatusBar = False

End Sub

Sub findShape(x As Double, y As Double)
Dim shp As Shape
Dim flag As Boolean

    For Each shp In ActiveSheet.Shapes
        With shp
            If _
            x >= shp.Left And _
            x <= shp.Left + shp.Width And _
            y >= shp.Top And _
            y <= shp.Top + shp.Height Then
            ActiveSheet.TextBox1 = shp.Name
            flag = True
            Exit For
            End If
        End With
    Next shp
    
If flag = False Then ActiveSheet.TextBox1 = ""

End Sub


Function TopLeftPoint(rng As Range) As POINTAPI
    lnghDC = GetDC(0)
    lngCurrentZoom = ActiveWindow.Zoom / 100
    With TopLeftPoint
        .x = ActiveWindow.PointsToScreenPixelsX(rng.Left * _
    (GetDeviceCaps(lnghDC, LOGPIXELSX) / PointsPerInch * lngCurrentZoom))
        .y = ActiveWindow.PointsToScreenPixelsY(rng.Top * _
    (GetDeviceCaps(lnghDC, LOGPIXELSY) / PointsPerInch * lngCurrentZoom))
    End With
    ReleaseDC 0, lnghDC
End Function

Surely Rafaaj2000 or RightClick will enhance this, or find another way. Why not throw them a little PM with a link to here (not the question itself: see Boardrules)

kind regards,
Erik

 

[Jaafar Tribak]

Hi,

The Hyperlink tooltip suugestion made by Greg would be the easiest and best solution. However for some reason, unlike cell hyperlinks, the hyperlinks assigned to shapes displayt tooltips in a single line and long texts go off the screen.

Anyway, here is a workbook demo that shows the custom Shape tooltips: http://www.savefile.com/files/1170530


The only drawback of this , is that it uses a timer and the worksheet cannot be edited until the timer is stopped. I tried a Do Loop with the Doevents to avoid using APIs but the performance was worse and the sheet could not be edited either. Apart from this, it worked very smooth on my machine.

Set up required :

1- Place a TextBox (TextBox1) on sheet1 .
2- Place any number of AutoShapes on the same sheet.
3- Add 2 Buttons and assingn to them respectively the StartToolTip and the StopToolTip Procedures.


Code:

Place this in the Workbook Module:

Private Sub Workbook_Open()

    Sheets(1).TextBox1.Visible = False

End Sub

Place this code in the Worksheet Module:

Private Sub TextBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)

    TextBox1.Visible = False

End Sub

Place this code in a Standard Module :

Option Base 1
Option Explicit

Private Declare Function SetTimer Lib "user32" _
(ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, _
ByVal lpTimerFunc As Long) As Long

Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, _
ByVal nIDEvent As Long) As Long

Private lTimerID As Long

Private Type POINTAPI
  X As Long
  Y As Long
End Type

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

Private oToolTip As Object
Private ShapesArr() As String

Sub StartToolTip()

    CreateToolTip Sheets(1)
    GetTargetShapes Sheets(1)
    StartCursorWatch

End Sub

Sub StopToolTip()

    KillTimer 0, lTimerID
    oToolTip.Visible = False

End Sub


Private Sub CreateToolTip(ws As Object)

    Set oToolTip = ws.TextBox1
    oToolTip.Visible = False
    
End Sub

Private Sub GetTargetShapes(ByVal ws As Worksheet)

    Dim oShp As Shape
    Dim i As Byte

    For Each oShp In ws.Shapes
        If oShp.Type = 1 Then
            i = i + 1
            ReDim Preserve ShapesArr(i)
            ShapesArr(i) = oShp.Name
            oShp.OnAction = "Hello"
        End If
    Next

End Sub

Private Sub StartCursorWatch()

    lTimerID = SetTimer(0, 0, 100, AddressOf TimerCallBack)

End Sub

Private Sub TimerCallBack()

    Dim tCurPos As POINTAPI
    Dim oRangeFromPoint As Object
    Dim bFlag As Boolean
    Static oPrev As Object
    
    On Error Resume Next
    GetCursorPos tCurPos
    Set oRangeFromPoint = ActiveWindow.RangeFromPoint(tCurPos.X, tCurPos.Y)
    With oRangeFromPoint
        If TypeName(oRangeFromPoint) <> "Range" Then
            If oPrev.Name <> .Name And .Name <> oToolTip.Name Then
            Set oPrev = oRangeFromPoint
            bFlag = WorksheetFunction.Match(.Name, ShapesArr(), 0) >= 1
                If bFlag Then
                    bFlag = Null
                    FormatAndShowToolTip oToolTip, oRangeFromPoint
                End If
            End If
        ElseIf oToolTip.Visible = True Then
            oToolTip.Visible = False
        Else
            Set oPrev = Nothing
        End If
    End With

End Sub

Private Sub FormatAndShowToolTip(t As Object, ByVal s As Object)

   ' Dim sText As String
    Const sText = "Top line numbers for  "
    Const bRept = 10
    Dim iFarRightColumn As Integer

    With t.Object
        .Text = Application.WorksheetFunction.Rept _
        (sText & s.Name & "... -  ", bRept)
        .MultiLine = True
        .AutoSize = True
        t.Width = 220
        .SpecialEffect = 1 '0
        .BackColor = 12648447
        .WordWrap = True
        .Font.Size = 8
        .BorderStyle = 1
        .Locked = True
        .ForeColor = vbRed
        iFarRightColumn = _
        ActiveWindow.ScrollColumn + _
        ActiveWindow.VisibleRange.Columns.Count
        If iFarRightColumn - s.TopLeftCell.Column <= 5 Then
            t.Left = s.TopLeftCell.Offset(, -2).Left
            t.Top = s.BottomRightCell.Offset(1).Top
        Else
            t.Left = s.BottomRightCell.Offset(1).Left
            t.Top = s.BottomRightCell.Offset(1).Top
        End If
        .Text = Application.WorksheetFunction.Rept _
        (sText & s.Name & "... -  ", bRept)
        t.Visible = True
    End With

End Sub

Private Sub Hello()

    MsgBox "Hello from " & Application.Caller

End Sub

Regards.

 

[erik.van.geit]

As expected ... NICE solution Jaafar.

Sometimes the textbox is too low: (partially invisible). I tried to edit the code a bit (5 minutes), didn't succeed yet, but it shouldn't be too difficult.

have a nice Sunday!
Erik

 

[Jaafar Tribak]

As expected ... NICE solution Jaafar.

Sometimes the textbox is too low: (partially invisible). I tried to edit the code a bit (5 minutes), didn't succeed yet, but it shouldn't be too difficult.

have a nice Sunday!
Erik

Thanks Erik,

The tooltip actually pops up at the bottom edge of the square frame on which the shapes are sitting. If the shape happens to be a rectangle then the tooltip position looks just right . otherwise, for autoshapes with odd shapes, the tooltip may look a bit too far down.

I guess this could be fairly easy to overcome simply by checking the shape of the autoshape before hand in code and displaying the position of the tooltip accordingly.

Regards.

 

[tusharm]

You can create screentips that show up on multiple pages. Insert vbnewline through code as in the proof-of-concept:

Option Explicit

Sub Macro1()
    Dim x As Shape, aStr As String
    Set x = Selection.ShapeRange(1)
    aStr = x.Hyperlink.ScreenTip
    aStr = Left(aStr, Len(aStr) / 2) & vbNewLine & Right(aStr, Len(aStr) - Len(aStr) / 2)
    x.Hyperlink.ScreenTip = aStr
    MsgBox x.Hyperlink.ScreenTip
    End Sub

So, I would use the hyperlink to a cell beneath the shape approach with an appropriate screentip for the hyperlink.

Hi,

The Hyperlink tooltip suugestion made by Greg would be the easiest and best solution. However for some reason, unlike cell hyperlinks, the hyperlinks assigned to shapes displayt tooltips in a single line and long texts go off the screen.
{snip}