OK, last one. Didn't get done but this next section is a lot more involved...

by Pete (no login)


Highlighting, and with this auto-input, it presents some interesting challenges. You can try it on the year entry to get the best look at it. Just hold a shift key and highlight with the cursor right and left arrows.

There is no copy/paste yet or mouse highlighting.

Anyway, this was fun and I fixed the 400 rule on the Leap Year:

-----------------------------------
DECLARE SUB MDRIVER (EX%, key$, mouseyx%)
TYPE RegType
AX AS INTEGER
BX AS INTEGER
CX AS INTEGER
DX AS INTEGER
BP AS INTEGER
SI AS INTEGER
DI AS INTEGER
FLAGS AS INTEGER
DS AS INTEGER
ES AS INTEGER
END TYPE

DIM SHARED MOUSE$
DIM SHARED Registers AS RegType
DIM SHARED LB%, RB%, MB%, DX, CX

CLS
DIM SHARED dt$(3), icol%(3), max%(3), cur%(3)
DIM SHARED curcol%, currow%
curcol% = 1: currow% = 1
max%(1) = 1: max%(2) = 1: max%(3) = 3: insert% = 1
icol%(1) = 7
icol%(2) = icol%(1) + 9
icol%(3) = icol%(2) + 10
LOCATE , , 1, 7, 7
FOR idt% = 1 TO 3
SELECT CASE idt%
CASE 1: LOCATE currow%, curcol%: PRINT "Month: ";
CASE 2: LOCATE currow%, curcol% + 11: PRINT "Day: ";
CASE 3: LOCATE currow%, curcol% + 20: PRINT "Year: ";
END SELECT
NEXT

idt% = 0
DO
DO
idt% = idt% + 1: flag = 0
cur%(idt%) = 0
LOCATE currow%, curcol% + icol%(idt%)
DO
GOSUB getkey
SELECT CASE key$
CASE CHR$(13)
SELECT CASE idt%
CASE 1, 2
IF VAL(dt$(idt%)) > 0 THEN EXIT DO
CASE 3
IF LEN(dt$(idt%)) = 4 THEN EXIT DO
END SELECT

CASE CHR$(0) + "R"
insert% = insert% * -1
IF insert% = 1 THEN LOCATE , , 1, 7, 7 ELSE LOCATE , , 1, 7, 30

CASE CHR$(0) + "K"
IF cur%(idt%) > 0 THEN
LOCATE , POS(1) - 1: cur%(idt%) = cur%(idt%) - 1: flag = 0
ELSE
IF idt% > 1 THEN
IF hl% <> 0 THEN GOSUB rewrite
idt% = idt% - 2
EXIT DO
END IF
END IF

CASE CHR$(0) + "M"
IF cur%(idt%) < max%(idt%) THEN
IF cur%(idt%) < LEN(dt$(idt%)) THEN
LOCATE , POS(1) + 1: cur%(idt%) = cur%(idt%) + 1
END IF
ELSE
IF VAL(dt$(idt%)) > 0 AND idt% < 3 THEN
IF hl% <> 0 THEN GOSUB rewrite
EXIT DO
END IF
END IF

CASE CHR$(0) + "G"
LOCATE currow%, curcol% + icol%(idt%): cur%(idt%) = 0: flag = 0

CASE CHR$(0) + "O"
LOCATE currow%, curcol% + icol%(idt%) + max%(idt%): cur%(idt%) = max%(idt%)

CASE CHR$(0) + "S"
IF LEN(dt$(idt%)) > 0 THEN
SELECT CASE cur%(idt%)
CASE 0
dt$(idt%) = MID$(dt$(idt%), 2)
CASE ELSE
dt$(idt%) = MID$(dt$(idt%), 1, cur%(idt%)) + MID$(dt$(idt%), cur%(idt%) + 2)
END SELECT
GOSUB rewrite
END IF

CASE CHR$(8)
IF cur%(idt%) <= 0 THEN key$ = ""
IF key$ <> "" THEN
dt$(idt%) = MID$(dt$(idt%), 1, cur%(idt%) - 1) + MID$(dt$(idt%), cur%(idt%) + 1)
cur%(idt%) = cur%(idt%) - 1
GOSUB rewrite
flag = 0
END IF
CASE ""
CASE ELSE
SELECT CASE insert%
CASE 1
PRINT key$;
cur%(idt%) = cur%(idt%) + 1
IF cur%(idt%) > LEN(dt$(idt%)) THEN dt$(idt%) = dt$(idt%) + key$ ELSE MID$(dt$(idt%), cur%(idt%), 1) = key$
CASE -1
dt$(idt%) = MID$(dt$(idt%), 1, cur%(idt%)) + key$ + MID$(dt$(idt%), cur%(idt%) + 1)
GOSUB rewrite
cur%(idt%) = cur%(idt%) + 1
LOCATE , POS(1) + 1
END SELECT

SELECT CASE idt%
CASE 1
IF LEN(dt$(idt%)) = 2 THEN
IF VAL(dt$(idt%)) > 12 OR VAL(dt$(idt%)) = 0 THEN flag = -1 ELSE EXIT DO
ELSE
IF VAL(dt$(idt%)) > 1 AND flag = 0 THEN EXIT DO
END IF

CASE 2
IF LEN(dt$(idt%)) = 2 THEN
IF VAL(dt$(idt%)) > 31 OR VAL(dt$(idt%)) = 0 THEN flag = -1
IF flag = 0 THEN EXIT DO
ELSE
flag = 0
END IF

CASE 3
IF LEN(dt$(idt%)) = 4 THEN EXIT DO
END SELECT
END SELECT
LOOP
IF idt% = 3 THEN EXIT DO
LOOP

REM Evaluate Days in Month Entry.
flag = 0
j% = VAL(dt$(1))
IF j% = 4 OR j% = 6 OR j% = 9 OR j% = 11 THEN i% = 30 ELSE IF j% = 2 THEN i% = 28 ELSE i% = 31
IF i% = 28 THEN
IF VAL(dt$(3)) MOD 4 = 0 THEN
IF VAL(dt$(3)) MOD 100 <> 0 THEN i% = 29
IF VAL(dt$(3)) MOD 400 = 0 THEN i% = 29
END IF
END IF
IF VAL(dt$(2)) > i% THEN flag = -1
IF flag = -1 THEN
LOCATE currow%, curcol% + icol%(3) + 20: PRINT "Invalid date, redo day...";
SLEEP 2: key$ = INKEY$: key$ = ""
LOCATE currow%, curcol% + icol%(3) + 20: PRINT SPACE$(25);
idt% = 1: flag = 0
ELSE
EXIT DO
END IF
LOOP

SYSTEM

getkey:
mouseyx% = 0
EX% = 1: CALL MDRIVER(EX%, key$, mouseyx%)
DO
key$ = INKEY$
EX% = 2: CALL MDRIVER(EX%, key$, mouseyx%)
IF mouseyx% <> 0 THEN GOSUB mousemap
IF key$ <> "" THEN EXIT DO
LOOP
EX% = -1: CALL MDRIVER(EX%, key$, mouseyx%)
GOSUB checkhgl
IF key$ = CHR$(13) THEN RETURN: REM Only needed for corrections.
IF key$ = CHR$(27) THEN SYSTEM
IF ASC(key$) < 48 OR ASC(key$) > 57 THEN
IF key$ = CHR$(8) OR LEN(key$) = 2 AND INSTR("KMGOSR", MID$(key$, 2, 1)) <> 0 THEN RETURN
key$ = "": REM invalid entry.
END IF
IF insert% = -1 AND LEN(dt$(idt%)) = max%(idt%) + 1 THEN key$ = ""
IF flag = -1 THEN key$ = ""
RETURN

rewrite:
COLOR 7, 0
LOCATE currow%, curcol% + icol%(idt%)
PRINT SPACE$(max%(idt%) + 1);
LOCATE currow%, curcol% + icol%(idt%)
PRINT dt$(idt%);
LOCATE currow%, curcol% + icol%(idt%) + cur%(idt%)
hl% = 0
RETURN

mousemap:
x% = (mouseyx% - 1) \ 80 + 1
y% = (mouseyx% - 1) MOD 80 + 1
IF x% = currow% THEN
FOR j% = 1 TO 3
IF y% >= curcol% + icol%(j%) AND y% <= curcol% + icol%(j%) + LEN(dt$(j%)) THEN
IF y% >= curcol% + icol%(j%) AND y% < curcol% + icol%(j%) + LEN(dt$(j%)) THEN
cur%(idt%) = y% - (curcol% + icol%(j%))
LOCATE , y%
EXIT FOR
END IF
END IF
NEXT
IF j% < 4 THEN idt% = j%
IF cur%(idt%) <= max%(idt%) THEN flag = 0
END IF
mouseyx% = 0
RETURN

checkhgl:
DEF SEG = 0
IF PEEK(1047) MOD 16 = 1 AND LEN(key$) = 2 AND INSTR("KM", MID$(key$, 2, 1)) <> 0 OR PEEK(1047) MOD 16 = 2 AND LEN(key$) = 2 AND INSTR("KM", MID$(key$, 2, 1)) <> 0 THEN
DO
IF MID$(key$, 2, 1) = "K" THEN peekon% = -1: EXIT DO
IF MID$(key$, 2, 1) = "M" THEN peekon% = 1: EXIT DO
EXIT DO
LOOP
ELSE
IF peekon% <> 0 THEN peekon% = peekon% * 2
END IF
DEF SEG
IF ABS(peekon%) > 1 THEN
COLOR 7, 0
GOSUB rewrite
LOCATE , curcol% + icol%(idt%) + cur%(idt%)
peekon% = 0: hl% = 0
ELSE
IF peekon% = 1 THEN
IF cur%(idt%) < LEN(dt$(idt%)) THEN
hl% = hl% + 1
IF hl% > 0 THEN COLOR 7, 1 ELSE COLOR 7, 0
PRINT MID$(dt$(idt%), cur%(idt%) + 1, 1);
IF cur%(idt%) <> max%(idt%) THEN
LOCATE currow%, POS(1) - 1
ELSE
REM needed to keep from tabbing to next entry
LOCATE currow%, POS(1) - 2
cur%(idt%) = cur%(idt%) - 1
END IF
END IF
END IF
IF peekon% = -1 THEN
IF cur%(idt%) > 0 THEN
hl% = hl% - 1
IF hl% >= 0 THEN COLOR 7, 0 ELSE COLOR 7, 1
LOCATE , POS(1) - 1
PRINT MID$(dt$(idt%), cur%(idt%), 1);
END IF
END IF
END IF
RETURN

SUB MDRIVER (EX%, key$, mouseyx%)
STATIC MOUSEACT%

IF MOUSEACT% = 0 THEN
Registers.AX = 0: GOSUB CALLI
MOUSEACT% = 1
END IF

IF EX% = 1 THEN Registers.AX = 1: GOSUB CALLI

Registers.AX = 3: GOSUB CALLI
DX = Registers.DX
CX = Registers.CX
x% = DX \ 8 + 1: y% = CX \ 8 + 1

LB% = Registers.BX AND 1
RB% = (Registers.BX AND 2) \ 2
MB% = (Registers.BX AND 4) \ 4

IF LB% <> 0 THEN
mouseyx% = (x% - 1) * 80 + y%
EXIT SUB
DO
CALL INTERRUPT(&H33, Registers, Registers)
LB% = Registers.BX AND 1
LOOP UNTIL LB% = 0
END IF
EXIT SUB

CALLI:
CALL INTERRUPT(&H33, Registers, Registers)
RETURN

END SUB

-----------------------------------

Pete

Posted on Nov 13, 2009, 5:35 PM

Respond to this message   

Return to Index