View Single Post
  #10   Report Post  
Posted to microsoft.public.excel.programming
RB Smissaert RB Smissaert is offline
external usenet poster
 
Posts: 2,452
Default set textbox cursor in mouse right-click

OK, got this worked out now:

In the form:

Private Sub MorbtxtReadCodeFrom_MouseDown(ByVal Button As Integer, _
ByVal Shift As Integer, _
ByVal X As Single, _
ByVal Y As Single)
Static btCount As Byte
If Button = 2 Then
If btCount Mod 2 = 0 Then
SendMouseLeftClick
End If
btCount = btCount + 1
End If
End Sub

In a module:

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 Long, ByVal Y As
Long) As Long

Private Declare Sub mouse_event Lib "user32" _
(ByVal dwFlags As Long, _
ByVal dx As Long, _
ByVal dy As Long, _
ByVal cButtons As Long, _
ByVal dwExtraInfo As Long)

Private Const MOUSEEVENTF_MOVE = &H1
Private Const MOUSEEVENTF_LEFTDOWN = &H2
Private Const MOUSEEVENTF_LEFTUP = &H4
Private Const MOUSEEVENTF_RIGHTDOWN = &H8
Private Const MOUSEEVENTF_RIGHTUP = &H10
Private Const MOUSEEVENTF_MIDDLEDOWN = &H20
Private Const MOUSEEVENTF_MIDDLEUP = &H40
Private Const MOUSEEVENTF_ABSOLUTE = &H8000


Sub SendMouseLeftClick(Optional ByVal lX As Long = -1, _
Optional ByVal lY As Long = -1)
'NOTE: lX and lY are assumed to be Screen coordinates
' relative to the uper left corner (0, 0)
'----------------------------------------------------
Dim lFlags As Long
Dim Point As POINTAPI
Dim bReturn As Boolean

'get the mouse cursor position to return to
GetCursorPos Point

'Set cursor position
If lX -1 Then
SetCursorPos lX, lY
bReturn = True
Else
lX = Point.X
lY = Point.Y
End If

DoEvents

'Send the mouse event
lFlags = MOUSEEVENTF_LEFTDOWN Or MOUSEEVENTF_ABSOLUTE
mouse_event lFlags, lX, lY, 0, 0
DoEvents

lFlags = MOUSEEVENTF_LEFTUP Or MOUSEEVENTF_ABSOLUTE
mouse_event lFlags, lX, lY, 0, 0
DoEvents

'return to the old mouse position
If bReturn Then
SetCursorPos Point.X, Point.Y
DoEvents
End If

End Sub


The code that handles the Mouse Up with right button is in a class module,
handling some 100 textboxes.
Only a few of them need the extra mouse left click, so these are handled in
the form.
I am not interested in the right-click selecting a whole word, so that is
fine as it is.


RBS


"RB Smissaert" wrote in message
...
Hi Peter,

Yes, somehow this should be the way to go.
As you say it is a bit fiddly and I haven't got it working properly yet.

RBS

"Peter T" <peter_t@discussions wrote in message
...
PS, I know you said MouseDown but when calling MouseClick the event
appears
to want run three times. Would need to work out more carefully which to
catch and which to abort and flag correctly. I'll leave that to you!

Regards,
Peter T

"Peter T" <peter_t@discussions wrote in message
...
Hi Bart,

This seemed to work for me with no more testing than shown below. Not
sure
about other implications, eg might want to flag and early exit other

Textbox
events.

Private Declare Sub mouse_event Lib "user32" ( _
ByVal dwFlags As Long, ByVal dX As Long, _
ByVal dY As Long, ByVal dwData As Long, _
ByVal dwExtraInfo As Long)

Private Const MOUSEEVENTF_LEFTDOWN = &H2
Private Const MOUSEEVENTF_LEFTUP = &H4
'Dim mbExit As Boolean

Private Sub TextBox1_Mouseup(ByVal Button As Integer, _
ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Static bExit As Boolean

Debug.Print "Button"; Button, "bExit "; bExit

If bExit Then
bExit = False
Debug.Print "Exit Sub"
Debug.Print
Exit Sub
End If

If Button = 2 Then
bExit = True
MouseClick
End If

End Sub

Sub MouseClick()
Debug.Print "MouseClick"

mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0
DoEvents
mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0

End Sub

But this prevents the default right-click to 'select entire word' ?

Regards,
Peter T
"RB Smissaert" wrote in message
...
Is there an easy way to set the cursor in a textbox in the the mouse

down
event when the right mouse button is used?
This is an ordinary textbox in a VBA userform, so I am not sure the
Windows
API can help out here.

RBS