Tweet
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