Code:
' Purpose: Create InKey and InStat functions for a graphic window. ' Compiler: PBCC 4 ' ' The console has InKey$ and InStat functions for keyboard input. ' This demo program creates similar functions for a graphic window: ' InKey1 and InStat1. ' ' Unlike InKey$, InKey1 is a keycode, and is always the uppercase version. ' The program could be modified to reflect the appropriate case, but here ' we use another variable to tell the shift state. ' ' The shift state is told by the variable "shiftstate." If you hold either the ' Shift or CßO¸key down while pressing a character key more than once, ' both characters will be assigned the appropriate shift. However when ' holding Alt down only the first character will be assigned Alt. #Dim All #Console Off 'cannot use Print or WaitKey$ '----------------------------------------------------------------- Macro False = 0 Macro True = -1 Macro Boolean = Long '----------------------------------------------------------------- %esc = 27 %enter = 13 %lowerA = 97 :%lowerZ = 122 %none = 0 'arbitrary shiftstate values %alt = 1 %ctrl = 2 %shift = 3 '----------------------------------------------------------------- 'From WinAPI %WM_KEYDOWN = &H100 %WM_KEYUP = &H101 %WM_SYSKEYDOWN = &H104 %WM_SYSKEYUP = &H105 %VK_MENU = &H12 'alt key %WM_SYSCOMMAND = &H112 %SC_KEYMENU = &HF100& %SC_CLOSE = &HF060& %SC_MINIMIZE = &HF020& %VK_SHIFT = &H10 %VK_CONTROL = &H11 %GWL_WNDPROC = -4 Type KeyState repeatcount As Bit*16 In Dword scancode As Bit*8 extendkey As Bit*1 '1 if right Alt or Ctrl reserve1 As Bit*4 context As Bit*1 '1 if Alt down when key pressed previous As Bit*1 '1 if down, 0 if up transstate As Bit*1 'always 0 End Type Union Syskey value As Dword KeyState End Union 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 '----------------------------------------------------------------- Declare Function GWnew_k(ByVal Dword, ByVal Dword, ByVal Dword, ByVal Long) As Long Declare Function UpperCase(ByVal Long) As Long Declare Function InStat1 As Long Declare Function InKey1 As Long Declare Sub StuffKey(ByVal Long, ByVal Long) ' Declare Sub ClearKey ' Declare Function NextKey As Long Declare Sub GetKey '----------------------------------------------------------------- Global GW1, GWold1, GWold1k As Dword 'handles Global win1 As Dword 'handle for window Global ky As Long 'keycode Global shiftstate As Long 'Alt, Ctrl, Shift Global keybuff() As Long 'keycode buffer Global shiftbuff() As Long 'shiftstate buffer Global nkey As Long 'number of keys in keycode buffer '----------------------------------------------------------------- Sub Stuffkey(ByVal ky As Long, ByVal shiftstate As Long) keybuff(nkey) = ky shiftbuff(nkey) = shiftstate Incr nkey End Sub Function InStat1 As Boolean Function = (nkey <> 0) End Function Function InKey1 As Long If nkey Then Decr nkey Function = keybuff(nkey) shiftstate = shiftbuff(nkey) End If End Function ' Sub ClearKey ' nkey = 0 ' End Sub ' Function NextKey As Long 'look at key without removing ' If nkey Then ' Function = keybuff(nkey-1) ' End If ' End Function Sub GetKey Dim count As Long 'sleep 0 once every five iterations Do Until InStat1 Incr count If count = 5 Then count = 0 Sleep 0 End If Loop ky = InKey1 End Sub '----------------------------------------------------------------- Function UpperCase(ByVal k As Long) As Long 'ky any key upper or lowercase If %lowerA <= k And k <= %lowerZ Then 'lowercase letter Function = k - 32 Else Function = k End If End Function '----------------------------------------------------------------- Function GWnew_k (ByVal Wnd As Dword, ByVal Msg As Dword, ByVal Param As Long, ByVal OtherParam As Long) As Long 'assume no more than one shift key at a time Dim ks As Syskey Select Case Long Msg Case %WM_KEYUP If Param = %VK_SHIFT Or Param = %VK_CONTROL Then 'shift or ctrl key up shiftstate = %none End If Case %WM_KEYDOWN If Param = %VK_SHIFT Then 'shift key down shiftstate = %shift ElseIf Param = %VK_CONTROL Then 'ctrl key down shiftstate = %ctrl Else Stuffkey Param,shiftstate 'always uppercase shiftstate = %none End If Case %WM_SYSCOMMAND If (Param And &HFFF0) = %SC_CLOSE Then Stuffkey %esc,%none Exit Function ElseIf Param = %SC_KEYMENU And OtherParam <> 0 Then Stuffkey UpperCase(OtherParam),shiftstate shiftstate = %none End If Case %WM_SYSKEYDOWN If Param = %VK_MENU Then ks.Value = OtherParam 'Alt pressed, it generates WM_SYSCOMMAND. Change the state. '(Trick due to Richard Angell.) ks.previous = 1 - ks.previous OtherParam = ks.Value shiftstate = %alt End If Case %WM_SYSKEYUP shiftstate = %none End Select Function = CallWindowProc(GWold1k, Wnd, Msg, param, OtherParam) End Function '----------------------------------------------------------------- Function PBMain Dim keybuff(10) Dim shiftbuff(10) Graphic Window "", 0,0, 800,400 To win1 'create graphic window Graphic Attach win1,0, ReDraw GWold1k = SetWindowLong(win1, %GWL_WNDPROC, CodePtr(GWnew_k)) Graphic Font "Times New Roman", 12, 0 Graphic Print "Type some letters or numbers. They'll appear below, preceeded by *, ^, or ~ if you press Alt, Ctrl, or Shift." Graphic Print "Press Esc to quit." Graphic Print Graphic ReDraw Graphic Font "Times New Roman", 12, 1 shiftstate = %none Do Getkey If ky = %esc Then Exit Loop If ky = %enter Then 'new line Graphic Print Else Select Case shiftstate Case %none Case %alt :Graphic Print "*"; Case %ctrl :Graphic Print "^"; Case %shift :Graphic Print "~"; End Select Graphic Print Chr$(ky); End If Graphic ReDraw Loop End Function
Comment