Feature creep....
Chris,
Here is Dave's code with a few improvements.
It solved my caret problem and will show a nice full size caret like old time instead of the skinny one you get with windows programs.
All keys and mouse events are covered and a SLEEP 1 is enough. And also you can now use the Tab Key....
I do not use DIALOG DOEVENTS
Click anywhere with the left button and type any text
Use the mouse wheel to move the caret position and type anything.
This is the ultimate way to control the inputs with a graphic console program.
The font size and the number of lines and characters are used to calculate the window size
Many thanks again to Dave for that nice technique.
Chris,
Here is Dave's code with a few improvements.
It solved my caret problem and will show a nice full size caret like old time instead of the skinny one you get with windows programs.
All keys and mouse events are covered and a SLEEP 1 is enough. And also you can now use the Tab Key....
I do not use DIALOG DOEVENTS
Click anywhere with the left button and type any text
Use the mouse wheel to move the caret position and type anything.
This is the ultimate way to control the inputs with a graphic console program.
The font size and the number of lines and characters are used to calculate the window size
Many thanks again to Dave for that nice technique.
Code:
#COMPILE EXE
#CONSOLE OFF
#DIM ALL
#Register None
'#DEBUG ERROR ON
#INCLUDE "WIN32API.INC"
FUNCTION PBMAIN () AS LONG
GLOBAL cw,ch,row,col AS LONG ' For Caret size in pixels, rows and columns
GLOBAL lb,mb,rb,wm,tbk AS LONG ' For mouse buttons, wheel and tab key
GLOBAL caption AS STRING
LOCAL hGWin???, hFont???, hStatic???, x!, y!, ink$
FONT NEW "Courier New", 12, 1 TO hFont ' NB. Fixed-width font
caption$="Graphic window"
GRAPHIC WINDOW caption$, 0, 0, 505, 600 TO hGWin
GRAPHIC ATTACH hGWin, 0
hStatic = GetWindow(hGWin, %GW_CHILD) ' handle of Static child of Gfx Window
'SubClass Static to attach cursor etc
SetProp hGWin, "OldStaticProc", SetWindowLong(hStatic, %GWL_WNDPROC, CODEPTR(StaticProc))
GRAPHIC SET FONT hFont ' Font select.
GRAPHIC CHR SIZE TO cw, ch ' Get char size for this font and make caret same size
SendMessage hStatic, %WM_USER + 1000, 0, 0 ' Create caret
row=24: col=40 ' Rows and columns in box
GRAPHIC BOX (cw/2, ch/2) - ((col+1.5)*cw, (row+1.5)*ch), 0, %BLUE ' Draw box - has char grid depending on character size
GRAPHIC SET POS (cw*2,0): GRAPHIC PRINT "Graphic Note Pad"
x=cw: y=ch: GRAPHIC SET POS (x, y)
'Update caret position and pass char size and x,y
SendMessage hStatic, %WM_USER + 1001, MAK(LONG, cw, ch), MAK(LONG, x, y): SetCaretPos x,y ' pass char size and x, y
'======================================InKey$ Loop==============================================
DO UNTIL ink$=$ESC
GRAPHIC INKEY$ TO ink$: SLEEP 1 ' Get keyboard input
SendMessage hStatic, %WM_USER + 1001, 0, MAK(LONG, x, y)
'------------------------------ Mouse buttons from StaticProc Function -------------------------------
IF lb THEN ' Left button
GRAPHIC GET POS TO x,y
lb=0: ITERATE
END IF
IF wm=1 THEN ' Wheel mouse up
IF y/ch>1 THEN
y=y-ch: GRAPHIC SET POS (x,y)
ELSE: BEEP
END IF
wm=0: ITERATE
END IF
IF wm=-1 THEN ' Wheel mouse down
IF y/ch<row THEN
y=y+ch: GRAPHIC SET POS (x,y)
ELSE: BEEP
END IF
wm=0: ITERATE
END IF
'--------------------------------------Normal keys---------------------------------------
IF LEN(ink$)=1 THEN
IF ink$ = $CR THEN ' Next line if below maximum else go back up
IF y/ch<row THEN ink$="": x=cw: y=y+ch ELSE BEEP: y=ch: x=cw
END IF
IF ink$ = $BS THEN ' Backspace
IF x/cw>1 THEN x=x-cw ELSE BEEP: ITERATE
GRAPHIC SET POS (x,y) : GRAPHIC PRINT " "
END IF
IF tbk=9 THEN ' Tab Key
tbk=0: SendMessage hStatic, %WM_USER + 1001, 0, MAK(LONG, x, y)
END IF
IF ink$>CHR$(31) THEN ' Printable characters
GRAPHIC SET POS (x, y): GRAPHIC PRINT ink$
IF x/cw<col THEN x=x+cw ELSE BEEP
END IF
ITERATE
END IF
'----------------------------------------Extended keys------------------------------------
IF LEN(ink$) = 2 THEN
SELECT CASE ASC(RIGHT$(ink$,1))
CASE 72 ' Up Arrow
IF y/ch>1 THEN
y=y-ch: GRAPHIC SET POS (x,y)
ELSE: BEEP
END IF
CASE 75 ' Left arrow
IF x/cw>1 THEN
x=x-cw: GRAPHIC SET POS (x,y)
ELSE: BEEP
END IF
CASE 77 ' Right arrow
IF x/cw<col THEN
x=x+cw: GRAPHIC SET POS (x,y)
ELSE: BEEP
END IF
CASE 80 ' Down arrow
IF y/ch<row THEN
y=y+ch: GRAPHIC SET POS (x,y)
ELSE: BEEP
END IF
CASE 71 ' Home
x=cw: GRAPHIC SET POS (x,y)
CASE 79 ' End
x=col*cw: GRAPHIC SET POS (x,y)
END SELECT
END IF
LOOP WHILE IsWindow(hGWin)
'==============================================================================================
'Cleanup
SetWindowLong(hStatic, %GWL_WNDPROC, GetProp(hGWin, "OldStaticProc"))
RemoveProp hGWin, "OldStaticProc"
SetWindowLong(hGWin, %GWL_WNDPROC, GetProp(hGWin, "OldGWProc"))
RemoveProp hGWin, "OldGWroc"
GRAPHIC WINDOW END
END FUNCTION
'-----------------------------------------------------------------------------------------------------------------
FUNCTION StaticProc(BYVAL hWnd AS DWORD, BYVAL wMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
LOCAL x! ,y!: 'STATIC ncW!, ncH!
SELECT CASE AS LONG wMsg
CASE %WM_USER + 1000: CreateCaret hWnd, 0, cw, ch ' Create solid caret size of font character grid
CASE %WM_USER + 1001 ' User message to update caret pos
IF wParam THEN cw = LO(WORD, wParam) : ch = HI(WORD, wParam)
x = LO(WORD, lParam) : y = HI(WORD, lParam): SetCaretPos x, y: ShowCaret hWnd
CASE %WM_KILLFOCUS
DestroyCaret ' Don't show caret if focus elsewhere
CASE %WM_SETFOCUS
CreateCaret hWnd, 0, cw, ch: ShowCaret hWnd ' we're back! - show caret
CASE %WM_MOUSEMOVE
IF GetFocus = hWnd THEN ' don't update cursor pos if focus elsewhere
x = LO(WORD, lParam) : y = HI(WORD, lParam)
SetWindowText GetParent(hWnd), "x" + STR$(x) + ", y" + STR$(y)
END IF
CASE %WM_LBUTTONUP ' Left mouse button
x = LO(WORD, lParam) : y = HI(WORD, lParam): lb=1
x = (x\cw)*cw : y = (y\ch)*ch : SetCaretPos x, y ' new pos adjusted to char/line spacing
GRAPHIC ATTACH GetParent(hWnd), 0 : GRAPHIC SET POS (x, y)
CASE %WM_MBUTTONUP ' Middle mouse button
x = LO(WORD, lParam) : y = HI(WORD, lParam): mb=1: SetWindowText GetParent(hWnd), "Middle button"
CASE %WM_RBUTTONUP ' Right mouse button
x = LO(WORD, lParam) : y = HI(WORD, lParam): rb=1: SetWindowText GetParent(hWnd), "Right button"
CASE %WM_MOUSEWHEEL ' Mouse wheel
wm = HI(WORD, wParam): IF wm>32768 THEN wm=-1 ELSE wm=1 ' Wheel turned (+)=up (-)=down
CASE %WM_CHAR
IF LO(WORD,wParam)=9 THEN tbk=9: SetWindowText GetParent(hWnd), "Tab Key" ELSE tbk=0
END SELECT
FUNCTION = CallWindowProc(GetProp (GetParent(hWnd), "OldStaticProc"), hWnd, wMsg, wParam, lParam)
END FUNCTION
)
I should stop interlopping if I can't stop those DDTs sneeking into my posts!
Comment