Mouse button auto-repeat

1 of 2 < >

New Sub-Forum

In an effort to help make sure there are appropriate categories for topics of discussion that are happening, there is now a sub-forum for databases and database programming under Special Interest groups. Please direct questions, etc., about this topic to that sub-forum moving forward. Thank you.

2 of 2 < >

Forum Guidelines

This forum is for finished source code that is working properly. If you have questions about this or any other source code, please post it in one of the Discussion Forums, not here.

See less

Mark Hunter

Member

Join Date: Feb 2001
Posts: 1966

21 Nov 2007, 12:31 AM

Code:

' Compiler:  PBCC 4.04 
' (Should work with PBWIN with minor modifications.)
'
' This program shows how to create a thread so that
' holding down a mouse button in a graphic window gives
' an auto-repeat click.
'
' The mouse is integrated with the keyboard:  a mouse click
' inserts a code into the same buffer as the keyboard.

 #Dim All
 #Console Off
'-----------------------------------------------------------------

 Macro False     = 0
 Macro True      = -1
 Macro Boolean   = Long
'-----------------------------------------------------------------

 'From WinAPI
 %WM_KEYDOWN    = &H100
 %WM_KEYUP      = &H101
 %GWL_WNDPROC   = -4

 %VK_OEM_COMMA  = &HBC
 %VK_OEM_PERIOD = &HBE

 %WM_NCHITTEST     = &H084
 %HTTRANSPARENT    = -1
 %WM_LBUTTONDOWN   = &H201
 %WM_RBUTTONDOWN   = &H204
 %WM_LBUTTONUP     = &H202
 %WM_RBUTTONUP     = &H205
 %GW_CHILD         = 5
 %HTCLIENT         = 1

 Declare Function GetWindow      Lib "USER32.DLL" Alias "GetWindow" (ByVal Wnd As Dword, ByVal wCmd As Dword) As Long
 Declare Function CallWindowProc Lib "USER32.DLL" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Dword, ByVal Wnd As Dword, ByVal uMsg As Dword, ByVal param As Dword, ByVal mousepos As Long) As Long
 Declare Function SetWindowLong  Lib "USER32.DLL" Alias "SetWindowLongA" (ByVal Wnd As Dword, ByVal nIndex As Long, ByVal lNewLong As Long) As Long
'=================================================================

 %esc   = 27             ' ascii keycode for escape key
 %LT = %VK_OEM_COMMA     ' <
 %GT = %VK_OEM_PERIOD    ' >

 %leftbutton  =  1       'arbitrary whichbutton values
 %rightbutton = -1
 %nobutton    =  0
'-----------------------------------------------------------------

 Declare Function GWnew(ByVal Dword, ByVal Dword, ByVal Dword, ByVal Long) As Long
 Declare Function InStat1 As Long
 Declare Function InKey1 As Long
 Declare Sub StuffKey(ByVal Long)
 Declare Sub Getkey
 Declare Function ButtonThread(ByVal Dword) As Dword
 Declare Sub MouseClick(ByVal Long)
'-----------------------------------------------------------------

 Global GW, GWold As Dword   'handles
 Global win1 As Dword        'handle for window
 Global ky As Long           'keycode
 Global keybuff() As Long    'keycode buffer
 Global nkey As Long         'number of keys in keycode buffer
 Global whichbutton As Long  'which mouse button
 Global BTcalled As Boolean  'thread called?
 Global Xmouse, Ymouse As Long   '(not used in this example code)
'-----------------------------------------------------------------

 Sub Stuffkey(ByVal ky As Long)        'add keycode to buffer
  keybuff(nkey) = ky
  Incr nkey
 End Sub

 Function InStat1 As Boolean           'key waiting?
  Function = (nkey <> 0)
 End Function

 Function InKey1 As Long               'the key
  If nkey Then
   Decr nkey
   Function = keybuff(nkey)
  End If
 End Function

 Sub GetKey                            'get the key
  Dim count As Long                    'sleep 0 once every few iterations
  Do Until InStat1
   Incr count
   If count = 3 Then
    count = 0
    Sleep 0
   End If
  Loop
  ky = InKey1
 End Sub
'-----------------------------------------------------------------

 Sub MouseClick(ByVal whichbutton As Boolean)
  If whichbutton = %leftbutton Then
   Stuffkey %LT
  Else            '%rightbutton
   Stuffkey %GT
  End If
 End Sub
'-----------------------------------------------------------------

' On first button down, reset clock, set flag.
' Have a thread that checks flag and clock.  If down
' for more than threshold, begin repeated calls to mouseclick.
' On button up, reset flag.
' The thread checks flag, if reset stops calls to mouseclick.
' Button down must record mouse position for auto-repeat
' Asume no more than one shift key at a time

 Function GWnew (ByVal Wnd As Dword, ByVal Msg As Dword, ByVal param As Dword, ByVal mousepos As Long) As Long
   Local result As Long

   result = CallWindowProc (GWold, Wnd, Msg, param, mousepos)

   Select Case Long Msg
   Case %WM_NCHITTEST
    If result = %HTTRANSPARENT Then result = %HTCLIENT

   Case %WM_LBUTTONDOWN
    whichbutton = %leftbutton
    BTcalled = False
    Xmouse = Lo(Word,mousepos) :Ymouse = Hi(Word,mousepos)
   Case %WM_LBUTTONUP
    whichbutton = %nobutton
    Xmouse = Lo(Word,mousepos) :Ymouse = Hi(Word,mousepos)
    MouseClick %leftbutton

   Case %WM_RBUTTONDOWN
    whichbutton = %rightbutton
    BTcalled = False
    Xmouse = Lo(Word,mousepos) :Ymouse = Hi(Word,mousepos)
   Case %WM_RBUTTONUP
    whichbutton = %nobutton
    Xmouse = Lo(Word,mousepos) :Ymouse = Hi(Word,mousepos)
    MouseClick %rightbutton

   Case %WM_KEYDOWN
    Stuffkey Param                          'always uppercase

   End Select

   Function = result
 End Function
'-----------------------------------------------------------------

 %delay  = 275        'millisecond delay before begin repeating
 %repeat = 125        'repeat period, that is, time between
 %threadperiod = 100  '0 is ideal I guess, but anything not much
                      ' over %repeat works.  If too large then
                      ' gets added to %delay
 Function ButtonThread(ByVal q As Dword) Static As Dword
  Local xm As Long, ym As Long
  Do                                 'thread motor
   If Not BTcalled Then              'save mouse position
    BTcalled = True                  'so won't do it again
    xm = xmouse
    ym = ymouse
    Sleep %delay                     'delay before start repeating
   End If
   Do                                'repeating-click loop
    xmouse = xm                      'recover mouse position
    ymouse = ym
    If whichbutton Then              'button still down?
     MouseClick whichbutton          'perform mouseclick if is
    Else
     Exit Do                         'stop repeating if isn't
    End If
    Sleep %repeat                    'repeat period
   Loop
   Sleep %threadperiod               'thread period
  Loop
 End Function
'-----------------------------------------------------------------

 Sub DrawCircle(x As Long, y As Long, r As Long, c As Long)
   Graphic Ellipse(x-r,y-r)-(x+r,y+r),c
 End Sub
 
 Sub DrawDot(x As Long, y As Long)
   DrawCircle(x,y, 2,%Black)
 End Sub

 %xx = -47
 %yy = 170
 Sub PrintIncrement(ss As Single)
  Graphic Box (%xx,%yy) - (%xx+100,%yy-20),,%LtGray,%LtGray
  Graphic Set Pos (%xx,%yy)
  Graphic Color %Black
  Graphic Print "<     " + Format$(ss,"+.00;-.00") + "     >"
  Graphic ReDraw
  Graphic Color %Red
 End Sub
'-----------------------------------------------------------------

 Function PBMain
  Dim keybuff(10)
  Local mousethread As Dword
  Local result As Long

  Local GW As Dword
  Local BM As Dword

  Local ss  As Single                        'angle of line increment
  Local th  As Single                        'angle of radius
  Local th2 As Single                        'angle of line

  Local pi, ph  As Single                    'pi, pi/2
  Local arx,ary As Long
  Local brx,bry As Long

  %r  = 50                                   'radius
  %r2 = %r*2 + 25                            'half length of line
'----------------------------

  Graphic Window "", 0,0, 400, 400 To win1   'create graphic window
  Graphic Attach win1, 0, ReDraw
  Graphic Scale (-200,200)-(200,-200)        'origin at center
  Graphic Clear
  Graphic Set Focus

  GW   = GetWindow(win1, %GW_CHILD)                'subclass
  GWold = SetWindowLong(GW, %GWL_WNDPROC, CodePtr(GWnew))

  BTcalled = True                                  'so ButtonThread deactivated
  whichbutton = %nobutton
  Thread Create ButtonThread(0) To mousethread
  Thread Close mousethread To result               'note: thread still runs

  Graphic Font "Arial", 12, 0
  Graphic Print "  Use  left  and  right  mouse buttons"
  Graphic Print "  (or  <  and  >  keyboard keys)  to change"
  Graphic Print "  speed and direction of the animation."
  Graphic Print
  Graphic Print "  Do anything to start the animation."
  Graphic ReDraw

  Getkey
  If ky = %esc Then Exit Function
  Graphic Clear
  Graphic Print " Esc - quit."
  Graphic Color %Red,%LtGray
'----------------------------
                        
  pi = 4*Atn(1)
  ph = 2*Atn(1)

  th2 = 0                                    'line starts horizontally
  ss = pi/180                                'start with 1 degree
  PrintIncrement ss

  Do
   th  = th2 + th2 - ph                      'radius starts at -ph or -90 degrees
   brx = %r *Cos(th ) : bry = %r *Sin(th )
   arx = %r2*Cos(th2) : ary = %r2*Sin(th2)
   Graphic Box (-%r2,-%r2-55) - (%r2+5,%r2),,%LtGray,%LtGray
   DrawCircle(0,0, %r,%Red)
   Graphic Line (-arx,-%r-ary)-(arx,-%r+ary),%Yellow
   Graphic Line (0,0)-(brx,bry),%Black
   DrawDot(0,0)                   'center of cirlce
   DrawDot(0,-%r)                 'center of line
   DrawDot(brx,bry)               'on circle
   Graphic ReDraw
   Sleep 10
   th2 = th2 + ss

   If Instat1 Then
    Select Case InKey1
    Case %esc
     Exit Loop
    Case %LT
     ss = ss - .01 : If ss < -.5 Then ss = -.5
     PrintIncrement ss
    Case %GT
     ss = ss + .01 : If ss >  .5 Then ss =  .5
     PrintIncrement ss
    End Select
   End If
  Loop
 End Function

Politically incorrect signatures about immigration patriots are forbidden. Googling “immigration patriots” is forbidden. Thinking about Googling ... well, don’t even think about it.

Tags: None

Previous template Next

Announcement

New Sub-Forum

Forum Guidelines

Mouse button auto-repeat

Mouse button auto-repeat