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 more
See less

Mouse button auto-repeat

  • Filter
  • Time
  • Show
Clear All
new posts

  • Mouse button auto-repeat

    ' 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
     %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
      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
        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
        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
         Exit Do                         'stop repeating if isn't
        End If
        Sleep %repeat                    'repeat period
       Sleep %threadperiod               'thread period
     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
      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
       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
     End Function
    Politically incorrect signatures about immigration patriots are forbidden. Searching “immigration patriots” is forbidden. Thinking about searching ... well, don’t even think about it.