CODEWITHSUNDEEP
vbaexcelactivex
Absinthe
Absinthe

Reputation: 3391

Mouse down event timing

I've been asked to code the ability to click on an image in Excel and add a shape on top of it (it's a body diagram for a physiotherapist, the shape will indicate the site of the patient's pain). My code does this OK by using the mouse down event of an ActiveX image control:

Private Sub bodypic_MouseDown(ByVal Button As Integer, _
ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)

ClickShape x, y

End Sub

Sub ClickShape(x As Single, y As Single)

Dim shp As Shape
Dim cursor As Point

Set shp = ActiveSheet.Shapes.AddShape(msoShapeMathMultiply, x + ActiveSheet.Shapes("bodypic").Left, _
y + ActiveSheet.Shapes("bodypic").Top, 26, 26)

With shp.Fill

    .ForeColor.RGB = RGB(255, 0, 0)
    .BackColor.RGB = RGB(255, 0, 0)

End With

shp.Line.Visible = False

End Sub

The problem is that while the mouse cursor is over the diagram the shape is not visible. Only when the mouse is moved off of the diagram does the shape appear.

I've tried various methods to refresh the screen, selecting a cell, even changing the cursor position via the SetCursor method in Lib user32. Nothing seems to work except for the user actually moving the mouse.

To recreate the issue: insert an ActiveX image control roughly 200 x 500 px, add a jpeg image to the control, add the mouse down code to the worksheet and the click shape code to a module.

Upvotes: 4

Views: 1292

Answers (2)

Variatus
Variatus

Reputation: 14383

I have a limited amount of success with this code:-

Option Explicit

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 SetCursorPos Lib "user32" (ByVal x As Integer, ByVal y As Integer) As Integer

Sub ClickShape(ByVal x As Single, ByVal y As Single)

    Dim Shp As Shape
    Dim Pos As POINTAPI

    GetCursorPos Pos
    SetCursorPos Pos.x + 300, Pos.y
    With ActiveSheet
        With .Shapes("bodypic")
            x = x + .Left
            y = y + .Top
        End With
        Set Shp = .Shapes.AddShape(msoShapeMathMultiply, x, y, 26, 26)
    End With

    With Shp
        .Name = "Mark1"
        .Line.Visible = False
        With .Fill
            .ForeColor.RGB = RGB(255, 0, 0)
            .BackColor.RGB = RGB(255, 0, 0)
        End With
    End With
End Sub

In essence, what it does is to move the cursor out of the image. Then it takes about a second for the mark to appear. The delay will be longer the more marks there are. Note that my movement of 300 pixels is random. You would have to work out where to move it, so long as it is outside the image. I tried moving it back immediately, but that didn't work, and timing the return would be tricky because of the variations in the delay.

I experimented with another concept where I created the mark first and made it invisible. Then, on MouseUp (MouseUp is the more suitable event), I moved the mark and made it visible. That was faster, but it limits you to a single mark or condemns you to a lot of name management. Giving a name to the mark is a leftover from that experiment. Actually, it looked quite nice since I could move the mark by repeatedly clicking on different positions. If you need only one mark I recommend to pursue that idea.

If you need several marks, another leftover from my experiments is the idea to add a feature to delete (or hide) a mark, perhaps on double-click.

Upvotes: 0

Absinthe
Absinthe

Reputation: 3391

This is very hacky but I discovered that hiding and unhiding the image solves the problem:

ActiveSheet.Shapes("bodypic").Visible = False
ActiveSheet.Shapes("bodypic").Visible = True
End Sub

I'd welcome more elegant answers!

Upvotes: 1

Related Questions