Tweet
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