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