Use the mouse or keyboard to make menu selections.
There is a right click menu for find and replace to cut/copy/paste, etc.
You can find or replace text or sentences across line-breaks.
The edited file can be saved with a -new addition to the file name.
Note this utility is not a WP, so you cannot type to the file. It also was not made to scroll files longer than the page height, but it will tell you how many finds/replace, it encountered.
Let me know if you find any any bugs and, as always, use caution with any program that writes to files.
Pete
EDIT: I was so kind replacing your mishighlighted codebox, please use the QB64PE IDE File menu > ExportAs > Forum Codebox in the future. - RhoSigma
There is a right click menu for find and replace to cut/copy/paste, etc.
You can find or replace text or sentences across line-breaks.
The edited file can be saved with a -new addition to the file name.
Note this utility is not a WP, so you cannot type to the file. It also was not made to scroll files longer than the page height, but it will tell you how many finds/replace, it encountered.
Code: (Select All)
DEFINT A-Z
main find$, replace$
SYSTEM
SUB main (find$, replace$)
WIDTH 140, 43: _FONT 16: _SCREENMOVE 0, 0
mypalette
COLOR 7, 1: CLS
target$ = _OPENFILEDIALOG$("Open a file to to be searched:", "", "*.*", "", 0)
IF target$ = "" THEN SYSTEM
file$ = MID$(target$, _INSTRREV(target$, "\") + 1)
DO
IF orig$ = "" THEN
COLOR 7, 1: CLS
IF _FILEEXISTS(target$) THEN ELSE PRINT "Error, file not found: " + target$: END
OPEN target$ FOR BINARY AS #1
a$ = SPACE$(LOF(1))
GET #1, , a$
CLOSE #1
orig$ = a$
GOSUB show1
END IF
msg$ = "[Ctrl + F] Search [Esc] Quit"
LOCATE _HEIGHT, 1, 0: PRINT SPACE$(_WIDTH);
g = _WIDTH / 2 - LEN(msg$) / 2
LOCATE _HEIGHT, g, 0: PRINT msg$;
map$ = SPACE$(_WIDTH)
MID$(map$, g) = msg$
DO
IF redo THEN
redo = 0: b$ = CHR$(6)
ELSE
my_mse_kbd lb, mb, rb, my, mx, mw, shift%, clkcnt, drag, b$, mhovery, mhoverx
END IF
IF lb = 1 THEN
f = _INSTRREV(mx, map$, "[") + 1
g = INSTR(mx, map$, "]") - f
msel$ = MID$(map$, f, g)
SELECT CASE LCASE$(msel$)
CASE "esc": b$ = CHR$(27)
CASE "ctrl + f": b$ = CHR$(6)
END SELECT
END IF
SELECT CASE b$
CASE CHR$(6)
LOCATE _HEIGHT, 1: PRINT SPACE$(_WIDTH);: LOCATE 1, 1
myform fld, yfield(), xfield(), flen(), maxlen(), text$(), mtop, mleft, mhovery, mhoverx, b1TopLtx, b1BtmRtx, b1TopRty, b1BtmLty, b2TopLtx, b2BtmRtx, b2TopRty, b2BtmLty, inpclose, find$, replace$, findreplace
IF inpclose THEN inpclose = 0: EXIT DO ELSE inpclose = 0 ' Popup input window closed.
CASE CHR$(27)
SYSTEM
END SELECT
LOOP
LOCATE , , 0
IF find$ <> replace$ THEN ' Note Len(find$) was set in input mode so it cannot be zero.
a2$ = a$: fnd = 0: lb = 0: c = 0
DO ' Strip out line-breaks and substitute a space for a single line-break.
q = INSTR(seed, a$, CHR$(13) + CHR$(10))
IF q THEN
IF MID$(a$, q + 2, 2) = CHR$(13) + CHR$(10) OR MID$(a$, q + 2) = "" THEN
sp$ = "": sp2$ = ""
FOR j = 0 TO LEN(a2$) STEP 2
IF MID$(a2$, q + j, 2) <> CHR$(13) + CHR$(10) THEN EXIT FOR
NEXT
IF j THEN lb = lb + 1: REDIM _PRESERVE line_break(lb) AS INTEGER: line_break(lb) = j / 2
ELSE
sp$ = " ": sp2$ = CHR$(10): IF j THEN sp2$ = CHR$(13)
j = 0
END IF
a$ = MID$(a$, 1, q - 1) + sp$ + MID$(a$, q + 2)
a2$ = MID$(a2$, 1, q - 1) + sp2$ + MID$(a2$, q + 2)
seed = q
ELSE
EXIT DO
END IF
c = c + 1: IF c > 1000 THEN PRINT "Oops. We went over 1000 loops without completing the routine.": END ' For beta version this prevents an endless loop for any unhandled condition.
LOOP
' So now a$ is stripped of line-breaks and a2$ is the same length as a$, but
' has single control characters Chr$(10) for a single line-break and chr$(13)
' for multiple line-breaks. So 1 character instead of 2 for Chr$(13) + Chr$(10).
seed = 1: r1 = 0: r2 = 0
DO ' Find and Replace.
q = INSTR(seed, LCASE$(a$), LCASE$(find$))
IF q THEN
i = INSTR(MID$(a2$, q, LEN(find$)), CHR$(10))
IF i = 0 THEN i = INSTR(MID$(a2$, q, LEN(find$)), CHR$(13))
IF LTRIM$(find$) = "" AND i = 0 OR LTRIM$(find$) <> "" THEN ' Space over Chr$(10) exception.
fnd = fnd + 1
r1 = r1 + 1: REDIM _PRESERVE r1(r1): r1(r1) = q ' Position of the 1st character of the found string.
r2 = r2 + 1: REDIM _PRESERVE r2(r2)
ELSE
falseflag = 1
END IF
k = 0: seed2 = 1
DO
i = INSTR(seed2, MID$(a2$, 1, q), CHR$(10))
IF i THEN k = k + 1 ELSE EXIT DO
seed2 = i + 1
LOOP
l = 0: m = 0: seed2 = 1
DO
i = INSTR(seed2, MID$(a2$, 1, q), CHR$(13))
IF i THEN
l = l + 1: m = m + line_break(l) * 2 - 1
ELSE
EXIT DO
END IF
seed2 = i + 1
LOOP
IF falseflag = 0 THEN r2(r2) = q + k + m ELSE falseflag = 0
seed = q + LEN(find$)
ELSE
IF LEN(find2$) THEN find2$ = "": EXIT DO
IF fnd THEN
EXIT DO
ELSE ' Perform a marquee vertical search.
x$ = ""
find2$ = find$
FOR i = 1 TO LEN(find2$)
x$ = x$ + MID$(find2$, i, 1) + " "
NEXT
find$ = MID$(x$, 1, LEN(x$) - 1) ' Remove trailing space
x$ = ""
END IF
END IF
LOOP
UBr1 = r1: UBr2 = r2
LOCATE _HEIGHT, 1, 0
COLOR 7, 1
IF fnd THEN
IF fnd = 1 THEN msg$ = " match " ELSE msg$ = " matches "
PRINT LTRIM$(STR$(fnd)) + msg$ + "found:";
LOCATE 1, 1
IF findreplace THEN ' Replace. See Else statement for Find only.
j = 0: a$ = ""
CLS
r1 = 1: r2 = 1
DO
i1 = INSTR(a2$, CHR$(10))
i3 = INSTR(a2$, CHR$(13))
i4 = r1(r1): IF i4 THEN i4 = i4 - chop
WHILE -1
IF i1 THEN
IF i1 < i3 OR i3 = 0 THEN
IF i1 < i4 OR i4 = 0 THEN
q = i1
x$ = CHR$(13) + CHR$(10)
GOSUB assemble
EXIT WHILE
END IF
END IF
END IF
IF i3 THEN
IF i3 < i1 OR i1 = 0 THEN
IF i3 < i4 OR i4 = 0 THEN
q = i3
j = j + 1: x$ = ""
FOR k = 1 TO line_break(j): x$ = x$ + CHR$(13) + CHR$(10): NEXT
GOSUB assemble
EXIT WHILE
END IF
END IF
END IF
IF i4 THEN
IF i4 < i1 OR i1 = 0 THEN
IF i4 < i3 OR i3 = 0 THEN
x$ = replace$
q = i4
GOSUB assemble
x$ = MID$(a2$, 1, LEN(find$))
FOR i = 1 TO LEN(find$) - 1
SELECT CASE MID$(a2$, i, 1)
CASE CHR$(10)
lb$ = CHR$(13) + CHR$(10)
CASE CHR$(13)
j = j + 1: x$ = ""
FOR k = 1 TO line_break(j): lb$ = lb$ + CHR$(13) + CHR$(10): NEXT
END SELECT
NEXT
a$ = a$ + lb$: lb$ = ""
q = LEN(find$)
IF MID$(a2$, q, 1) = " " AND RIGHT$(a$, 2) = CHR$(13) + CHR$(10) THEN
q = q + 1 ' Remove leading space.
END IF
a2$ = MID$(a2$, q)
chop = chop + q - 1
IF r1 < UBr1 THEN r1 = r1 + 1 ELSE r1 = 0 ' Turn off.
IF r2 < UBr2 THEN r2 = r2 + 1 ELSE r2 = 0 ' Turn off.
EXIT WHILE
END IF
END IF
END IF
a$ = a$ + a2$: a2$ = "": EXIT DO ' End of file.
EXIT WHILE
WEND
LOOP
GOSUB show2
ELSE ' Find
GOSUB showfind
j = 0
END IF
ELSE
PRINT "No match found:";
END IF
REM Shell _DontWait _Hide "start notepad"
ELSE
findreplace = 0 ' Cancel replace.
msg$ = "Find and Replace are the same."
LOCATE _HEIGHT, 1: PRINT msg$;
END IF ' Completed replace.
IF findreplace THEN
LOCATE _HEIGHT, 1: PRINT "Replacement count:"; fnd;
msg$ = "[S]ave File [R]evert to Saved [Enter] Run [Ctrl + F] Search Again [Esc] Quit"
ELSE
msg$ = "[Enter] Run [Ctrl + F] Search Again [Esc] Quit"
END IF
g = _WIDTH / 2 - LEN(msg$) / 2
LOCATE _HEIGHT, g, 0: PRINT msg$;
map$ = SPACE$(_WIDTH)
MID$(map$, g) = msg$
WHILE -1
my_mse_kbd lb, mb, rb, my, mx, mw, shift%, clkcnt, drag, b$, mhovery, mhoverx
IF lb = 1 THEN
f = _INSTRREV(mx, map$, "[") + 1
g = INSTR(mx, map$, "]") - f
msel$ = MID$(map$, f, g)
SELECT CASE LCASE$(msel$)
CASE "enter": b$ = CHR$(13)
CASE "esc": b$ = CHR$(27)
CASE "ctrl + f": b$ = CHR$(6)
CASE "r": b$ = "R"
CASE "s": b$ = "S"
END SELECT
END IF
SELECT CASE b$
CASE "R", "r"
IF findreplace THEN
GOSUB clrvars: orig$ = ""
EXIT WHILE
END IF
CASE "S", "s"
IF findreplace THEN
save$ = MID$(file$, 1, _INSTRREV(file$, ".") - 1) + "-new" + MID$(file$, _INSTRREV(file$, "."))
save$ = _SAVEFILEDIALOG$("Save File As", save$, "*" + MID$(file$, _INSTRREV(file$, ".")), "")
IF LEN(save$) THEN
OPEN save$ FOR OUTPUT AS #1
PRINT #1, a$
CLOSE #1
orig$ = a$
GOSUB clrvars: CLS: LOCATE 1, 1: GOSUB show2
EXIT WHILE
END IF
END IF
CASE CHR$(13): CLS: _DELAY .5: RUN
CASE CHR$(27): SYSTEM
CASE CHR$(6)
IF findreplace THEN orig$ = a$ ELSE a$ = orig$
GOSUB clrvars: CLS: LOCATE 1, 1: GOSUB show2
redo = 1: EXIT WHILE
END SELECT
WEND
LOCATE _HEIGHT, 1: PRINT SPACE$(_WIDTH);: LOCATE 1, 1
LOOP
EXIT SUB
assemble:
a$ = a$ + MID$(a2$, 1, q - 1) + x$
a2$ = MID$(a2$, q + 1): chop = chop + q
RETURN
show1:
FOR i = 1 TO LEN(a$)
x$ = MID$(a$, i, 1)
IF x$ = CHR$(13) THEN PRINT: i = i + 1: _CONTINUE
PRINT x$;
IF CSRLIN > _HEIGHT - 2 THEN EXIT FOR
NEXT
LOCATE 1, 1: x$ = ""
RETURN
showfind:
y = CSRLIN: x = POS(0)
j = 1: k = 0
FOR i = 1 TO LEN(orig$)
x$ = MID$(orig$, i, 1)
IF x$ = CHR$(13) THEN
IF k AND breaks = 0 THEN
k = k + 1 ' Line-break eliminated one space.
breaks = 1
END IF
PRINT: i = i + 1: _CONTINUE
END IF
IF i = r2(j) THEN
j = j + 1: IF j > UBr1 THEN j = 0
COLOR 0, 4: k = 1
END IF
IF k > LEN(find$) THEN k = 0: COLOR 7, 1
PRINT x$;
breaks = 0
IF k THEN k = k + 1
IF CSRLIN > _HEIGHT - 2 THEN EXIT FOR
NEXT
x$ = "": j = 0: k = 0: breaks = 0
LOCATE y, x
RETURN
show2:
FOR i = 1 TO LEN(a$)
x$ = MID$(a$, i, 1)
IF x$ = CHR$(13) THEN PRINT: i = i + 1: _CONTINUE
PRINT x$;
IF CSRLIN > _HEIGHT - 2 THEN EXIT FOR
NEXT
x$ = ""
RETURN
clrvars:
a2$ = "": x$ = "": sp$ = "": sp2$ = "": find$ = "": find2$ = "": replace$ = ""
i = 0: j = 0: k = 0: l = 0: m = 0: lb = 0: q = 0: fnd = 0: breaks = 0
seed = 0: seed1 = 0: seed2 = 0: findreplace = 0: falseflag = 0
ERASE line_break: ERASE r1: ERASE r2
chop = 0: UBr1 = 0: UBr2 = 0
RETURN
END SUB
SUB myform (fld, yfield(), xfield(), flen(), maxlen(), text$(), mtop, mleft, mhovery, mhoverx, b1TopLtx, b1BtmRtx, b1TopRty, b1BtmLty, b2TopLtx, b2BtmRtx, b2TopRty, b2BtmLty, inpclose, find$, replace$, findreplace)
myform_c1 = _DEFAULTCOLOR: myform_c2 = _BACKGROUNDCOLOR
ctext = 15: hl1 = 0: hl2 = 4
PCOPY 0, 2
REM mypalette Already called in main for screen color.
mtop = 3: mwidth = 60: mheight = 11: mleft = 5
RESTORE myformdata
j = 0: noe = 7 ' Number of elements in each data field.
DO
j = j + 1
READ a$
IF a$ = "EOF" THEN EXIT DO
IF j MOD noe = 0 THEN j = 0: fld = fld + 1 ' Number of fields from our data statement.
LOOP
REDIM ncol(fld) ' Name start column.
REDIM nfield$(fld) ' Name.
REDIM yfield(fld) ' Row.
REDIM xfield(fld) ' Column.
REDIM flen(fld) ' Field length.
REDIM maxlen(fld) ' Max text length.
REDIM text$(fld) ' Text input
RESTORE myformdata
DO ' Falx loop.
FOR i = 1 TO fld
FOR j = 1 TO noe: READ a$: IF a$ = "EOF" THEN EXIT DO
SELECT CASE j
CASE 1: ncol(i) = VAL(a$) + mleft
CASE 2: nfield$(i) = a$
CASE 3: yfield(i) = VAL(a$) + mtop
CASE 4: xfield(i) = VAL(a$) + mleft
CASE 5: flen(i) = VAL(a$)
CASE 6: maxlen(i) = VAL(a$)
CASE 7: text$(i) = a$
' Edit # of cases if noe is changed from 5.
END SELECT
NEXT j
NEXT
LOOP
COLOR 0, 5
LOCATE mtop, mleft
COLOR 0, 5
PRINT CHR$(218) + STRING$(mwidth - 2, 196) + CHR$(191)
FOR i = 1 TO mheight - 2
LOCATE , mleft
PRINT CHR$(179); SPACE$(mwidth - 2) + CHR$(179)
NEXT
COLOR 0, 5: LOCATE , mleft
PRINT CHR$(192) + STRING$(mwidth - 2, 196) + CHR$(217)
' Shadow below.
LOCATE , mleft + 1: COLOR 8, 0
FOR i = 1 TO mwidth + 1
x = SCREEN(CSRLIN, POS(0))
PRINT CHR$(x);
NEXT
' Shadow to right.
LOCATE mtop + 1
FOR i = 1 TO mheight - 1
LOCATE , mleft + mwidth
x = SCREEN(CSRLIN, POS(0))
PRINT CHR$(x);
x = SCREEN(CSRLIN, POS(0))
PRINT CHR$(x)
NEXT
' Close symbol.
COLOR 0, 5: LOCATE mtop, mleft + mwidth - 4: PRINT " x ";
mhoverx = mleft + mwidth - 3: mhovery = mtop
' Buttons
LOCATE mtop + 7, mleft + 14: b1TopRty = CSRLIN: b1TopLtx = POS(0)
PRINT CHR$(218) + STRING$(12, 196) + CHR$(191)
LOCATE , mleft + 14
PRINT CHR$(179); SPACE$(12) + CHR$(179);
LOCATE CSRLIN + 1, mleft + 14
PRINT CHR$(192) + STRING$(12, 196) + CHR$(217);: b1BtmLty = CSRLIN: b1BtmRtx = POS(0) - 1
LOCATE mtop + 8, mleft + 17: PRINT "Find All"
LOCATE mtop + 7, mleft + 32: b2TopRty = CSRLIN: b2TopLtx = POS(0)
PRINT CHR$(218) + STRING$(13, 196) + CHR$(191)
LOCATE , mleft + 32
PRINT CHR$(179); SPACE$(13) + CHR$(179)
LOCATE , mleft + 32
PRINT CHR$(192) + STRING$(13, 196) + CHR$(217);: b2BtmLty = CSRLIN: b2BtmRtx = POS(0) - 1
LOCATE mtop + 8, mleft + 34: PRINT "Replace All"
' Fields.
FOR i = 1 TO fld
LOCATE yfield(i), ncol(i)
COLOR 0, 5
PRINT nfield$(i); ":";
LOCATE yfield(i), xfield(i) - 1
COLOR 0, 5: PRINT CHR$(222);
COLOR 15, 0: PRINT SPACE$(flen(i));
NEXT
COLOR 15, 0
fld = 1 ' Set to first field.
LOCATE yfield(fld), xfield(fld)
DO
myinput find$, replace$, findreplace, ctext, hl1, hl2, fld, inpclose, yfield(), xfield(), flen(), maxlen(), text$(), mtop, mleft, mhovery, mhoverx, b1TopLtx, b1BtmRtx, b1TopRty, b1BtmLty, b2TopLtx, b2BtmRtx, b2TopRty, b2BtmLty
IF inpclose THEN EXIT DO
LOOP
COLOR myform_c1, myform_c2
EXIT SUB '--------------------------------------------------------->
myformdata: ' Name column, name, input row, input column, input length, max length, initial text
DATA 3,"Find",2,12,43,250,""
DATA 3,"Replace",5,12,43,250,""
DATA EOF
END SUB
SUB myinput (find$, replace$, findreplace, ctext, hl1, hl2, fld, inpclose, yfield(), xfield(), flen(), maxlen(), text$(), mtop, mleft, mhovery, mhoverx, b1TopLtx, b1BtmRtx, b1TopRty, b1BtmLty, b2TopLtx, b2BtmRtx, b2TopRty, b2BtmLty)
' Single line keyboard routine for input.
STATIC tabx AS INTEGER, tabmax AS INTEGER, mhlinput AS _BIT, menu$()
IF tabx = 0 THEN tabx = 1: tabmax = 4
LOCATE , , 1 ' Show cursor.
start_column = xfield(fld) ' Margin right.
mr = start_column + flen(fld)
y = yfield(fld): x = xfield(fld) ' Initial cursor position.
DO
_LIMIT 60
string_pos = POS(0) - start_column ' Track cursor and word position.
my_mse_kbd lb, mb, rb, my, mx, mw, shift%, clkcnt, drag, b$, mhovery, mhoverx
bmovr = mx > b1TopLtx AND mx < b1BtmRtx AND my > b1TopRty AND my < b1BtmLty
IF tabx = 3 OR bmovr THEN
y = CSRLIN: x = POS(0)
mc1 = 1: mycolor mc1
IF tabx = 3 AND NOT bmovr THEN COLOR 9, 5 ELSE COLOR 12, 5
LOCATE mtop + 7, mleft + 14, 0 ' Hide cursor.
PRINT CHR$(218) + STRING$(12, 196) + CHR$(191)
LOCATE , mleft + 14
PRINT CHR$(179);: LOCATE , POS(0) + 12: PRINT CHR$(179);
LOCATE CSRLIN + 1, mleft + 14
PRINT CHR$(192) + STRING$(12, 196) + CHR$(217);
b1hover = 1
LOCATE y, x
IF tabx < 3 THEN LOCATE , , 1 ' Show cursor.
mc1 = 2: mycolor mc1
ELSE
IF b1hover THEN
y = CSRLIN: x = POS(0)
mc1 = 1: mycolor mc1
COLOR 0, 5
LOCATE mtop + 7, mleft + 14, 0 ' Hide cursor.
PRINT CHR$(218) + STRING$(12, 196) + CHR$(191)
LOCATE , mleft + 14
PRINT CHR$(179);: LOCATE , POS(0) + 12: PRINT CHR$(179);
LOCATE CSRLIN + 1, mleft + 14
PRINT CHR$(192) + STRING$(12, 196) + CHR$(217);
b1hover = 0
LOCATE y, x
IF tabx < 3 THEN LOCATE , , 1 ' Show cursor.
mc1 = 2: mycolor mc1
END IF
END IF
bmovr = mx > b2TopLtx AND mx < b2BtmRtx AND my > b2TopRty AND my < b2BtmLty
IF tabx = 4 OR bmovr THEN
y = CSRLIN: x = POS(0)
mc1 = 1: mycolor mc1
IF tabx = 4 AND NOT bmovr THEN COLOR 9, 5 ELSE COLOR 12, 5
LOCATE mtop + 7, mleft + 32, 0 ' Hide cursor.
PRINT CHR$(218) + STRING$(13, 196) + CHR$(191)
LOCATE , mleft + 32
PRINT CHR$(179);: LOCATE , POS(0) + 13: PRINT CHR$(179);
LOCATE CSRLIN + 1, mleft + 32
PRINT CHR$(192) + STRING$(13, 196) + CHR$(217);
b2hover = 1
LOCATE y, x
IF tabx < 3 THEN LOCATE , , 1 ' Show cursor.
mc1 = 2: mycolor mc1
ELSE
IF b2hover THEN
y = CSRLIN: x = POS(0)
mc1 = 1: mycolor mc1
COLOR 0, 5
LOCATE mtop + 7, mleft + 32, 0 ' Hide cursor.
PRINT CHR$(218) + STRING$(13, 196) + CHR$(191)
LOCATE , mleft + 32
PRINT CHR$(179);: LOCATE , POS(0) + 13: PRINT CHR$(179);
LOCATE CSRLIN + 1, mleft + 32
PRINT CHR$(192) + STRING$(13, 196) + CHR$(217);
b2hover = 0
LOCATE y, x
IF tabx < 3 THEN LOCATE , , 1 ' Show cursor.
mc1 = 2: mycolor mc1
END IF
END IF
IF drag = 0 AND mhlinput THEN mhlinput = 0 ' Quit mouse input line highlighting.
IF lb > 0 OR drag THEN ' Mouse button events.
DO
IF drag THEN
IF my = yfield(fld) OR mhlinput THEN
IF mx >= start_column - hscr AND mx <= start_column + LEN(text$(fld)) - hscr OR mhlinput THEN
mhlinput = -1
IF drag > 0 THEN
IF mx > POS(0) - 1 THEN
shift% = -1: GOSUB cursor_forward
string_pos = POS(0) - start_column
y = CSRLIN: x = POS(0)
END IF
ELSE
IF mx < POS(0) THEN
shift% = -1: GOSUB cursor_back
string_pos = POS(0) - start_column
y = CSRLIN: x = POS(0)
END IF
END IF
END IF
EXIT DO
END IF
END IF
IF lb = 1 OR clkcnt THEN
FOR i = 1 TO UBOUND(yfield) ' Locate input line.
IF my = yfield(i) AND mx >= xfield(i) AND mx <= xfield(i) + flen(i) THEN i = -i: EXIT FOR
NEXT
IF i < 0 THEN ' Mouse cursor in an input field.
IF hl THEN GOSUB hl_off
i = ABS(i)
IF i <> 1 THEN IF text$(1) = "" THEN BEEP: EXIT DO ' Unique restriction when no text is present in first input field.
fld = i: tabx = i
IF clkcnt THEN GOSUB select_all ELSE GOSUB relocate
y = CSRLIN: x = POS(0)
END IF
EXIT DO
END IF
IF lb = 2 THEN ' Mouse button pressed and released.
IF mx > b1TopLtx AND mx < b1BtmRtx AND my > b1TopRty AND my < b1BtmLty THEN
IF LEN(text$(1)) THEN
' Form button 1 selected.
y = CSRLIN: x = POS(0)
mc1 = 1: mycolor mc1
FOR i = 1 TO 2
IF i = 1 THEN COLOR 1, 5 ELSE COLOR 0, 5
LOCATE mtop + 7, mleft + 14, 1
PRINT CHR$(218) + STRING$(12, 196) + CHR$(191)
LOCATE , mleft + 14
PRINT CHR$(179);: LOCATE , POS(0) + 12: PRINT CHR$(179);
LOCATE CSRLIN + 1, mleft + 14
PRINT CHR$(192) + STRING$(12, 196) + CHR$(217);
_DELAY .1
NEXT
mc1 = 2: mycolor mc1
b1hover = 0
find$ = text$(1)
text$(1) = "": text$(2) = ""
inpclose = 1
LOCATE y, x, 1
EXIT DO
ELSE
BEEP
END IF
END IF
IF mx > b2TopLtx AND mx < b2BtmRtx AND my > b2TopRty AND my < b2BtmLty THEN
IF LEN(text$(1)) THEN
' Form button 2 selected.
y = CSRLIN: x = POS(0)
mc1 = 1: mycolor mc1
FOR i = 1 TO 2
IF i = 1 THEN COLOR 1, 5 ELSE COLOR 0, 5
LOCATE mtop + 7, mleft + 32, 1
PRINT CHR$(218) + STRING$(13, 196) + CHR$(191)
LOCATE , mleft + 32
PRINT CHR$(179);: LOCATE , POS(0) + 13: PRINT CHR$(179);
LOCATE CSRLIN + 1, mleft + 32
PRINT CHR$(192) + STRING$(13, 196) + CHR$(217);
_DELAY .1
NEXT
b2hover = 0
mc1 = 2: mycolor mc1
IF hl THEN GOSUB hl_off
find$ = text$(1): replace$ = text$(2)
findreplace = 1
text$(1) = "": text$(2) = ""
inpclose = 1
LOCATE y, x, 1
EXIT DO
ELSE
BEEP
END IF
END IF
IF mx = mhoverx AND my = mhovery THEN
y = CSRLIN: x = POS(0)
inpclose = -1
LOCATE my, mx - 1, 0
mc1 = 2: mycolor mc1
PALETTE 2, 44
COLOR 7, 6
PRINT " x ";
_DELAY .2
PALETTE 2, 36
LOCATE my, mx - 1
COLOR 15, 6
PRINT " x ";
mc1 = 2: mycolor mc1
_DELAY .1
LOCATE y, x
END IF
EXIT DO
END IF
PRINT "error": END ' No condition should end up here.
LOOP
IF inpclose THEN EXIT DO
END IF
IF rb = 2 THEN
IF menu.var < 1 THEN
IF my <> yfield(fld) THEN ' Check for change input field click.
FOR i = 1 TO UBOUND(yfield)
IF my = yfield(i) THEN ' Change input fields.
IF i <> 1 THEN IF text$(1) = "" THEN BEEP: EXIT DO ' Unique restriction when no text is present in first input field.
fld = i: tabx = i
GOSUB relocate
EXIT FOR
END IF
NEXT
END IF
MyPopup menu$(), text$(), fld, hl, menu.var, b$
LOCATE , , 1 ' Show cursor
COLOR ctext, 0 ' Note for future changes: This should be done in popup.
SELECT CASE menu.var
CASE 1: b$ = CHR$(24)
CASE 2: b$ = CHR$(3)
CASE 3: b$ = CHR$(22)
CASE 4: b$ = CHR$(0) + "S"
CASE 5: b$ = CHR$(1)
CASE 6 ' Do nothing.
CASE 7: b$ = CHR$(27)
END SELECT
menu.var = 0
END IF
END IF
IF LEN(b$) THEN
SELECT CASE b$
CASE CHR$(27) ' Esc key.
inpclose = -1
ERASE text$
EXIT DO ' Leave sub and close window.
CASE CHR$(9) ' Tab key. Change text fields.
IF hl THEN GOSUB hl_off: GOSUB cur_home
SELECT CASE tabx
CASE 1
IF LEN(text$(fld)) THEN
fld = fld + 1: IF fld > UBOUND(yfield) THEN fld = 1
LOCATE yfield(fld), xfield(fld)
tabx = tabx + 1: IF tabx > tabmax THEN tabx = 1
EXIT DO ' Leave sub but maintain window.
ELSE
BEEP
_CONTINUE
END IF
CASE 2
LOCATE , , 0
tabx = tabx + 1: IF tabx > tabmax THEN tabx = 1
CASE 3
tabx = tabx + 1: IF tabx > tabmax THEN tabx = 1
CASE 4
tabx = tabx + 1: IF tabx > tabmax THEN tabx = 1
fld = fld + 1: IF fld > UBOUND(yfield) THEN fld = 1
LOCATE yfield(fld), xfield(fld), 1
END SELECT
CASE CHR$(13) ' Enter key.
IF text$(1) = "" THEN BEEP: _CONTINUE
IF hl THEN GOSUB hl_off
SELECT CASE tabx
CASE 1
find$ = text$(1)
text$(1) = "": text$(2) = ""
inpclose = 1
EXIT DO ' Leave sub but maintain window.
CASE 2
find$ = text$(1): replace$ = text$(2)
findreplace = 1
text$(1) = "": text$(2) = ""
inpclose = 1
EXIT DO ' Leave sub but maintain window.
CASE 3
find$ = text$(1)
text$(1) = "": text$(2) = ""
inpclose = 1
EXIT DO ' Leave sub but maintain window.
CASE 4
find$ = text$(1): replace$ = text$(2)
findreplace = 1
text$(1) = "": text$(2) = ""
inpclose = 1
EXIT DO ' Leave sub but maintain window.
END SELECT
fld = fld + 1: IF fld > UBOUND(yfield) THEN
fld = 1
ELSE
LOCATE yfield(fld), xfield(fld)
END IF
EXIT DO ' Leave sub but maintain window.
CASE CHR$(8) ' Backspace key.
GOSUB backspace
CASE CHR$(0) + "S" ' Delete key.
GOSUB delete
CASE CHR$(0) + "M" ' Arrow right key.
GOSUB cursor_forward
CASE CHR$(0) + "K" ' Arrow left key.
GOSUB cursor_back
CASE CHR$(0) + "t" ' Ctrl + Arrow right key.
GOSUB ctrl_rt
CASE CHR$(0) + "s" ' Ctrl + Arrow left key.
GOSUB ctrl_lt
CASE CHR$(0) + "G" ' Home
GOSUB cur_home
CASE CHR$(0) + "O" ' End
GOSUB cur_end
CASE CHR$(0) + "R" ' Insert/overwrite toggel
ovw = 1 - ovw
IF ovw = 0 THEN LOCATE , , 1, 7, 7 ELSE LOCATE , , 1, 7, 30
CASE CHR$(22) ' Ctrl + V - Paste
GOSUB paste
CASE CHR$(3) ' Ctrl + C - Copy
GOSUB copy
CASE CHR$(24) ' Ctrl + X - Cut
GOSUB cut
CASE CHR$(1) ' Select all.
GOSUB select_all
CASE CHR$(32) TO "z"
IF tabx < 3 THEN GOSUB print_chr
END SELECT
y = CSRLIN: x = POS(0) ' Track cursor.
END IF
LOOP
IF inpclose THEN ' Close window.
hscr = 0: mhovery = 0: mhoverx = 0: mhlinput = 0: tabx = 0: fld = 0
PCOPY 2, 0
LOCATE , , 0
END IF
EXIT SUB
print_chr:
IF hl THEN GOSUB cut: string_pos = POS(0) - start_column
IF string_pos + start_column < mr - 1 AND LEN(text$(fld)) < mr - start_column - 1 THEN
IF start_column + LEN(text$(fld)) < mr THEN
text$(fld) = MID$(text$(fld), 1, string_pos) + b$ + MID$(text$(fld), string_pos + 1 + ovw)
LOCATE , start_column: PRINT SPACE$(mr - start_column);: LOCATE , start_column
PRINT text$(fld);
LOCATE , start_column + string_pos + 1
END IF
ELSE ' Horizontal scrolling.
IF LEN(text$(fld)) < maxlen(fld) THEN
IF string_pos = mr - start_column - 1 OR string_pos = mr - start_column - 2 AND string_pos < LEN(text$(fld)) - hscr - 1 THEN
j = 1 ' At right margin.
ELSEIF string_pos = LEN(text$(fld)) - hscr THEN
j = 0 ' Cursor leading text.
ELSE
j = 0 ' Cursor inside text.
END IF
text$(fld) = MID$(text$(fld), 1, hscr + string_pos) + b$ + MID$(text$(fld), hscr + string_pos + 1 + ovw)
hscr = hscr + j
LOCATE , start_column
IF ovw THEN PRINT SPACE$(mr - start_column);: LOCATE , start_column
PRINT MID$(text$(fld), hscr + 1, mr - start_column);
LOCATE , start_column + string_pos + 1 - j
END IF
END IF
RETURN
backspace:
IF hl AND shift% = 0 THEN GOSUB cut
IF string_pos = 0 AND hscr > 0 OR string_pos > 0 THEN
IF hl THEN GOSUB hl_off
text$(fld) = MID$(text$(fld), 1, hscr + string_pos - 1) + MID$(text$(fld), hscr + string_pos + 1)
IF hscr THEN hscr = hscr - 1: j = 0 ELSE j = 1
LOCATE , start_column: PRINT SPACE$(mr - start_column);
LOCATE , start_column
PRINT MID$(text$(fld), hscr + 1, mr - start_column);
LOCATE , x - j
END IF
RETURN
delete:
IF hl THEN
GOSUB cut
ELSE
text$(fld) = MID$(text$(fld), 1, hscr + string_pos) + MID$(text$(fld), hscr + string_pos + 2)
LOCATE , start_column: PRINT SPACE$(mr - start_column);
LOCATE , start_column
PRINT MID$(text$(fld), hscr + 1, mr - start_column);
LOCATE , x
END IF
RETURN
cur_home:
DO
GOSUB cursor_back
string_pos = POS(0) - start_column
LOOP UNTIL hscr = 0 AND string_pos = 0
RETURN
cur_end:
DO
GOSUB cursor_forward
string_pos = POS(0) - start_column
LOOP UNTIL string_pos + 1 > LEN(text$(fld)) - hscr
RETURN
cursor_forward:
IF hl AND shift% = 0 THEN GOSUB hl_off
IF string_pos + 1 <= LEN(text$(fld)) - hscr THEN
IF start_column + string_pos + 1 = mr AND LEN(text$(fld)) > mr - start_column AND shift% = 0 THEN
hscr = hscr + 1
LOCATE , start_column: PRINT SPACE$(mr - start_column);: LOCATE , start_column
PRINT MID$(text$(fld), hscr + 1, mr - start_column);
IF string_pos <> LEN(text$(fld)) - hscr THEN LOCATE , POS(0) - 1
ELSEIF shift% AND string_pos < LEN(text$(fld)) - hscr THEN
IF string_pos = mr - start_column - 1 THEN
hscr = hscr + 1
COLOR ctext, 0
LOCATE , start_column: PRINT SPACE$(mr - start_column);: LOCATE , start_column
IF string_pos - hl > mr - start_column THEN
PRINT MID$(text$(fld), hscr + 1, (mr - start_column) - 1);
ELSE
PRINT MID$(text$(fld), hscr + 1, string_pos - hl - 1);
END IF
IF hl < 0 THEN COLOR ctext, 0 ELSE COLOR hl1, hl2
hl = hl + 1
IF POS(0) = start_column THEN
PRINT MID$(text$(fld), hscr + 1, mr - start_column - 1);
ELSE
PRINT MID$(text$(fld), hscr + 1 + string_pos - hl, (mr - start_column) - (string_pos - hl) - 1);
END IF
ELSE
IF hl < 0 THEN COLOR ctext ELSE COLOR hl1, hl2
hl = hl + 1
PRINT MID$(text$(fld), hscr + string_pos + 1, 1);
END IF
ELSE
IF hl THEN GOSUB hl_off
IF POS(0) < mr THEN LOCATE , POS(0) + 1
END IF
COLOR ctext
END IF
RETURN
cursor_back:
IF hl AND shift% = 0 THEN GOSUB hl_off
IF string_pos = 0 AND shift% = 0 THEN
IF hscr THEN hscr = hscr - 1: PRINT MID$(text$(fld), hscr + 1, mr - start_column);: LOCATE , start_column
ELSEIF shift% THEN
IF string_pos = 0 THEN
IF hscr THEN
hscr = hscr - 1
IF hl > 0 THEN COLOR ctext, 0 ELSE COLOR hl1, hl2
hl = hl - 1
j = ABS(hl): IF j > (mr - start_column) THEN j = mr - start_column
PRINT MID$(text$(fld), hscr + 1, j);
COLOR ctext, 0: PRINT MID$(text$(fld), hscr + 1 + j, (mr - start_column) - j);
LOCATE , start_column
END IF
ELSE
LOCATE , POS(0) - 1
IF hl > 0 THEN COLOR ctext, 0 ELSE COLOR hl1, hl2
PRINT MID$(text$(fld), hscr + string_pos, 1);
LOCATE , POS(0) - 1
hl = hl - 1
END IF
COLOR ctext, 0
ELSE
IF hl THEN GOSUB hl_off
LOCATE , POS(0) - 1
END IF
RETURN
ctrl_rt:
DO
GOSUB cursor_forward
string_pos = POS(0) - start_column
LOOP UNTIL MID$(text$(fld), hscr + string_pos, 1) = " " OR string_pos >= LEN(text$(fld)) - hscr
RETURN
ctrl_lt:
DO
GOSUB cursor_back
string_pos = POS(0) - start_column
LOOP UNTIL MID$(text$(fld), hscr + string_pos, 1) = " " OR POS(0) = start_column AND hscr = 0
RETURN
hl_off:
j = POS(0)
LOCATE , start_column
COLOR ctext, 0
PRINT MID$(text$(fld), hscr + 1, mr - start_column);
LOCATE , j
hl = 0
RETURN
cut:
COLOR ctext, 0
SELECT CASE hl
CASE IS > 0
IF b$ = CHR$(24) THEN _CLIPBOARD$ = MID$(text$(fld), string_pos + 1 + hscr - hl, hl) ' Only copy to clipboard for 'cut' and not delete or paste over highlighted text calls.
j = start_column + string_pos - hl
LOCATE , start_column
PRINT SPACE$(mr - start_column);
text$(fld) = MID$(text$(fld), 1, hscr + string_pos - hl) + MID$(text$(fld), hscr + string_pos + 1)
LOCATE , start_column
IF j < start_column THEN hscr = hscr + string_pos - hl: j = start_column
PRINT MID$(text$(fld), hscr + 1, mr - start_column);
LOCATE , j
CASE 0
' Do nothing
CASE IS < 0
IF b$ <> CHR$(0) + "S" THEN _CLIPBOARD$ = MID$(text$(fld), string_pos + 1 + hscr, ABS(hl))
LOCATE , start_column
PRINT SPACE$(mr - start_column);
text$(fld) = MID$(text$(fld), 1, hscr + string_pos) + MID$(text$(fld), hscr + string_pos + 1 + ABS(hl))
LOCATE , start_column
PRINT MID$(text$(fld), hscr + 1, mr - start_column);
LOCATE , start_column + string_pos
END SELECT
hl = 0 ' No need for hl_off.
RETURN
copy:
SELECT CASE hl
CASE LEN(text$(fld)) ' Select all.
_CLIPBOARD$ = text$(fld)
CASE 1 TO LEN(text$(fld)) - 1
_CLIPBOARD$ = MID$(text$(fld), string_pos + 1 - hl, hl)
CASE 0
' Do nothing
CASE IS < 0
_CLIPBOARD$ = MID$(text$(fld), string_pos + 1, ABS(hl))
END SELECT
RETURN
paste:
IF LEN(_CLIPBOARD$) THEN
IF INSTR(_CLIPBOARD$, CHR$(13)) THEN
tmp$ = "": j = 0
FOR i = 1 TO LEN(_CLIPBOARD$)
x$ = MID$(_CLIPBOARD$, i, 1)
IF x$ = CHR$(13) AND j = 0 THEN
tmp$ = tmp$ + " "
j = -1
ELSE
IF ASC(x$) > 32 THEN j = 0
IF j = 0 THEN tmp$ = tmp$ + x$
END IF
NEXT
ELSE
tmp$ = _CLIPBOARD$
END IF
IF LEN(text$(fld)) - ABS(hl) + LEN(tmp$) <= maxlen(fld) THEN
IF hl THEN GOSUB cut
s1 = CSRLIN: s2 = POS(0): LOCATE 1, 1: PRINT hscr; LEN(tmp$), s2, string_pos, mr, start_column; " ": LOCATE s1, s2
text$(fld) = MID$(text$(fld), 1, hscr + string_pos) + tmp$ + MID$(text$(fld), hscr + string_pos + 1)
IF POS(0) + LEN(tmp$) + 1 >= mr THEN
i = hscr
hscr = hscr + POS(0) + LEN(tmp$) + 1 - mr
s1 = CSRLIN: s2 = POS(0): LOCATE 1, 1: PRINT hscr; LEN(tmp$), s2, string_pos, mr, start_column; " ": LOCATE s1, s2
j = POS(0) + LEN(tmp$) - (hscr - i)
ELSE
j = POS(0) + LEN(tmp$)
END IF
LOCATE , start_column: PRINT SPACE$(mr - start_column);
LOCATE , start_column: PRINT MID$(text$(fld), hscr + 1, mr - start_column);
LOCATE , j
ELSE
BEEP ' Too many characters to paste.
END IF
END IF
RETURN
select_all:
GOSUB cur_end
hl = LEN(text$(fld))
LOCATE , start_column
COLOR hl1, hl2
PRINT MID$(text$(fld), hscr + 1, mr - start_column);
COLOR ctext, 0
RETURN
relocate:
IF text$(i) = "" THEN
LOCATE yfield(i), start_column: PRINT MID$(text$(fld), 1, mr - start_column);
ELSE
IF mx <= xfield(fld) + LEN(text$(fld)) THEN
LOCATE my, mx
ELSE
IF LEN(text$) >= flen(fld) - 1 THEN
LOCATE yfield(fld), xfield(fld) + flen(fld) - 1
ELSE
LOCATE yfield(fld), xfield(fld) + LEN(text$(fld))
END IF
END IF
END IF
RETURN
END SUB
SUB MyPopup (menu$(), text$(), fld, hl, menu.var, b$) ' Self-contained subroutine.
STATIC initialize_menu, WinCon.noi, oldmy
IF initialize_menu = 0 THEN
initialize_menu = 1
RESTORE WinMenuData
WinCon.noi = 0
DO
READ tmp$
IF tmp$ = "eof" THEN EXIT DO
WinCon.noi = WinCon.noi + 1
REDIM _PRESERVE menu$(WinCon.noi)
menu$(WinCon.noi) = tmp$
LOOP
WinMenuData:
'-------------------------------------User Defined here.--------------------------------------
DATA Cut.........Ctrl+X,Copy........Ctrl+C,Paste.......Ctrl+V,Clear..........Del,Select All..Ctrl+A
'---------------------------------------------------------------------------------------------
DATA Close..........Esc,Exit Find...Alt+F4,eof
END IF
y = CSRLIN: x = POS(0)
LOCATE , , 0 ' Hide cursor
DIM atmp AS STRING
REDIM menu_restrict(WinCon.noi)
GOSUB restrict
DO
_LIMIT 30
REM z = GetCursorPos(WinMse)
my_mse_kbd lb, mb, rb, my, mx, mw, shift%, clkcnt, drag, b$, mhovery, mhoverx
mxalt = 0
IF b$ = CHR$(0) + "H" OR mw = -1 THEN
IF (MenuHL - MenuT + 1) \ 2 > 1 THEN
myalt = MenuHL - 2: mxalt = -1
END IF
ELSEIF b$ = CHR$(0) + "P" OR mw = 1 THEN
IF MenuHL = 0 THEN
myalt = MenuT + 1: mxalt = -1
ELSE
IF (MenuHL - MenuT + 1) \ 2 < WinCon.noi THEN
myalt = MenuHL + 2: mxalt = -1
END IF
END IF
ELSEIF b$ = CHR$(13) OR mb = 2 THEN
IF menu_restrict((MenuHL - MenuT + 1) \ 2) = 0 THEN
menu.var = (MenuHL - MenuT + 1) \ 2
EXIT DO
END IF
END IF
SELECT CASE menu.var
CASE -1 ' Hover.
IF mxalt = 0 THEN myalt = my: mxalt = mx
i = myalt > MenuT AND myalt < MenuB AND mxalt > MenuL AND mxalt < MenuR
IF i OR mxalt = -1 THEN
i = (myalt - MenuT) \ 2 <> (myalt - MenuT) / 2 AND myalt <> oldmy
IF i OR mxalt = -1 THEN ' Works for odd or even number top margins.
IF MenuHL THEN ' Remove highlighting from previous hover.
atmp = SPACE$(mwidth - 2)
MID$(atmp, 2, LEN(menu$((MenuHL - MenuT + 1) \ 2))) = menu$((MenuHL - MenuT + 1) \ 2)
LOCATE MenuHL, MenuL + 2 - 1
IF menu_restrict((MenuHL - MenuT + 1) \ 2) THEN COLOR 7, 5 ELSE COLOR 0, 5
PRINT atmp
END IF
atmp = SPACE$(mwidth - 2)
MID$(atmp, 2, LEN(menu$((myalt - MenuT + 1) \ 2))) = menu$((myalt - MenuT + 1) \ 2)
LOCATE myalt, MenuL + 2 - 1
IF menu_restrict((myalt - MenuT + 1) \ 2) THEN COLOR 5, 7 ELSE COLOR 5, 0
PRINT atmp;
COLOR 0, 5
MenuHL = myalt
oldmy = my
END IF
IF lb = 2 THEN
IF menu_restrict((myalt - MenuT + 1) \ 2) = 0 THEN
menu.var = (myalt - MenuT + 1) \ 2
EXIT DO
END IF
END IF
ELSE
' Toggle close menu.
IF lb = 1 THEN
IF myalt >= _SCREENY AND my <= _SCREENY + 24 AND mx >= _SCREENX + 36 AND mx <= _SCREENX + 48 THEN
menu.var = 0: EXIT DO ' Close menu.
ELSE
IF myalt >= _SCREENY AND my <= _SCREENY + _FONTHEIGHT * (_HEIGHT + 1) AND mx >= _SCREENX AND mx <= _SCREENX + _FONTWIDTH * _WIDTH THEN
ELSE ' Outside of app window.
menu.var = 0: EXIT DO ' Close menu.
END IF
END IF
END IF
IF lb = 1 THEN ' Outside of menu closes menu.
menu.var = 0 ' Close.
EXIT DO
END IF
END IF
IF b$ = CHR$(27) THEN b$ = "": EXIT DO ' Simply close popup.
IF LEN(b$) THEN
'-----------------------------------------------------------------------------------------------------------
' Valid menu shortcut key list here.
SELECT CASE b$
CASE CHR$(0) + "S", CHR$(22), CHR$(24), CHR$(1), CHR$(3): EXIT DO
END SELECT
END IF
CASE ELSE ' Open menu.
menu_variety = 1
h = 5 ' Variable to determine margin spaces from the right of menu.
FOR i = 1 TO WinCon.noi
j = LEN(menu$(i))
IF j > k THEN k = j
NEXT
mwidth = k + h
mheight = WinCon.noi * 2 + 1 ' Add one for the separate border element.
SELECT CASE menu_variety
CASE 0 ' Fixed menu to left.
MenuT = 3: MenuL = 1: MenuR = MenuL + mwidth: MenuB = MenuT + mheight
CASE 1 ' Movable menu.
WHILE _MOUSEINPUT: WEND
MenuT = _MOUSEY + 1 ' One below input line.
MenuL = _MOUSEX
IF MenuT + mheight >= _HEIGHT THEN MenuT = _HEIGHT - mheight - 1 ' -1 for shadow.
IF MenuL + mwidth >= _WIDTH THEN MenuL = _WIDTH - mwidth - 1 ' -1 for shadow.
MenuR = MenuL + mwidth: MenuB = MenuT + mheight
END SELECT
menu.var = -1
PCOPY 0, 1
COLOR 0, 5
LOCATE MenuT, MenuL
PRINT CHR$(218) + STRING$(mwidth - 2, 196) + CHR$(191)
FOR i = 1 TO mheight - 2
COLOR 0, 5: LOCATE , MenuL
PRINT CHR$(179); SPACE$(mwidth - 2) + CHR$(179);
COLOR 5, 3: PRINT CHR$(SCREEN(CSRLIN, POS(0))) + CHR$(SCREEN(CSRLIN, POS(0) + 1)): COLOR 1, 5
NEXT
COLOR 0, 5: LOCATE , MenuL
PRINT CHR$(192) + STRING$(mwidth - 2, 196) + CHR$(217);
COLOR 5, 3: PRINT CHR$(SCREEN(CSRLIN, POS(0))) + CHR$(SCREEN(CSRLIN, POS(0) + 1))
LOCATE , MenuL + 2
FOR i = 1 TO mwidth
PRINT CHR$(SCREEN(CSRLIN, POS(0)));
NEXT
LOCATE MenuT + 2, MenuL + 2
FOR i = 0 TO WinCon.noi - 1
LOCATE MenuT + 1 + i * 2, MenuL + 2
IF menu_restrict(i + 1) THEN COLOR 7, 5 ELSE COLOR 0, 5
PRINT menu$(i + 1)
COLOR 0, 5
LOCATE , MenuL
IF i + 1 < WinCon.noi THEN PRINT "Ã" + STRING$(mwidth - 2, CHR$(196)) + "´";
NEXT
END SELECT
LOOP
PCOPY 1, 0
LOCATE y, x
_KEYCLEAR
EXIT SUB
restrict:
IF text$(fld) = "" THEN
FOR i = 1 TO WinCon.noi - 2: menu_restrict(i) = 1: NEXT
ELSE
IF hl = 0 THEN
FOR i = 1 TO 4: menu_restrict(i) = 1: NEXT
END IF
END IF
IF LEN(_CLIPBOARD$) THEN menu_restrict(3) = 0 ELSE menu_restrict(3) = 1
RETURN
END SUB
SUB my_mse_kbd (lb, mb, rb, my, mx, mw, shift%, clkcnt, drag, b$, mhovery, mhoverx)
STATIC oldmy, oldmx, z1, hover, mwy, oldmwy
b$ = INKEY$
IF z1 THEN IF ABS(TIMER - z1) > .3 THEN z1 = 0: clkcnt = 0
IF lb > 0 THEN
IF lb = 1 THEN
lb = -1
ELSE
lb = 0
END IF
END IF
IF rb > 0 THEN IF rb = 1 THEN rb = -1 ELSE rb = 0
IF mb > 0 THEN IF mb = 1 THEN mb = -1 ELSE mb = 0
WHILE _MOUSEINPUT
mwy = mwy + _MOUSEWHEEL
WEND
my = _MOUSEY
mx = _MOUSEX
IF lb = -1 THEN
IF oldmy AND oldmx <> mx OR oldmy AND oldmy <> my THEN
IF mx <> oldmx THEN drag = SGN(mx - oldmx) ' Prevent zero which can occur if mouse moves off row when being draged horizontally.
END IF
END IF
IF drag = 0 THEN
IF mwy <> oldmw THEN
mw = SGN(mwy - oldmwy): mwy = 0
ELSE
mw = 0
END IF
oldmwy = mwy
IF mhoverx AND mx = mhoverx AND my = mhovery THEN
i = SCREEN(my, mx)
y = CSRLIN: x = POS(0)
mc1 = 1: mycolor mc1
COLOR 15, 6: LOCATE my, mx - 1, 0: PRINT " x ";
mc1 = 2: mycolor mc1
LOCATE y, x, 1
hover = 1
ELSE
IF hover THEN
hover = 0
y = CSRLIN: x = POS(0)
LOCATE mhovery, mhoverx - 1, 0
mc1 = 2: mycolor mc1
COLOR 0, 5
PRINT " x ";
LOCATE y, x, 1
mc1 = 2: mycolor mc1
END IF
END IF
IF _KEYDOWN(100303) OR _KEYDOWN(100304) THEN shift% = -1 ELSE IF shift% THEN shift% = 0
END IF
IF lb = -1 AND _MOUSEBUTTON(1) = 0 THEN
lb = 2: drag = 0: hover = 0
ELSEIF rb = -1 AND _MOUSEBUTTON(2) = 0 THEN
rb = 2
ELSEIF mb = -1 AND _MOUSEBUTTON(3) = 0 THEN
mb = 2
END IF
IF _MOUSEBUTTON(1) THEN
IF lb = 0 THEN
lb = 1
IF z1 = 0 THEN
z1 = TIMER ' Let first click through.
ELSE
clkcnt = clkcnt + 1
END IF
END IF
ELSEIF _MOUSEBUTTON(2) AND rb = 0 THEN
rb = 1
ELSEIF _MOUSEBUTTON(3) AND mb = 0 THEN
mb = 1
END IF
oldmy = my: oldmx = mx
END SUB
SUB mypalette
PALETTE 1, 8 ' Page background. Blue
PALETTE 3, 56 ' Popup background shadow. Grey.
PALETTE 4, 62 ' Highlight text background. Yellow 11 15 59 Other choices.
PALETTE 5, 63 ' Window background. Bright white.
PALETTE 6, 36 ' Close x symbol. Bright red.
PALETTE 9, 1 ' Tab on a button. Medium Blue.
PALETTE 12, 43 ' Hover on a button. Light blue.
END SUB
SUB mycolor (mc1)
STATIC sc1~&, sc2~&
SELECT CASE mc1
CASE 1
sc1~& = _DEFAULTCOLOR: sc2~& = _BACKGROUNDCOLOR
CASE 2
COLOR sc1~&, sc2~&
END SELECT
END SUB
Let me know if you find any any bugs and, as always, use caution with any program that writes to files.
Pete
EDIT: I was so kind replacing your mishighlighted codebox, please use the QB64PE IDE File menu > ExportAs > Forum Codebox in the future. - RhoSigma
