It's a robot golfer. So far, all I can get it to learn is to pound its club repeatedly on the ground, but that's got 90% of the people at my country club completely fooled into thinking it's a real golfer. Now if I can just get it to pee standing up. Hopefully soon. The price of oil isn't getting any cheaper.
Here is my first message on this forum.
I have been asking a few questions on the Discord and thanks to people, I have been able to get this far, but this one requires a forum post.
First of all, I would like to mention that I'm quite a beginner and that I have still a lot to learn - and I'm eager to.
I am currently programming a survival text-based game with RPG elements.
It is basically a loop, with several SELECT CASE. Many functionalities are already in place and working properly : status bars, exploration, building, crafting etc...
There is also a draft for an inventory system, basically only displaying owned items (no interaction with them yet).
I programmed a simple combat system as well, however for it to be fully-fledged, I would need an equipment screen to add weapons and armor which add damage and defense in order to defeat stronger enemies.
This equipment screen would be comprised of about 6 slots, with two-handed weapons taking two slots at once and would look like that :
Code: (Select All)
FUNCTION equipScreen()
CLS
PRINT "Equipment Screen"
PRINT " [Right Hand] " 'here maybe show the variables of the equipment ? equipmentname; equipmentdamage; equipmentdefense; equipmentdurability ?
PRINT " [Left Hand] "
PRINT " [Gloves] "
PRINT " [Armor] "
PRINT " [Shoes] "
PRINT " [Helmet] "
PRINT
PRINT " (E)quip (U)nequip (B)ack"
END FUNCTION
For that, I think I would need arrays, but I don't know in which category to put what and what.
Here is the code I have so far. Let me know how I could improve it, as it doesn't work at the moment.
Would you know what I'm missing/doing wrong, please? I receive the error "Illegal SUB/FUNCTION parameter". I think I'm confused between all those variables, TYPEs and Arrays
Thank you in advance for your help!
Code: (Select All)
DIM enemy (20) as STRING '----- DIM Array or Type?
DIM Shared playername as STRING
DIM Shared damage as INTEGER
DIM Shared defense as INTEGER
DIM Shared health as INTEGER
DIM equip(50) AS equipment '----- DIM Array or Type?
'TYPE equipment ' -------Type or DIM Array ?
' shownname AS STRING
'damage AS INTEGER
'defense AS INTEGER
'durability AS INTEGER
'slot AS INTEGER
'END TYPE
dim rabbitname as string 'rabbit enemy ---------- Shall I perhaps use a TYPE for "enemy" ?
dim rabbitdamage as integer
dim rabbitdefense as integer
dim rabbithealth as integer
rabbitname = "Rabbit"
rabbitdamage = 2
rabbitdefense = 0
rabbithealth = 6
dim crabname as string 'crab enemy
dim crabdamage as integer
dim crabdefense as integer
dim crabhealth as integer
crabname = "Crab"
crabdamage = 3
crabdefense = 1
crabhealth = 6
TYPE equipment
equipmentname AS STRING
equipmentdamage AS INTEGER
equipmentdefense AS INTEGER
equipmentdurability AS INTEGER
END TYPE
bonespear.equipmentname = "Bone spear" ' ---------- Will this work with TYPE ?
bonespear.equipmentdamage = 2
bonespear.equipmentdefense = 0
bonespear.equipmentdurability = 20
bonespearcount = 0
After that, I would need several more FUNCTIONs I guess, to select equipment, see its stats, put it in a slot, see the new player stats and remove it from the slots.
I have tried to write the code for that, but I don't understand what I'm really doing, as I don't know if I should use TYPE or DIM Arrays, and in what order.
FUNCTION equipItem (slot AS INTEGER, item AS equipment)
' Equip the item in the specified slot
equip(slot) = item
END FUNCTION
FUNCTION unequipItem(slot AS INTEGER)
' Unequip the item in the specified slot
equip(slot).name = ""
equip(slot).damage = 0
equip(slot).defense = 0
equip(slot).durability = 0
END FUNCTION
DIM equipmentchoice$ 'AS STRING in that case
DIM selectedSlot AS INTEGER
DIM selectedItem AS eqItem
initEquip()
DO
equipScreen()
INPUT "Enter your choice: "; equipmentchoice$
SELECT CASE equipmentchoice$
CASE "E"
INPUT "Enter the slot number: "; selectedSlot
IF selectedSlot >= 0 AND selectedSlot < 6 THEN
INPUT "Enter the item number: "; selectedItem
equipItem(selectedSlot, selectedItem)
END IF
CASE "U"
INPUT "Enter the slot number: "; selectedSlot
IF selectedSlot >= 0 AND selectedSlot < 6 THEN
unequipItem(selectedSlot)
END IF
I've created a module that contains all error numbers and the text of the error. It is intended to be placed in the top of the main program, so the info is available for any part of the program. It has been written to work even in OPTION _EXPLICIT programs.
I started a new thread here to respond to @Pete without further hijacking @Mastergy's thread...
(03-22-2024, 02:46 AM)Pete Wrote: I guess I have some loose concept of someday putting together an HTML page I can run locally, with various input fields and boxes to click, which would run programs that would interact with the html page, itself. That way I get the beauty and ease of HTML/CSS pages with the mechanical functionality of QB64.
Pete
So, that you can certainly do today. If you click the share button...
...in one of the examples below and then choose "Auto" as the mode and click "Export"...
...you will be prompted to download a "program.zip". You can then just unzip this file and double-click the index.html to run in a local browser.
Simple Web Calculator
Vince's Egg Designer 2000
This one allows you to use web controls to modify the traditional QB screen:
I am trying to use lower case i, j, and k as counters for looping. To declare them I'm using this:
_define i-k as _unsigned integer
But as soon as I go to the next line, the letters i to k turn uppercase and therefore the lower case i, j, and k which are used in looping get error message that they are not declared.
I tried to use lcase$() to keep the letters in lowercase, but get error message for _define statement.
Screen _ScreenImage
_FullScreen
Do
If InKey$ <> "" Then GoTo sa
Loop
sa:
Screen _NewImage(1920, 1080, 256)
_FullScreen
_MouseHide
Do
For e = 10 To 100
For c = 1 To 10
For w = 0 To 1920 Step e
For i = 0 To 1080 Step 2
x = Sin((i / c) * 3.1415927)
PSet (w + i, (x * w) + 20), 10
PSet (w + i, 1080 - (x * w) + 20), 12
PSet (i, (x * w) + 20), 10
PSet (i, 1080 - (x * w) + 20), 12
PSet (1920 - i, (x * w) + 20), 11
PSet (1920 - i, 1080 - (x * w) + 20), 15
PSet (1920 - i - w, (x * w) + 20), 11
PSet (1920 - i - w, 1080 - (x * w) + 20), 15
If InKey$ <> "" Then System
Next i
Next w
Line (500, 0)-(502, 1080), _RGB(17, 249, 139), BF
Line (550, 0)-(550, 1080), _RGB(17, 249, 139), BF
_Display
Line (0, 0)-(1920, 1080), _RGB(0, 0, 0), BF
'_Delay .00002
Next c
Next e
Loop
_Title "Ad grabber"
Screen _NewImage(1, 1, 8)
idc$ = "addocid" + Chr$(34) + ": " + Chr$(34)
p = 1
While p <= Len(_Clipboard$)
ls = InStr(p, _Clipboard$, Chr$(13))
le = InStr(p, _Clipboard$, Chr$(13))
If le = 0 Then
le = Len(_Clipboard$) + 1
End If
line$ = Mid$(_Clipboard$, ls, le - ls)
If InStr(UCase$(line$), UCase$(idc$)) > 0 Then
sp = ls + InStr(UCase$(line$), UCase$(idc$)) + Len(idc$)
natxt$ = Mid$(_Clipboard$, sp, 11)
_Clipboard$ = "https://www.youtube.com/watch?v=" + natxt$
GoTo done
Exit While
End If
p = le + 1
Wend
done:
If natxt$ = "" Then Sound 44, 2: _Delay 1: System
Sound 1000, 1
_Delay 2
System
I made this simple program to reveal the URL of Youtube ads, including unlisted videos.
At times, you come across a YouTube advertisement that you'd like to share or rewatch.
However, the challenge arises when you can't access the advertisement's URL, only the subsequent video URL.
Also, the ads are often 'unlisted', so you can't even find them with the search function of YouTube.
With Adgrab, it's possible!
Instructions:
1) Right-click on the YouTube ad and select "copy debug info."
2) Open Adgrab.
3) After you hear a high-pitched tone, you can open the video in your browser with Ctrl-V.
If you hear a low-pitched tone, something went wrong.
Well don't get to excited. I may have fell off the SCREEN 0 wagon, temporarily, but this example is just a limited text input routine, in pure graphics mode. Because it allows for italicized and bold text, you'll need to download the attached zip folder and extract the fonts to whatever folder you decide to run this routine in.
You know my regular SCREEN 0 routines had url capabilities, but I only had the option of differentiating the links by color. No italics, and no underlining ability in a text mode screen. Now I could have used hardware graphics in SCREEN 0 to make a hybrid, instead of going all in on graphics, but like I stated in my message header, I got really, really drunk for the 17th. Oh, that reminds me. I used about a half a dozen line statements in the following code, but I'm not sure if any are straight.
Updated 3/22/24 to include more mouse features including clicking hypertext.
Updated 3/24/24 to include cut, copy, paste from keyboard.
Updated 3/28/24 to include ctrl + arrow keys to highlight words. Optimized highlighting for cursor and home/end keys. That was fun, but ctrl + arrows, I'll pass on optimizing that for now.
BIG UPDATE 4/2/24 to include POPUP window for cut/copy/paste/delete/select all/hypertext.
BIGGER UPDATE 4/7/24 to include text formatting buttons. Keys still work, too, and affect the buttons, accordingly.
4/9/24 Finished length restrictions, paste and universal button font changes.
BIGGEST UPDATE 4/19/24 Okay, so now we can make and save 1 page of text with up to 255 links on the page. Use the Enter key to go to a new line of text like an editor or IDE. Note there is no word wrap. Use CTRL + N for a new project, CTRL + S to save a project, and CTRL to O to open a saved project. This release does not check to see if you want to save your work before starting a new project. It also does not compare your present project with a saved version, so until I get around to addressing these and other file management issues, well, just be aware they are not yet available. Oh, I also removed link restrictions, so make sure if you want to go to a website, you start your input with http:// or https:// followed by the url like https://qb64phoenix.com. By removing that restriction we can now input things like "Notepad" and it will open notepad when clicked. Notepad and some other registered Windows apps can be found by SHELL without the inclusion of a drive and path, but other programs you want to launch, using this method, will require you include the drive and path followed by the app name.
Updated 4/20/24 Delete key can now delete a blank line to move lines below it up. Backspace cannot be used this way and will not be modified until wrap is added. Also, fixed one issue with multiple shell instances when dragging over a link.
Updated 4/22/24 Links can now be removed or edited. Right click on link and select to edit or remove.
Updated 4/24/24 Text scrolling with Enter key, arrow up/down keys, or mouse wheel.
Updated 5/25/24 Bug fix.
Code: (Select All)
Rem Note if code is expanded to include word wrap, the disallow length too long routines need to be updated to wrap routines.
Dim Shared debug As Integer
On Error GoTo pete
$Color:32
_ControlChr Off
Type fontvar
nof As Integer ' Number of Fonts.
fsn As Integer ' Font Selection Number 1 reg, 2 Bold, 3 Italic, 4 Bold Italic.
size As Integer ' Font Size.
max_fontheight As Integer ' The Largest Font Size on any Line of Text.
End Type
Dim ft As fontvar
Type textvar
maxchrs As Integer ' The Max Characters of a Text String. IMPORTANT: Cannot be over 255.
noa As Integer ' Number of Text Attributes.
tm As Integer ' Top Margin by Pixel.
bm As Integer ' Bottom Margin by Pixel.
lm As Integer ' Left Margin by Pixel.
rm As Integer ' Right Margin by Pixel.
ln As Integer ' Line number.
row As Integer ' Row by Pixel.
scr As Integer ' Scroll Number.
eop As Integer ' End of Page (The Last Display Line).
nol As Integer ' Total Number of Text Lines.
ccol As Integer ' Numeric Column of a Character.
oldccol As Integer ' Numeric Column of the Previous Cursor Position.
pixcol As Integer ' The Pixel Column the Cursor is On Currently.
insreg As Integer ' Causes a Delay in Changing the Cursor Appearance When the Insert Key is Rapidly Pressed.
reprnt As Integer ' Only Reprints a Row of Characters When Non-zero.
ovr As Integer ' Overwrite mode When Non-zero, Otherwise Insert Mode.
xl As Integer ' Pixel Column for a Character that is Part of a Link.
mindex As Integer ' Numeric Matrix Index.
underline As Integer ' Underline Text.
link As Integer ' Hyperlink Text.
c_wdth As Integer ' Cursor Width in Pixels
c_hght As Integer ' Cursor Height in Pixels.
numchrs As Integer ' Number of Characters in the Line of Text.
sa As Integer ' Special Attributes for Paragraph, Highlighting Markers, etc.
cchr As String ' Cursor Character.
t As String ' Row of Text.
m As String ' Text and Attributes to be Saved in an RA File.
url As String ' URL Link to Follow.
shift As Integer ' Shift Keys.
autoshift As Integer ' Used for Instances Like Mouse Highlighting to Mimic Keyboard Highighting.
ctrl As Integer ' Ctrl key.
alt As Integer ' Alt Key.
hl As Integer ' Highlighting Left (-1) or Right (+1)
arrows As Integer ' Aids the Cursor Update Subroutine When Arrows are Used to Highliht Text.
button_row As Integer ' Row Occupied by the Text Formatting Buttons.
button_status As Integer ' > 0 Mouse Click, < 0 Hotkey. 999 Cycle Termination Code for both. -999 Hotkey Default Status and Terminate Cycle.
prior_colorHL As Integer ' The Prior Color to be Reinstated After Highlighting the Text is Completed.
newproject As Integer ' Creates a new project.
openfile As String ' Forces a redo of varibles and selects the file to open.
tcopy As String ' Copied Text
mcopy As String ' Copied Text Matrix
map_rows As String ' Screen Memory for Text Rows.
map_buttons As String ' Screen Memory for Buttons.
map_links As String ' Screen Memory for Links.
End Type
Dim tx As textvar
Type mousevar
mx As Integer ' Row.
my As Integer ' Column.
wh As Integer ' Wheel.
lb As Integer ' Left Button.
rb As Integer ' Right Button.
lb_status As Integer ' Left Button Status.
rb_status As Integer ' Right Button Status.
CursorStyle As Integer ' 0 Default, 1 Link style. (Hand).
mousekey As String ' Auto Keyboard Input.
End Type
Dim m As mousevar
Type popup
setup As Integer ' Single Use to Initiate Popup Variables.
status As Integer ' 0 Not in Use, 1 Initiated, -1 Displayed, 2 Closed.
nmi As Integer ' Number of Items in the Menu.
pr1 As Integer ' Top Row.
pr2 As Integer ' Bottom Row.
pc1 As Integer ' Left Column.
pc2 As Integer ' Right Column.
phshadow As Integer ' Horizontal shadow.
pvshadow As Integer ' Vertical Shadow.
pwdth As Integer ' Popup Width.
phght As Integer ' Popup Height.
pbgcolor As Integer ' Background Color.
pbbxcolor As Integer ' Box Border Color.
pbshdcolor As Integer ' Shadow Color.
col_matrix As String ' Column.
row_matrix As String ' Row.
chr_wdth As Integer ' Character Width in Pixels.
chr_hght As Integer ' Character Height in Pixels.
restrict As String ' Limits Access to Unavailable Items in Menu.
End Type
Dim pop As popup
' Matrix: 1-tx.maxchrs text, tx.maxchrs + 1 to tx.maxchrs + 10 Special attributes, tx.maxchrs + 11 on are attributes each tx.noa spaces long.
' Example: tx.maxchrs = 255. tx.noa = 12. 1-255 text, 256-265 special attributes, 266-277 attributes for 1st character in text string, 278-289 2nd, etc.
Sub main (ft As fontvar, tx As textvar, m As mousevar, pop As popup)
Static initiate%
If initiate% = 0 Then
Screen _NewImage(1050, 600, 32)
_Display ' Turn off autodisplay.
Color Black, _RGB32(255, 255, 255, 255)
Cls
_Delay .1
_ScreenMove _Middle
_Delay .1
_Clipboard$ = ""
initiate% = -1
End If
Do
_Limit 60
load_font ft, fnum&()
mouse m
keyboard tx, m, b$
text_input ft, tx, m, pop, b$, fnum&(), mtx$(), mylink$(), index_col(), default_cl%(), default_bc%(), cl%(), bc%()
popup_main ft, tx, m, pop
text_buttons tx, m, b$
Loop
End Sub
Sub load_font (ft As fontvar, fnum() As Long)
' Set DEFAULT FONT SIZE at line #7.
Static oldfontsize%
If ft.size = 0 Or ft.size <> oldfontsize% Then
ft.nof = 4 ' Number of Fonts to Load into Memory.
ft.size = oldfontsize% ' Font Size.
If ft.size = 0 Then ft.size = 18 ' Default font size.
ft.fsn = 1 ' Default font style number.
ft.max_fontheight = ft.size
ReDim fnum(ft.nof) As Long
fnum(0) = -1 ' See remark above.
fnum(1) = _LoadFont("RobotoMono-regular.ttf", ft.size)
fnum(2) = _LoadFont("RobotoMono-bold.ttf", ft.size)
fnum(3) = _LoadFont("RobotoMono-italic.ttf", ft.size)
fnum(4) = _LoadFont("RobotoMono-bolditalic.ttf", ft.size)
For i% = 1 To ft.nof
If fnum(i%) <= 0 Then ' Try to load the Windows Lucida Console font.
fnum(1) = _LoadFont(Environ$("SYSTEMROOT") + "\Fonts\lucon.ttf", ft.size)
Exit For
End If
Next
If fnum(1) <= 0 Then
ft.size = 16 ' Default 8 x 16 font.
fnum(1) = ft.size
End If
oldfontsize% = ft.size
End If
End Sub
Sub mouse (m As mousevar)
' Local vars: i%,j%
Static oldmx As Integer, oldmy As Integer
If m.wh Then m.wh = 0
While _MouseInput
m.wh = m.wh + _MouseWheel
Wend
m.mx = _MouseX
m.my = _MouseY
m.lb = _MouseButton(1)
m.rb = _MouseButton(2)
Select Case m.lb
Case 0
Select Case m.lb_status
Case -2
m.lb_status = 0 ' The clicked event and the release triggered any event structured to occur on release.
Case -1
m.lb_status = -2 ' The clicked event triggered any event structured to occur when the button is released.
Case 0
' Button has not been pressed yet.
Case 1
m.lb_status = -1 ' Rare but button was released before the next required cycle, so cycle is continued here.
Case 2
m.lb_status = 0 ' The drag event is over because the button was released.
End Select
Case -1
Select Case m.lb_status ' Note drag is determined in the text highlighting routine.
Case -1
' An event occurred and the button is still down.
If oldmx <> m.mx Or oldmy <> m.my Then m.lb_status = 2 ' Drag.
Case 0
m.lb_status = 1 ' Left button was just pressed.
Case 1
m.lb_status = -1 ' The button is down and triggered any event structured to occur on initial press. The status will remain -1 as long as the button is depressed.
End Select
End Select
Select Case m.rb
Case 0
Select Case m.rb_status
Case -2
m.rb_status = 0 ' The clicked event and the release triggered any event structured to occur on release.
Case -1
m.rb_status = -2 ' The clicked event triggered any event structured to occur when the button is released.
Case 0
' Button has not been pressed yet.
Case 1
m.rb_status = -1 ' Rare but button was released before the next required cycle, so cycle is continued here.
Case 2
m.rb_status = 0 ' The drag event is over because the button was released.
End Select
Case -1
Select Case m.rb_status
Case -1
' An event occurred and the button is still down.
Case 0
m.rb_status = 1 ' button was just pressed.
Case 1
m.rb_status = -1 ' The button is down and triggered any event structured to occur on initial press. The status will remain -1 as long as the button is depressed.
End Select
End Select
oldmx = m.mx: oldmy = m.my
End Sub
Sub keyboard (tx As textvar, m As mousevar, b$)
' Local vars: oldfsn, cur_arrows, fill$, ex_keys%.
Def Seg = 0
i% = Peek(1047) Mod 16
If InStr(Chr$(1) + Chr$(2) + Chr$(5) + Chr$(6) + Chr$(9) + Chr$(10), Chr$(i%)) Then tx.shift = -1 Else tx.shift = 0
If i% = 3 Or i% = 4 Then tx.ctrl = -1 Else tx.ctrl = 0
If i% = 7 Or i% = 8 Then tx.alt = -1 Else tx.alt = 0
Def Seg
If Len(m.mousekey$) Then ' Used to pass automated key response, especially from the mouse routine.
b$ = m.mousekey$: tx.shift = tx.autoshift: m.mousekey$ = "": tx.autoshift = 0
Else
b$ = InKey$
End If
If tx.alt Then
Rem Reserved for Alt key.
_KeyClear
Exit Sub
End If
If tx.ctrl Then
Rem Reserved for Crrl key.
End If
End Sub
Sub text_input (ft As fontvar, tx As textvar, m As mousevar, pop As popup, b$, fnum() As Long, mtx$(), mylink$(), index_col(), default_cl%(), default_bc%(), cl%(), bc%())
Static initiate%, rbx%, rby%, cc!, z1!, oldb$
' Locale vars: i%, cc!
If initiate% = 0 Or Len(tx.openfile) Or tx.newproject = -1 Then
_Font fnum(1) ' Default font.
tx.scr = 0
tx.nol = 0 ' Resets when new or file gets loaded.
' Text and link arrays.
ReDim mtx$(1)
ReDim index_col(tx.maxchrs)
ReDim mylink$(0)
' Color Arrays and Variables.
ReDim cl%(3), bc%(3)
ReDim default_cl%(3), default_bc%(3)
default_cl%(1) = 0: default_cl%(2) = 0: default_cl%(3) = 0
default_bc%(1) = 255: default_bc%(2) = 255: default_bc%(3) = 255
cl%(1) = default_cl%(1): cl%(2) = default_cl%(2): cl%(3) = default_cl%(3)
bc%(1) = default_bc%(1): bc%(2) = default_bc%(2): bc%(3) = default_bc%(3)
' Matrix variables.
tx.maxchrs = 255 ' IMPORTANT: Can't be > 255. If <, error 9 in index_col() possible and line length issues, which are regulated in pixels, not characters.
tx.noa = 12 ' Number of character attributes.
tx.sa = 10 ' Number of special attributes.
' Border variables.
tx.lm = 100 ' Margins in pixels.
tx.tm = 80
tx.bm = tx.tm + (6 + _FontHeight) * 20 - 6
tx.rm = _Width - tx.lm
' Draw text border.
Line (tx.lm - 5, tx.tm - 5)-(tx.rm + 5, tx.bm + 5 + 6), Gray, B ' Text input field.
initiate% = -1
_Font fnum(1) 'Start with default font.
tx.ln = 1 ' Start at text line #1.
tx.row = tx.tm ' Current row in pixels set to the top margin.
If tx.newproject Then tx.newproject = 0 ' Note: openfile is zeroed later.
End If
_Font fnum(ft.fsn)
If Len(tx.openfile) Then
' Note: Variables are zeroed at the beginning of this subroutine.
ff1 = FreeFile
Open tx.openfile For Input As #ff1
Line Input #ff1, a$
g% = tx.ln ' It will always be 1 here.
i% = Val(Mid$(a$, InStr(a$, "LEN=") + 4))
j% = Val(Mid$(a$, InStr(a$, "NOL=") + 4))
k% = Val(Mid$(a$, InStr(a$, "LNK=") + 4))
tx.maxchrs = Val(Mid$(a$, InStr(a$, "MAX=") + 4))
Dim temp As String
temp = String$(i%, Chr$(0))
ReDim _Preserve mylink$(k%)
ReDim _Preserve mtx$(j%)
Close #ff1
ff1 = FreeFile
Open tx.openfile For Binary As #ff1
For h% = 1 To k%
Get #ff1, 1 + h% * i%, temp
mylink$(h%) = Mid$(temp, 1, InStr(temp + Chr$(0), Chr$(0)) - 1)
Next
Close #ff1
tx.openfile = ""
End If
If pop.status Then
If b$ = Chr$(27) Then pop.status = 2
Exit Sub
End If
Do
' Keyboard text events
Select Case Len(b$) ' Key down suspension routine for F1 - F12 keys.
Case 0 ' Time loop to test for key release.
If Len(oldb$) Then
If Abs(z1! - Timer) > .1 Then
oldb$ = ""
End If
End If
Case 1
' Do nothing so typing characters is not affected.
Case 2
i% = Asc(Right$(b$, 1))
If i% = 133 Or i% = 134 Then ' Function key range.
z1! = Timer
If oldb$ <> b$ Then
oldb$ = b$
Sleep 1 ' Needed to prevent double entry.
Else
b$ = "": _Continue
End If
End If
End Select
If Len(b$) Then ' Special to COPY.
If b$ = Chr$(22) Then
temp_oldm$ = tx.m$
temp_oldt$ = tx.t$
If _Clipboard$ <> tx.tcopy$ Then tx.tcopy$ = "": tx.mcopy$ = "" ' A clipboard addition was made from another program.
End If
If tx.hl Then ' Highlighted text key exceptions. 0 = Remove highlighting, -1 = Keep highlighting.
Select Case Len(b$)
Case 1
Select Case b$
Case Chr$(27), Chr$(1), Chr$(3), Chr$(22), Chr$(24): ex_keys% = -1
End Select
If tx.ctrl Then
If ex_keys% = 0 Then Exit Sub ' Non supported key press.
End If
Case 2
If InStr(";<=>?@ABCD…†", Right$(b$, 1)) Then ' Keys F1 - F12.
ex_keys% = -1 ' Will zero-out automatically when leaving subroutine.
Else
If InStr("MKHPIQOGuwst", Right$(b$, 1)) Then
If tx.shift Then
ex_keys% = -1
Else
debug = 391: GoSub direct_reprinting
End If
End If
End If
End Select
End If
' Special to highlighted text and both highlighted and non-highlighted paste.
If tx.hl And ex_keys% = 0 Or tx.hl And b$ = Chr$(3) Or tx.hl And b$ = Chr$(24) Or b$ = Chr$(22) Then ' A key was pressed, text is highlighted, and no F1-F12 key was used.
i% = Asc(Mid$(tx.m$, tx.maxchrs + 1, 1))
j% = Asc(Mid$(tx.m$, tx.maxchrs + 2, 1))
If b$ = Chr$(22) And tx.hl = 0 Then ' Special to (PASTE).
' No highlighted text to copy, just a straight paste.
If _Clipboard$ = "" Then Exit Sub ' No text copied.
Else ' Copy text. Cut and Copy copying plus empty Paste check.
If b$ = Chr$(3) Or b$ = Chr$(24) Then ' Ctrl + c and Ctrl + x (COPY) (CUT).
tx.tcopy$ = Mid$(tx.t$, i%, j% - i% + 1)
tx.mcopy = Mid$(tx.m$, (tx.maxchrs + 1) + tx.sa + (i% - 1) * tx.noa, (j% * tx.noa) - ((i% - 1) * tx.noa))
_Clipboard$ = tx.tcopy$
Select Case b$
Case Chr$(3)
Exit Sub
Case Chr$(24)
tx.hl = 0 ' Clear highlighting upon reprinting. Ctrl + C (COPY) exception.
End Select
Else
If b$ = Chr$(22) Then
If tx.mcopy = "" And _Clipboard$ = "" Then Beep: Exit Sub ' Nothing to paste into highlighted text.
End If
End If
End If
' Special to backspace, delete, Ctrl + X (CUT), and ctrl + V (Paste) over highlighted text.
If b$ = Chr$(8) Or b$ = Chr$(0) + "S" Or b$ = Chr$(24) Or b$ = Chr$(22) And tx.hl Then
fill$ = String$(tx.maxchrs * tx.noa, Chr$(0))
Mid$(fill$, 1, Len(fill$)) = Mid$(tx.m$, (tx.maxchrs + 1) + tx.sa, (i% - 1) * tx.noa) + Mid$(tx.m$, (tx.maxchrs + 1) + tx.sa + j% * tx.noa)
Mid$(tx.m$, (tx.maxchrs + 1) + tx.sa) = fill$ ' Blanks out character attributes but leave special attributes.
Mid$(tx.m$, (tx.maxchrs + 1), 2) = Chr$(0) + Chr$(0) ' Blank both highlighting special attributes.
fill$ = String$(tx.maxchrs, Chr$(0)) ' Now redo the text in the front end.
Mid$(fill$, 1, Len(fill$)) = Left$(tx.t$, i% - 1) + Mid$(tx.t$, j% + 1)
tx.t$ = fill$
matrix_update_method% = 2 ' matrix_col% not required here.
tx.ccol = i%
tx.hl = 0 ' Clear highlighting upon reprinting.
tx.reprnt = -1
If b$ = Chr$(22) Then ' Paste into highlighted text.
debug = 441: GoSub text_paste ' Paste over routine for highlighted text only.
debug = 443: GoSub evaluate_length ' Returns temp_length_check% as 0 or -1.
If temp_length_check% = 0 Then ' Disallow paste, too long. Reestablish initial values of involved variables.
tx.mcopy$ = "": tx.tcopy$ = ""
tx.t$ = temp_oldt$
tx.m$ = temp_oldm$
tx.reprnt = 0 ' Note: Highlighting will be removed via previous tx.hl = 0 statement before the paste condition statement.
debug = 451: GoSub direct_reprinting
Exit Sub
Else
tx.ccol = tx.ccol + Len(tx.tcopy$) ' Advance cursor to last character of pasted text.
End If
End If
b$ = "": _Continue
Else
If b$ <> Chr$(3) Then ' Avoid if copying txt.
If b$ = Chr$(22) Then 'Paste into non-highlighted text.
debug = 463: GoSub text_paste
debug = 465: GoSub evaluate_length ' Returns temp_length_check% as 0 or -1.
If temp_length_check% = -1 Then ' Allow paste.
tx.ccol = tx.ccol + Len(copied_text$)
tx.reprnt = -1
Else ' Disallow paste, too long.
tx.mcopy$ = "": tx.tcopy$ = ""
tx.t$ = temp_oldt$
tx.m$ = temp_oldm$
End If
b$ = "": _Continue
Else ' Replace highlighted text with a typed character.
fill$ = String$(tx.maxchrs * tx.noa, Chr$(0))
Mid$(fill$, 1, Len(fill$)) = Mid$(tx.m$, (tx.maxchrs + 1) + tx.sa, (i% - 1) * tx.noa) + String$(tx.noa, Chr$(0)) + Mid$(tx.m$, (tx.maxchrs + 1) + tx.sa + j% * tx.noa)
Mid$(tx.m$, (tx.maxchrs + 1) + tx.sa) = fill$ ' Blanks out character attributes but leave special attributes.
Mid$(tx.m$, tx.maxchrs + 1, 2) = Chr$(0) + Chr$(0) ' Blank both highlighting special attributes.
fill$ = String$(tx.maxchrs, Chr$(0)) ' Now redo the text in the front end.
Mid$(fill$, 1, Len(fill$)) = Left$(tx.t$, i% - 1) + b$ + Mid$(tx.t$, j% + 1)
tx.t$ = fill$
matrix_col% = i%
matrix_update_method% = 1
tx.ccol = i% + 1
tx.hl = 0
tx.reprnt = -1
b$ = "": _Continue
End If
End If
End If
End If
If b$ = "Edit Link" Then
tx.link = Asc(Mid$(tx.map_links$, (Asc(Mid$(tx.map_rows$, rby% + 1)) - 1) * _Width + rbx% + 1, 1)) ' +1 adjusts for mouse coordinates starting at zero.
tx.url$ = mylink$(tx.link)
follow_link = 4
If Len(tx.url$) Then
mylink$(tx.link) = tx.url$
Else
' Link was removed.
mylink$(tx.link) = ""
j% = InStr(tx.map_links$, Chr$(tx.link))
Do
If InStr(j%, tx.map_links$, Chr$(tx.link)) Then
Mid$(tx.map_links$, InStr(j%, tx.map_links$, Chr$(tx.link)), 1) = Chr$(0)
Else
Exit Do
End If
j% = j% + 1
Loop
matrix_update_method% = 5 ' matrix_col% not required here.
_Delay .5
End If
Exit Sub
End If
Select Case Len(b$) ' Keys for standard text.
Case 1
Select Case b$
Case Chr$(27)
System
Case Chr$(13) ' Enter
m.mousekey$ = Chr$(0) + "P"
Exit Sub
Case Chr$(14) ' New.
tx.newproject = -1
Case Chr$(15) ' Open File.
tx.openfile = _OpenFileDialog$("Open File", "", "*.txt", "Text files", -1)
Exit Sub ' Go around and redo setup and trigger open file condition when enterng back into this routine through the main loop.
Case Chr$(19) ' Save / Save As.
a$ = _SaveFileDialog$("Save File", "", "*.txt", "Text files")
If a$ = "" Then Exit Sub ' Cancelled or closed.
If _FileExists(a$) Then Kill a$
j% = 0
temp = String$(tx.maxchrs * (tx.noa + 1) + tx.sa, Chr$(0)) ' tx.m$ STRING LENGTH.
Mid$(temp, 1, tx.maxchrs) = "MAX=" + LTrim$(Str$(tx.maxchrs)) + "|" + "LEN=" + LTrim$(Str$(Len(temp))) + "|" + "NOL=" + LTrim$(Str$(tx.nol)) + "|" + "LNK=" + LTrim$(Str$(UBound(mylink$)))
ff1 = FreeFile
Open a$ For Binary As #ff1
Put #ff1, 1, temp
For i% = 1 To UBound(mylink$)
temp = String$(tx.maxchrs * (tx.noa + 1) + tx.sa, Chr$(0))
Mid$(temp, 1) = mylink$(i%)
Put #ff1, 1 + i% * Len(temp), temp
Next
For j% = 1 To tx.nol
temp = String$(tx.maxchrs * (tx.noa + 1) + tx.sa, Chr$(0))
Mid$(temp, 1) = mtx$(j%)
Put #ff1, 1 + (i% - 1 + j%) * Len(temp), temp
Next
Close #ff1
Exit Sub
Case Chr$(1) ' Ctrl + A (SELECT ALL).
If tx.numchrs > 0 Then
tx.hl = 1
Mid$(tx.m$, tx.maxchrs + 1, 1) = Chr$(1) ' Always the first character.
Mid$(tx.m$, tx.maxchrs + 2, 1) = Chr$(tx.numchrs)
tx.reprnt = -1
tx.ccol = tx.numchrs + 1
If tx.ccol > tx.maxchrs Then tx.ccol = tx.maxchrs
b$ = "": _Continue
End If
Case Chr$(8) ' backspace
If tx.ccol > 1 Then
' Substitute matrix routine. ---------
fill$ = String$(tx.maxchrs * tx.noa, Chr$(0)): Mid$(fill$, 1, Len(fill$)) = Mid$(tx.m$, (tx.maxchrs + 1) + tx.sa, (tx.ccol - 2) * tx.noa) + Mid$(tx.m$, (tx.maxchrs + 1) + tx.sa + (tx.ccol - 1) * tx.noa)
Mid$(tx.m$, (tx.maxchrs + 1) + tx.sa) = fill$ ' Blanks out character attributes but leave special attributes.
fill$ = String$(tx.maxchrs, Chr$(0)) ' Now redo the text in the front end.
Mid$(fill$, 1, Len(fill$)) = Mid$(tx.t$, 1, tx.ccol - 2) + Mid$(tx.t$, tx.ccol)
tx.t$ = fill$
Mid$(tx.m$, 1, tx.maxchrs) = tx.t$
'-------------------------------------
'*' No need to update cursor because the entire line gets erased, including overwrite cursor height, during the reprint cycle. Without that line, gosub the update_cursor routine but first reduce tx.numchrs to tx.numchrs - 1 as the string was shortened.
tx.ccol = tx.ccol - 1
matrix_update_method% = 2 ' matrix_col% not required here.
tx.reprnt = -1
Else
b$ = "": Exit Sub
End If
Case Chr$(32) To Chr$(127) ' Restricted to keyboard nubers, letters, and displayed glyhps.
' Keys to display to the screen start here...
tx.c_wdth = _PrintWidth(b$)
Rem No need to update cursor here because the text line was blanked out in this routine.
If tx.ovr Then
' Evaluate line length.
i% = Len(Mid$(tx.t$, 1, InStr(tx.t$ + Chr$(0), Chr$(0)) - 1))
' Remember that pixcol is tx.lm + index_col(i%)
If tx.ccol > i% Then ' Cursor is past the end of the text.
If tx.pixcol + 2 * tx.c_wdth > tx.rm Then ' Character plus the cursor space.
Sound 500, 1
_KeyClear
Exit Sub
End If
Else ' Cursor is inside the text.
k% = Asc(Mid$(tx.m$, (tx.maxchrs + 1) + tx.sa + 2 + (tx.ccol - 1) * tx.noa, 1))
If tx.c_wdth > k% Then
If tx.pixcol + tx.c_wdth - k% > tx.rm Then
Sound 500, 1
_KeyClear
Exit Sub
End If
End If
End If
' If font or color was changed update it here.
If oldfsn <> ft.fsn Then oldfsn = ft.fsn: _Font fnum(ft.fsn)
If oldcolor <> mycolor Then oldcolor = mycolor: Color _RGB32(cl%(1), cl%(2), cl%(3), 255), _RGB32(bc%(1), bc%(2), bc%(3), 255)
Mid$(tx.t$, tx.ccol, 1) = b$
fill$ = String$(tx.maxchrs * tx.noa, Chr$(0))
Mid$(fill$, 1, Len(fill$)) = Mid$(tx.m$, (tx.maxchrs + 1) + tx.sa, (tx.ccol - 1) * tx.noa) + String$(tx.noa, Chr$(0)) + Mid$(tx.m$, (tx.maxchrs + 1) + tx.sa + (tx.ccol) * tx.noa)
Mid$(tx.m$, (tx.maxchrs + 1) + tx.sa) = fill$
matrix_col% = tx.ccol
matrix_update_method% = 1
tx.ccol = tx.ccol + 1 ' Advance cursor.
End If
End If
tx.reprnt = -1 ' Reprint screen next cycle.
Case Else
Beep ' Not supported
b$ = ""
End Select
Case 2
a = Asc(Right$(b$, 1))
Select Case a
Case 72, 80 ' CHR$(0) +"H" Arrow up and CHR$(0) + "P" Arrow down.
If a = 72 And tx.scr + tx.ln > 1 Or a = 80 Then
change_text_line% = tx.ln - 1 + -2 * (a = 80)
tx.oldccol = tx.ccol
debug = 670: GoSub change_text_line
If Len(Mid$(tx.t$, 1, InStr(tx.t$ + Chr$(0), Chr$(0)) - 1)) < tx.oldccol Then ' Line is shorter than cursor column.
m.mousekey$ = Chr$(0) + "O" ' Advanc to the end of the shorter text line.
Else
tx.ccol = tx.oldccol ' Stay in the same column.
End If
Exit Sub
End If
Case 115 ' Ctrl + arrow left CHR$(0) + "s"
If tx.ccol > 1 Then
bit = 0
' No need to sub update_cursor here because cursor doesn't get moved with delete.
tx.reprnt = -1 ' Now reprint the changed text.
ElseIf tx.numchrs = 0 And tx.ccol = 1 Then
If tx.scr + tx.ln < tx.nol Then
' Delete up text line below but bypass if on the last line to avoid an empty matrix error.
debug = 820: GoSub blank_text_area
While InStr(tx.map_rows$, Chr$(tx.ln + 1)) > 0
j% = InStr(tx.map_rows$, Chr$(tx.ln + 1)) ' Update row map.
Mid$(tx.map_rows$, j%, 1) = Chr$(0)
Wend
tx.nol = tx.nol - 1
g% = tx.ln
j% = tx.nol
temp% = tx.row ' Okay to use k% here but it might cause debug confusion in the upcoming gosub routine. k% is used in that sub by another calling routine.
If Len(tx.url$) Then
For i% = 1 To UBound(mylink$)
If Len(mylink$(i%)) = 0 Then i% = -i%: Exit For
Next
If i% > 0 Then
tx.link = tx.link + 1
ReDim _Preserve mylink$(tx.link)
Else
tx.link = Abs(i%)
End If
' Format hypertext.
matrix_update_method% = 4
b$ = "": _Continue
End If
If tx.button_status = 0 Then tx.button_status = -8
Else
Beep ' Nothing highlighted to link.
End If
Exit Sub
Case 134 ' F12 Follow link.
debug = 935: j% = 1: GoSub openlink
Exit Sub
End Select
Case 75, 77
cur_arrows = tx.ccol + (a = 75) - (a = 77) ' Arrow right or left.
If cur_arrows > 0 And cur_arrows <= tx.numchrs + 1 And tx.pixcol + pop.chr_wdth < tx.rm Then
If tx.shift Then
If cur_arrows > tx.ccol Then xx = 1 Else xx = 0 ' 1 cursor right, 0 cursor left.
tx.hl = -1 + xx * 2
tx.arrows = -1 + xx * 2
If Asc(Mid$(tx.m$, (tx.maxchrs + 1), 1)) Then
If cur_arrows - xx >= Asc(Mid$(tx.m$, (tx.maxchrs + 1), 1)) And cur_arrows - xx <= Asc(Mid$(tx.m$, (tx.maxchrs + 2), 1)) Then
If cur_arrows - xx = Asc(Mid$(tx.m$, (tx.maxchrs + 1 + xx), 1)) Then
tx.hl = 0 ' Fully retraced. Highlighting off.
Mid$(tx.m$, (tx.maxchrs + 1), 2) = Chr$(0) + Chr$(0)
Else
Mid$(tx.m$, tx.maxchrs + 2 - xx, 1) = Chr$(Asc(Mid$(tx.m$, tx.maxchrs + 2 - xx, 1)) - 1 + xx * 2) ' Retracing.
End If
Else
Mid$(tx.m$, tx.maxchrs + 1 + xx, 1) = Chr$(cur_arrows - xx) ' Continuing highlighting left.
End If
Else
Mid$(tx.m$, tx.maxchrs + 1, 2) = Chr$(cur_arrows - xx) + Chr$(cur_arrows - xx)
End If
End If
bit = 0
tx.ccol = cur_arrows ' Update to current cursor position.
End If
Case Else
Beep ' Not supported.
Exit Sub
End Select
End Select
End If
' Mouse events.
If m.wh Then ' Mouse wheel check.
If m.wh > 0 Then m.mousekey$ = Chr$(0) + "P" Else m.mousekey$ = Chr$(0) + "H"
Exit Sub
End If
If m.rb_status = 1 Then rbx% = m.mx: rby% = m.my
j% = Asc(Mid$(tx.map_rows$, m.my + 1)) ' Check if on a text row.
If tx.hl = 0 And j% And Mid$(tx.map_links$, (j% - 1) * _Width + m.mx, 1) <> Chr$(0) Then ' Last condition prevents activting while dragging over hyperlink.
_MouseShow "LINK": m.CursorStyle = 1
ElseIf m.CursorStyle = 1 Then ' Hyperlink mouseover event. 1 = hyperlink -1 is for buttons.
_MouseShow "DEFAULT": m.CursorStyle = 0
End If
If m.lb_status > 0 Then ' For events 1 = Click and 2 = Drag.
If m.mx >= tx.lm And m.mx <= tx.rm And m.my >= tx.row And m.my <= tx.row + tx.c_hght Or m.lb_status = 2 Then ' True when mouse cursor on text line within margins and anywhere when dragging.
' Click events on text line. See further in code for (Click occurred off the text line).
Select Case m.CursorStyle
Case 0
Select Case m.lb_status
Case 1
If tx.hl Then ' Highlighted text with a mouse click.
debug = 994: GoSub direct_reprinting ' Removes highlighting due to mouse click on text line.
_Delay .1
End If
j% = tx.lm
For i% = 1 To tx.numchrs
j% = j% + Asc(Mid$(tx.m$, tx.sa + (tx.maxchrs + 1) + 2 + tx.noa * (i% - 1), 1))
If j% >= m.mx Then Exit For ' Sets i% to determine the right or left direction for the highlighting drag.
Next
bit = 0
tx.ccol = i%
Case 2 ' Drag to highlight text.
j% = tx.lm
For i% = 1 To tx.numchrs
j% = j% + Asc(Mid$(tx.m$, tx.sa + (tx.maxchrs + 1) + 2 + tx.noa * (i% - 1), 1))
If j% >= m.mx Then Exit For ' Sets i% to determine the right or left direction for the highlighting drag.
Next
If i% > tx.ccol Then
m.mousekey$ = Chr$(0) + "M": tx.autoshift = -1
ElseIf i% < tx.ccol Then
m.mousekey$ = Chr$(0) + "K": tx.autoshift = -1
ElseIf i% = tx.ccol Then
' Do nothing.
End If
End Select
Case 1
If m.lb_status = 1 Then ' Do not allow drag events (2) to open links. This prevents opening many instances.
debug = 1025: j% = 2: GoSub openlink ' Also occurs, with drag event excluded by a prior statement, when off the text line. See further down in code.
End If
Exit Sub
End Select
ElseIf m.lb_status = 1 Then ' Click off text line. Drag event is not processed here.
' IMPORTANT: Add any other exceptions for new clickable features not in text areas like buttons.
If m.my >= tx.tm And m.my <= tx.bm And m.mx >= tx.lm And m.mx <= tx.rm Then ' Cursor is within text area and not above at buttons, top menu, etc.
Select Case m.CursorStyle
Case 0
If tx.hl Then ' Remove highlighted text.
debug = 1037: GoSub direct_reprinting
_Delay .1
End If
' Regular text or highlighting removed above. Move up or down.
j% = Asc(Mid$(tx.map_rows$, m.my + 1, 1))
If j% Then
change_text_line% = j%
debug = 1046: GoSub change_text_line
Exit Sub
Else ' Allow for a mouse click to move down if there is text in the current line.
change_text_line% = 0
For i% = 1 To m.my
k% = Asc(Mid$(tx.map_rows$, i%, 1))
If k% > change_text_line% Then change_text_line% = k%
Next
change_text_line% = change_text_line% + 1
debug = 1057: GoSub change_text_line
Exit Sub
End If
Case 1
debug = 1063: j% = 2: GoSub openlink ' Note dragging isn't processed here. See elseif statement several lines above.
Exit Sub
End Select
End If
End If
End If
' Cursor and text reprinting events.
If tx.reprnt Then
Else
_KeyClear: bit = 0: Exit Sub
End If
Else
If tx.insreg = 1 Then tx.insreg = -1 ' Cursor was changed. Now lock out any button held down ins events until a cursor cycle gets completed.
If m.lb_status <> 2 Then ' Disable cursor flashing during drag events.
If Timer > cc! Or tx.oldccol <> tx.ccol Or Len(b$) Or tx.arrows <> 0 Then
If tx.arrows Then tx.arrows = 0: bit = -1
bit = bit Xor 1
cc! = Timer + .25: If cc! > 86400 Then cc! = .25
If h% < j% And tx.row + 6 + _FontHeight < tx.bm Then
tx.ln = tx.ln + 1
tx.row = tx.row + 6 + _FontHeight ' IMPORTANT: Unfinished for max height when different size fonts are added.
Else
If tx.row + 6 + _FontHeight >= tx.bm Then tbit` = 0
End If
End If
Next
tbit` = 0
Return
set_maps:
tx.map_rows$ = String$(_Height, Chr$(0)) ' Blank map to detect text and mouse row.
tx.map_links$ = String$(_Width * _Height \ 4, Chr$(0)) ' Blank map to detect hyperlinked text and control mouseover. _height \ 4 for size 4 smallest allowed font.
Return
set_text_vars:
tx.ccol = 1: tx.oldccol = tx.ccol
tx.m$ = String$(tx.sa + tx.maxchrs * (tx.noa + 1), Chr$(0)) ' Algorithm makes a 1 string field, 10 ID fields for highlighting, paragraph, plain text line, etc., and tx.noa attributes fields.
tx.t$ = String$(tx.maxchrs, Chr$(0)) ' Our text.
ReDim index_col(tx.maxchrs)
tx.numchrs = 0
Return
evaluate_length:
' Evaluate length before displaying text.
i% = Len(Mid$(tx.t$, 1, InStr(tx.t$ + Chr$(0), Chr$(0)) - 1))
j% = Asc(Mid$(tx.m$, (tx.maxchrs + 1) + tx.sa + 2 + (i% - 1) * tx.noa, 1)) ' Width of the last character.
temp_length_check% = tx.lm ' Set to left margin.
For h% = 1 To i%
temp_length_check% = temp_length_check% + Asc(Mid$(tx.m$, (tx.maxchrs + 1) + tx.sa + 2 + (h% - 1) * tx.noa, 1))
Next
If temp_length_check% + j% > tx.rm Then
Sound 500, 1
temp_length_check% = 0 ' Too long to display. 0 = abort on return.
Else
temp_length_check% = -1 ' Okay to display.
End If
Return
change_text_line:
bit = 0: text_cursor ft, tx, fnum(), index_col(), default_cl%(), default_bc%(), cl%()
flag = 0
mtx$(tx.scr + tx.ln) = tx.m$
tx.ln = change_text_line%
Do ' Falx loop
If change_text_line% = 0 And tx.scr > 0 Then flag = 1: Exit Do
If InStr(tx.map_rows$, Chr$(tx.ln)) Then flag = 2: Exit Do
j% = InStr(tx.map_rows$, Chr$(tx.ln - 1))
If j% And j% + 6 + _FontHeight < tx.bm Then flag = 3: Exit Do
flag = 4: Exit Do
Loop
Select Case flag
Case 1
debug = 1191: GoSub blank_text_area
GoSub evaluate_length ' Returns temp_length_check% as 0 or -1.
If temp_length_check% = -1 Then
b$ = temp_b$ ' Allow. Revert to original key entry.
debug = 1286: GoSub direct_reprinting
Else ' Disallow. IMPORTANT: Note that the button used is still active.
tx.hl = 0 ' Results too long. Disallow, revert to prior, and remove highlighting
tx.m$ = temp_oldm$
matrix_col% = matrix_col% + 1
Next
Case Else ' Paste from the screen.
copied_text$ = tx.tcopy$
tx.t$ = Left$(tx.t$, tx.ccol - 1) + copied_text$ + Mid$(tx.t$, tx.ccol)
fill$ = String$(tx.maxchrs * tx.noa, Chr$(0))
Mid$(fill$, 1, Len(fill$)) = Mid$(tx.m$, (tx.maxchrs + 1) + tx.sa, (tx.ccol - 1) * tx.noa) + tx.mcopy$ + Mid$(tx.m$, (tx.maxchrs + 1) + tx.sa + (tx.ccol - 1) * tx.noa)
Mid$(tx.m$, (tx.maxchrs + 1) + tx.sa) = fill$ ' Blanks out character attributes but leave special attributes.
Mid$(tx.m$, (tx.maxchrs + 1), 2) = Chr$(0) + Chr$(0) ' Blank both highlighting special attributes.
fill$ = String$(tx.maxchrs, Chr$(0)) ' Now redo the text in the front end.
Mid$(fill$, 1, Len(fill$)) = tx.t$ ' Chopped from first line.
tx.t$ = fill$
End Select
fill$ = String$(tx.maxchrs, Chr$(0))
Mid$(fill$, 1, Len(tx.t$)) = tx.t$
Mid$(tx.m$, 1, tx.maxchrs) = fill$
Return
openlink:
Select Case j%
Case 1 ' Key press.
k% = Asc(Mid$(tx.m$, (tx.maxchrs + 1) + tx.sa + 11 + tx.noa * (tx.ccol - 1), 1))
Case 2 ' Mouse click.
k% = Asc(Mid$(tx.map_links$, (Asc(Mid$(tx.map_rows$, m.my + 1)) - 1) * _Width + m.mx + 1, 1)) ' +1 adjusts for mouse coordinates starting at zero.
End Select
If k% Then
Shell _DontWait mylink$(k%)
_Delay .2
End If
Return
End Sub
Sub text_reprint (ft As fontvar, tx As textvar, fnum() As Long, mtx$(), index_col(), default_bc%(), cl%())
' Local vars: i%, j%, k%, linkpresent` (bit)
tx.numchrs = InStr(tx.t$ + Chr$(0), Chr$(0)) - 1
ReDim index_col(tx.maxchrs)
Mid$(tx.map_links$, (tx.ln - 1) * _Width, _Width) = String$(_Width, Chr$(0))
'*' Line blanks input line, but will need to be updated when different font heights are added to the routine. Update tx.c_hght to a variable that represents the highest font character in the line.
' Note +3 adds a little extra to remove trailing overwrite right cursor edge.
Line (tx.lm, tx.row)-(tx.rm + 3, tx.row + tx.c_hght), _RGB32(255, 255, 255, 255), BF
j% = Asc(Mid$(tx.m$, tx.maxchrs + 1, 1)) ' Check for highlighted text.
k% = Asc(Mid$(tx.m$, tx.maxchrs + 2, 1))
For i% = 1 To tx.numchrs
tx.mindex = (tx.maxchrs + 1) + tx.sa + (i% - 1) * tx.noa
c$ = Mid$(tx.t$, i%, 1)
Rem font_size = Asc(Mid$(tx.m$, tx.mindex + 1, 1))
_Font fnum(Asc(Mid$(tx.m$, tx.mindex, 1)))
index_col(i%) = index_col(i% - 1) + Asc(Mid$(tx.m$, tx.mindex + 2, 1))
If Asc(Mid$(tx.m$, tx.mindex + 11, 1)) Then ' Special for links.
linkpresent` = -1
tx.xl = index_col(i% - 1): tx.cchr$ = c$
follow_link = 3 ' Show link and redo map for text changes.
Else ' non-linked text.
If i% >= j% And i% <= k% Then
Color White, Blue
Else
Color _RGB32(Asc(Mid$(tx.m$, tx.mindex + 4, 1)), Asc(Mid$(tx.m$, tx.mindex + 5, 1)), Asc(Mid$(tx.m$, tx.mindex + 6, 1)), 255), _RGB32(Asc(Mid$(tx.m$, tx.mindex + 7, 1)), Asc(Mid$(tx.m$, tx.mindex + 8, 1)), Asc(Mid$(tx.m$, tx.mindex + 9, 1)), 255)
End If
_PrintString (tx.lm + index_col(i% - 1), tx.row), c$ ' Note the first character is set at zero character width (i% - 1).
End If
If Asc(Mid$(tx.m$, tx.mindex + 10, 1)) Then Line (tx.lm + index_col(i% - 1), tx.row + tx.c_hght)-(tx.lm + index_col(i% - 1) + tx.c_wdth, tx.row + ft.max_fontheight), Black
Next
If linkpresent` = 0 Then
Mid$(tx.m$, tx.maxchrs + 3, 1) = Chr$(0) ' Remove any link reference that may have vanished due to various deletion methods, backspace, del, cut, etc.
End If
If tx.numchrs Then tx.pixcol = tx.lm + index_col(tx.numchrs) Else tx.pixcol = tx.lm ' Left margin when no characters exist in the string.
_Font fnum(ft.fsn)
If tx.scr + tx.ln > UBound(mtx$) Then ' ubound instead of tx.nol to avoid redimming when loading a file.
tx.nol = tx.scr + tx.ln
ReDim _Preserve mtx$(tx.nol) ' Array increased by 1.
End If
If tx.ln > tx.eop Then tx.eop = tx.ln
Mid$(tx.map_rows$, tx.row, ft.max_fontheight) = String$(ft.max_fontheight, Chr$(tx.ln))
mtx$(tx.scr + tx.ln) = tx.m$
tx.reprnt = 0
End Sub
Sub text_matrix (ft As fontvar, tx As textvar, matrix_update_method%, matrix_col%, b$, cl%(), bc%())
' Local vars: fill$
' Matrix Explained: 1 to tx.maxchrs is text, tx.maxchrs + 1 to tx.maxchrs + 10 Special attributes, maxchrs + 11 to 11 + tx.noa are character attributes.
' Special Attributes: 1 = begin highlight col. 2 = End highlight column. 3 = Link number.
' Example: tx.maxchrs = 255. tx.noa = 12. 1-255 text, 256-265 special attributes, 266-277 attributes for 1st character in text string, 278-289 2nd, etc.
Select Case matrix_update_method%
Case 1
GoSub backend
GoSub frontend ' The text portion index 1-255 of the matrix.
Case 2 ' Highlighted text changes from button press/click does not require updating the text characters, only the attributes.
GoSub frontend
Case 3
GoSub backend
Case 4
i% = Asc(Mid$(tx.m$, tx.maxchrs + 1, 1))
j% = Asc(Mid$(tx.m$, tx.maxchrs + 2, 1))
Rem Not used temp$ = Mid$(tx.t$, i%, j% - i% + 1) ' Highlighted text.
For k% = 0 To j% - i% ' Update matrix for hyperlinks.
Mid$(tx.m$, (tx.maxchrs + 1) + tx.sa + (i% - 1 + k%) * tx.noa + 11, 1) = Chr$(tx.link)
Next
Case 5
i% = 0
Do
If Mid$(tx.m$, (tx.maxchrs + 1) + tx.sa + i% * tx.noa + 11, 1) = Chr$(tx.link) Then
Mid$(tx.m$, (tx.maxchrs + 1) + tx.sa + i% * tx.noa + 11, 1) = Chr$(0)
End If
i% = i% + 1
Loop Until (tx.maxchrs + 1) + tx.sa + i% * tx.noa + 11 > Len(tx.m$)
End Select
Exit Sub ' ----------------------------------->
Else
If tx.ccol >= Asc(Mid$(tx.m$, (tx.maxchrs + 1), 1)) And tx.ccol <= Asc(Mid$(tx.m$, (tx.maxchrs + 2), 1)) Then
Color White, Blue
End If
_PrintString (tx.lm + index_col(tx.ccol - 1), tx.row), Mid$(tx.t$, tx.ccol, 1)
If Asc(Mid$(tx.m$, tx.mindex + 10, 1)) Then Line (tx.lm + index_col(tx.ccol - 1), tx.row + tx.c_hght)-(tx.lm + index_col(tx.ccol - 1) + tx.c_wdth, tx.row + ft.max_fontheight), Black
End If
If tx.ccol < tx.numchrs And tx.hl = 0 Then ' Print over second character to eliminate possibility of pixel overwritting, but pass when highlighting.
k% = (tx.maxchrs + 1) + tx.sa + (tx.ccol - 1) * tx.noa
If Asc(Mid$(tx.m$, k% + 11, 1)) Then
tx.xl = index_col(tx.ccol): tx.cchr$ = Mid$(tx.t$, tx.ccol + 1, 1)
follow_link = 2 ' Show any link at cursor.
Else
temp2% = Asc(Mid$(tx.m$, k%, 1))
_Font fnum(temp2%)
Color _RGB32(Asc(Mid$(tx.m$, k% + 4, 1)), Asc(Mid$(tx.m$, k% + 5, 1)), Asc(Mid$(tx.m$, k% + 6, 1)), 255), _RGB32(Asc(Mid$(tx.m$, k% + 7, 1)), Asc(Mid$(tx.m$, k% + 8, 1)), Asc(Mid$(tx.m$, k% + 9, 1)), 255)
_PrintString (tx.lm + index_col(tx.ccol), tx.row), Mid$(tx.t$, tx.ccol + 1, 1)
If Asc(Mid$(tx.m$, k% + 10, 1)) Then Line (tx.lm + index_col(tx.ccol), tx.row + tx.c_hght)-(tx.lm + index_col(tx.ccol) + tx.c_wdth, tx.row + ft.max_fontheight), Black
End If
End If
End If
_Font fnum(ft.fsn) ' Reestablish current font.
End If
_Display
End Sub
Sub text_links (ft As fontvar, tx As textvar, follow_link, fnum() As Long, default_bc%(), cl%())
' follow_link non-zero follows the link, otherwise the link is displayed as hypertext.
' Local vars: i%, j%
Select Case follow_link
Case 1
tx.url$ = _InputBox$("Link Manager", "Link URL:")
follow_link = 0
Case 2 ' Link reprinting.
GoSub showlink
Case 3 ' Link creation.
GoSub showlink
Mid$(tx.m$, tx.maxchrs + 3, 1) = "*" ' Assign link present symbol to (3) of matric special attributes.
j% = _PrintWidth(tx.cchr$) ' Make/update a link mouse map.
Mid$(tx.map_links$, (tx.ln - 1) * _Width + tx.lm + tx.xl, j%) = String$(j%, Mid$(tx.m$, tx.mindex + 11, 1))
Case 4 ' Link Editing.
tx.url$ = _InputBox$("Link Manager", "Link URL:", tx.url$)
follow_link = 0
End Select
Exit Sub ' ---------------------------->
showlink:
_Font fnum(3) ' Use italicized font for links.
If tx.ccol >= Asc(Mid$(tx.m$, (tx.maxchrs + 1), 1)) And tx.ccol <= Asc(Mid$(tx.m$, (tx.maxchrs + 2), 1)) Then
Color White, Red ' Special highlighting over hypertext.
Else
If tx.ovr = 1 And bit = -1 And follow_link = 2 Then ' Invert colors for block cursor appearance but not when reprinting text (follow_link = 3).
Color _RGB32(Asc(Mid$(tx.m$, tx.mindex + 7, 1)), Asc(Mid$(tx.m$, tx.mindex + 8, 1)), Asc(Mid$(tx.m$, tx.mindex + 9, 1)), 255), _RGB32(Asc(Mid$(tx.m$, tx.mindex + 4, 1)), Asc(Mid$(tx.m$, tx.mindex + 5, 1)), Asc(Mid$(tx.m$, tx.mindex + 6, 1)), 255)
Else
Color _RGB32(0, 0, 200, 255), _RGB32(default_bc%(1), default_bc%(2), default_bc%(3))
End If
End If
_PrintString (tx.lm + tx.xl, tx.row), tx.cchr$
Line (tx.lm + tx.xl, tx.row + tx.c_hght)-(tx.lm + tx.xl + tx.c_wdth, tx.row + ft.max_fontheight), _RGB32(0, 0, 200, 255)
_Font fnum(ft.fsn)
Color _RGB32(cl%(1), cl%(2), cl%(3), 255), _RGB32(default_bc%(1), default_bc%(2), default_bc%(3), 255)
Return
End Sub
Sub text_buttons (tx As textvar, m As mousevar, b$)
Static initialize
' IMPORTANT: m.CursorStyle is -1 for buttons and 1 for text field.
If initialize = 0 Or tx.button_status Or Len(tx.openfile) Or tx.newproject = -1 Then
oldfont = _Font ' Do not add any EXIT SUB statements between here and where font is restored.
j% = _LoadFont("RobotoMono-regular.ttf", 14) ' Font size 14 required for proper button appearance.
k% = _LoadFont("RobotoMono-italic.ttf", 14)
a = 100: b = 30: c = 26 ' a = left margin, b = row, c = spacing between buttons.
tx.button_row = b
If tx.button_status <= 0 Then tx.map_buttons$ = String$(_Width, Chr$(0))
For i% = 1 To 8
If Asc(Mid$(tx.map_buttons$, a, 1)) > 126 Then
Line (a, b)-(a + 17, b + 17), Black, B
Line (a + 2, b + 2)-(a - 2 + 17, b - 2 + 17), _RGB32(255, 255, 255, 255), BF
Else
Line (a, b)-(a + 17, b + 17), DarkGray, B
Line (a + 2, b + 2)-(a - 2 + 17, b - 2 + 17), _RGB32(230, 230, 230, 255), BF
End If
Line (a + 17 + 1, b + 3)-(a + 17 + 2, b + 17), _RGB32(210, 210, 210, 255), BF
Line (a + 3, b + 17 + 1)-(a + 17 + 1, b + 17 + 2), _RGB32(210, 210, 210, 255), BF
a = a + c
Next
a = 100: b = 30: c = 26
_Font j%
If Asc(Mid$(tx.map_buttons$, a, 1)) > 126 Then
Color _RGB32(0, 0, 0, 255), _RGB32(255, 255, 255, 0)
Else
Color _RGB32(0, 0, 0, 255), _RGB32(230, 230, 230, 0)
End If
For i% = 1 To 8
Select Case i%
Case 1
_PrintString (a + (i% - 1) * c + 5, b + 2), "B"
Case 2
_Font k%
_PrintString (a + (i% - 1) * c + 5, b + 2), "I"
Case 3
_Font j%
_PrintString (a + (i% - 1) * c + 5, b + 1), "u"
Line (a + (i% - 1) * c + 5, b + 17 - 2)-(a + (i% - 1) * c + 13, b + 17 - 2), Black, B
Case 4
Line (a + (i% - 1) * c + 5, b + 5)-(a + (i% - 1) * c + 12, b + 17 - 5), Black, BF
Case 5
Line (a + (i% - 1) * c + 5, b + 5)-(a + (i% - 1) * c + 12, b + 17 - 5), Blue, BF
Case 6
Line (a + (i% - 1) * c + 5, b + 5)-(a + (i% - 1) * c + 12, b + 17 - 5), Red, BF
Case 7
Line (a + (i% - 1) * c + 4, b + 4)-(a + (i% - 1) * c + 14, b + 17 - 4), Yellow, BF
_PrintString (a + (i% - 1) * c + 5, b + 2), "h"
Case 8
Color Blue, _RGB32(210, 210, 210, 0)
_PrintString (a + (i% - 1) * c + 5, b + 2), "ì"
End Select
' Make mouse map.
If tx.button_status <= 0 Then
Mid$(tx.map_buttons$, a + (i% - 1) * c, c) = String$(17, Chr$(i%)) + String$(c - 17, Chr$(0))
End If
Next
If initialize = 0 Or Len(tx.openfile) Or tx.newproject = -1 Then
' Set default button.
a = tx.lm + (4 - 1) * c
Line (a, b)-(a + 17, b + 17), Black, B ' Default black text button.
Line (a + 2, b + 2)-(a - 2 + 17, b - 2 + 17), _RGB32(255, 255, 255, 0), BF
Mid$(tx.map_buttons$, tx.lm + (4 - 1) * c, c) = String$(17, Chr$(4 + 216))
initialize = -1
End If
If tx.button_status = 999 Then tx.button_status = 0 ' Hotkey action was completed. Note: Mouse completion cycle is in the text_buttons sub.
_Font oldfont
If tx.button_status > 0 Then tx.button_status = 0: Exit Sub ' Mouse button click cycle completed. Without this statement it would be an endless toggle on-off loop.
End If
If m.my >= tx.button_row And m.my <= tx.button_row + 17 Then
If Mid$(tx.map_buttons$, m.mx, 1) <> Chr$(0) Then
_MouseShow "LINK"
m.CursorStyle = -1 ' Button cursor.
Else
_MouseShow "DEFAULT": m.CursorStyle = 0
End If
ElseIf m.CursorStyle = -1 Then ' Button cursor.
_MouseShow "DEFAULT"
m.CursorStyle = 0
End If
_Display
' Button clicks and hotkey buttons...
If m.lb_status = 1 And m.CursorStyle = -1 Or tx.button_status < 0 Then ' Mouse click on button or a button hotkey.
If tx.button_status < 0 Then ' Hotkeys.
i% = Abs(tx.button_status)
tx.button_status = 999 ' Mouse or hotkey status is now ready for termination after cycle is completed.
Select Case i%
Case 999 ' Default.
For k% = 1 To 4 ' Turns off bold, italic, and underline fonts.
Mid$(tx.map_buttons$, tx.lm + (k% - 1) * 26, 17) = String$(17, Chr$(k%))
Next
tx.underline = 0
Exit Sub
Case 11
For k% = 1 To 3 ' Turns off bold and italic fonts.
Mid$(tx.map_buttons$, tx.lm + (k% - 1) * 26, 17) = String$(17, Chr$(k%))
Next
' Turns on bold font.
Mid$(tx.map_buttons$, tx.lm + (1 - 1) * 26, 17) = String$(17, Chr$(1 + 126))
Exit Sub
Case 12
For k% = 1 To 3 ' Turns off bold and italic fonts.
Mid$(tx.map_buttons$, tx.lm + (k% - 1) * 26, 17) = String$(17, Chr$(k%))
Next
' Turns on italic font.
Mid$(tx.map_buttons$, tx.lm + (2 - 1) * 26, 17) = String$(17, Chr$(2 + 126))
Exit Sub
Case 22 ' Bold and Italic.
For k% = 1 To 2 ' Turns on bold and italic. Turns off underline.
Mid$(tx.map_buttons$, tx.lm + (k% - 1) * 26, 17) = String$(17, Chr$(k% + 126))
Next
Mid$(tx.map_buttons$, tx.lm + (3 - 1) * 26, 17) = String$(17, Chr$(3))
tx.underline = 0
Exit Sub
Case Else ' F5 - F9
If Asc(Mid$(tx.map_buttons$, tx.lm + (i% - 1) * 26, 1)) > 126 Then
tx.button_status = 0 ' The same key was pressed again or is being held down so it gets ignored here.
Exit Sub
End If
j% = i% + 126 ' Turn button on.
End Select
Else ' Mouse click on a button.
' Button toggle routine.
i% = Asc(Mid$(tx.map_buttons$, m.mx, 1))
If i% > 126 Then ' Button turned off.
i% = i% - 126 ' Locates 1-8 position on map.
j% = i% ' Assigns ascii character to map.
Else ' Button turned on.
j% = i% + 126
End If
tx.button_status = j% ' Controls program flow through the button routine.
End If
Select Case i%
Case 1 ' Bold font on.
Mid$(tx.map_buttons$, tx.lm + (i% - 1) * 26, 17) = String$(17, Chr$(j%))
If j% > 126 Then
If Asc(Mid$(tx.map_buttons$, tx.lm + (2 - 1) * 26, 1)) < 127 Then
m.mousekey$ = Chr$(0) + Chr$(60) ' Bold.
Else
m.mousekey$ = Chr$(0) + Chr$(62) ' Bold + Italic
End If
Else ' Bold font off.
If Asc(Mid$(tx.map_buttons$, tx.lm + (2 - 1) * 26, 1)) > 126 Then
m.mousekey$ = Chr$(0) + Chr$(61) ' Italic.
Else
m.mousekey$ = Chr$(0) + Chr$(59) ' Regular.
End If
End If
Case 2 ' Italic font on.
Mid$(tx.map_buttons$, tx.lm + (i% - 1) * 26, 17) = String$(17, Chr$(j%))
If j% > 126 Then
If Asc(Mid$(tx.map_buttons$, tx.lm + (1 - 1) * 26, 1)) < 127 Then
m.mousekey$ = Chr$(0) + Chr$(61) ' Italic.
Else
m.mousekey$ = Chr$(0) + Chr$(62) ' Bold + Italic.
End If
Else ' Italic font off.
If Asc(Mid$(tx.map_buttons$, tx.lm + (1 - 1) * 26, 1)) > 126 Then
m.mousekey$ = Chr$(0) + Chr$(60) ' Bold.
Else
m.mousekey$ = Chr$(0) + Chr$(59) ' Regular.
End If
End If
Case 3 ' Underline on.
Mid$(tx.map_buttons$, tx.lm + (i% - 1) * 26, 17) = String$(17, Chr$(j%))
m.mousekey$ = Chr$(0) + Chr$(63) ' Underline on/off. It's a togggle.
Case 4, 5, 6 ' Color font.
If Asc(Mid$(tx.map_buttons$, tx.lm + (i% - 1) * 26, 1)) < 127 Then ' Radio style buttons.
For k% = 4 To 7 ' Turns highlighting off, too.
Mid$(tx.map_buttons$, tx.lm + (k% - 1) * 26, 17) = String$(17, Chr$(k%))
Next
m.mousekey$ = Chr$(0) + Chr$(60 + i%) ' Colors F6-F8
Else
m.mousekey$ = Chr$(0) + Chr$(64) ' F6 Default black.
Mid$(tx.map_buttons$, tx.lm + (4 - 1) * 26, 17) = String$(17, Chr$(4 + 126))
End If
Mid$(tx.map_buttons$, tx.lm + (i% - 1) * 26, 17) = String$(17, Chr$(j%))
Case 7 ' Highlighting on.
If Asc(Mid$(tx.map_buttons$, tx.lm + (i% - 1) * 26, 1)) < 127 Then
If Asc(Mid$(tx.map_buttons$, tx.lm + (4 - 1) * 26, 1)) > 126 Then
tx.prior_colorHL = 4
ElseIf Asc(Mid$(tx.map_buttons$, tx.lm + (5 - 1) * 26, 1)) > 126 Then
tx.prior_colorHL = 5
Else
tx.prior_colorHL = 6
End If
For k% = 4 To 6
Mid$(tx.map_buttons$, tx.lm + (k% - 1) * 26, 17) = String$(17, Chr$(k%))
Next
m.mousekey$ = Chr$(0) + Chr$(67) ' F9 highlighting.
Else ' Highlighting off.
m.mousekey$ = Chr$(0) + Chr$(60 + tx.prior_colorHL) ' Restore prior color.
Mid$(tx.map_buttons$, tx.lm + (tx.prior_colorHL - 1) * 26, 17) = String$(17, Chr$(tx.prior_colorHL + 126))
End If
Mid$(tx.map_buttons$, tx.lm + (i% - 1) * 26, 17) = String$(17, Chr$(j%))
Case 8 ' Link. (Make when non-linked and follow when linked).
a = tx.lm + (i% - 1) * 26: b = 30
Line (a, b)-(a + 17, b + 17), Black, B: _Display
_Delay .15
Line (a, b)-(a + 17, b + 17), DarkGray, B: _Display
_Delay .15
m.mousekey$ = Chr$(0) + Chr$(133)
End Select
If tx.button_status < 0 Then m.mousekey$ = "": b$ = "" ' Button press was already completed by keyboard entry.
End If
End Sub
Sub popup_main (ft As fontvar, tx As textvar, m As mousevar, pop As popup)
Static menu_item$(), popfont, oldfont
If tx.button_status Then Exit Sub ' Button routines do not require popups.
Do ' Falx loop.
Select Case pop.status
Case 0
If m.rb_status = 1 Then pop.status = 1 ' Initiate popup from right mouse click.
Exit Sub
Case 1
pop.status = -1 ' Popup event started
PCopy _Display, 1 ' Change display to popup.
If pop.setup = 0 Then
pop.setup = -1
oldfont = _Font
$Color:32
ft.size = 16
popfont = _LoadFont("RobotoMono-regular.ttf", ft.size)
If popfont <= 0 Then ' Try to load the Windows Lucida Console font.
popfont = _LoadFont(Environ$("SYSTEMROOT") + "\Fonts\lucon.ttf", ft.size)
End If
If popfont <= 0 Then
popfont = 16
End If
End If
_Font popfont
pop.chr_wdth = _PrintWidth("A")
pop.chr_hght = _FontHeight
Select Case m.CursorStyle
Case 0
Restore popdata
Case 1
Restore popdata2
End Select
ReDim menu_item$(0): pop.nmi = 0
Do
Read temp$
If LCase$(temp$) = "eof" Then Exit Do
pop.nmi = pop.nmi + 1
ReDim _Preserve menu_item$(pop.nmi)
menu_item$(pop.nmi) = temp$
Loop
temp$ = ""
' Draw popup window.
pop.pbgcolor = 240
pop.pbbxcolor = 190
pop.pbshdcolor = 86
pop.phght = 2 * pop.nmi * pop.chr_hght
pop.pwdth = pop.chr_wdth * 16
pop.pc1 = m.mx + 1: If pop.pc1 + pop.pwdth > _Width - 5 Then pop.pc1 = _Width - 5 - pop.pwdth
pop.pr1 = m.my + 1: If pop.pr1 + pop.phght > _Height - 5 Then pop.pr1 = _Height - 5 - pop.phght
pop.pc2 = pop.pc1 + pop.pwdth
pop.pr2 = pop.pr1 + pop.phght
Line (pop.pc1, pop.pr1)-(pop.pc2, pop.pr2), _RGB32(pop.pbbxcolor, pop.pbbxcolor, pop.pbbxcolor, 255), B
Line (pop.pc1 + 1, pop.pr1 + 1)-(pop.pc2 - 1, pop.pr2 - 1), _RGB32(255, 255, 255, 255), B
Line (pop.pc1 + 2, pop.pr1 + 2)-(pop.pc2 - 2, pop.pr2 - 2), _RGB32(pop.pbgcolor, pop.pbgcolor, pop.pbgcolor, 255), BF
Line (pop.pc2 + 1, pop.pr1 + 7)-(pop.pc2 + 1, pop.pr2 + 0), _RGB32(pop.pbshdcolor, pop.pbshdcolor, pop.pbshdcolor, 180)
Line (pop.pc2 + 2, pop.pr1 + 7)-(pop.pc2 + 2, pop.pr2 + 0), _RGB32(pop.pbshdcolor, pop.pbshdcolor, pop.pbshdcolor, 180)
Line (pop.pc1 + 5, pop.pr2 + 1)-(pop.pc2 + 2, pop.pr2 + 1), _RGB32(pop.pbshdcolor, pop.pbshdcolor, pop.pbshdcolor, 180)
Line (pop.pc1 + 5, pop.pr2 + 2)-(pop.pc2 + 2, pop.pr2 + 2), _RGB32(pop.pbshdcolor, pop.pbshdcolor, pop.pbshdcolor, 180)
pop.col_matrix = String$(_Width, Chr$(0)): pop.row_matrix = pop.col_matrix
popup_restrict tx, m, pop
j% = 2
For i% = 1 To pop.nmi
Mid$(pop.col_matrix, pop.pc1, pop.pwdth) = String$(pop.pwdth, "*")
Mid$(pop.row_matrix, pop.pr1 + pop.chr_hght \ 2 + ((i% - 1) * pop.chr_hght * 2)) = String$(pop.chr_hght, Chr$(i%))
If Mid$(pop.restrict, i%, 1) = "*" Then
Color _RGB32(150, 150, 150, 190), _RGB32(pop.pbgcolor, pop.pbgcolor, pop.pbgcolor, 255)
Else
Color _RGB32(0, 0, 0, 190), _RGB32(pop.pbgcolor, pop.pbgcolor, pop.pbgcolor, 255)
End If
_PrintString (pop.pc1 + pop.chr_wdth * 2, pop.pr1 + pop.chr_hght \ 2 + ((i% - 1) * pop.chr_hght * 2)), menu_item$(i%)
Next
Color _RGB32(230, 190), _RGB32(230, 190)
For i% = 1 To pop.nmi - 1
Line (pop.pc1 + pop.chr_wdth * 2, pop.pr1 + i% * pop.chr_hght * 2)-(pop.pc2 - pop.chr_wdth * 2, pop.pr1 + i% * pop.chr_hght * 2), _RGB32(200, 255)
Next
Exit Do
Case -1
popup_engine m, pop, menu_item$()
_Display
If pop.status = -1 Then Exit Do ' If status changed, go around loop again.
Case 2 ' Close popup occurs here.
popup_engine m, pop, menu_item$() ' Only to clear variables.
pop.status = 0
_Font oldfont
PCopy 1, _Display ' Popup is now closed. Restores underlying screen.
_Display
Exit Do
End Select
Loop
popdata:
Data Cut
Data Copy
Data Paste
Data Delete
Data Select All
Data Hyperlink
Data eof
popdata2:
Data Edit Link
Data eof
End Sub
Sub popup_engine (m As mousevar, pop As popup, menu_item$())
Static c1, r1, c2, r2, oldmenu_item%
If pop.status = 2 Then ' Clear static and matrix variables then exit to close popup.
c1 = 0: c2 = 0: r1 = 0: r2 = 0: oldmenu_item% = 0: pop.col_matrix$ = "": pop.row_matrix$ = ""
Exit Sub
End If
If pop.status = 0 Then Exit Sub
If m.mx < pop.pc1 Or m.mx > pop.pc2 Or m.my < pop.pr1 Or m.my > pop.pr2 Then ' Mouse is outside of popup window.
If m.lb_status = 1 Then pop.status = 2: Exit Sub ' Left click outside of popup will close window.
If m.rb_status = 1 Then m.rb_status = -1: pop.status = 2: Exit Sub ' Right click outside of popup will close wndow.
If oldmenu_item% Then
If m.mx < pop.pc1 Or m.mx > pop.pc2 Or m.my < pop.pr1 Or m.my > pop.pr2 Then
GoSub remove_prior_menu_item_highlighting
End If
End If
Else ' Mouse is inside popup window.
If m.rb_status Then m.rb_status = 0: Exit Sub ' Disables right mouse click insdie menu.
If Mid$(pop.col_matrix, m.mx + 1, 1) = "*" And Mid$(pop.row_matrix, m.my + 1, 1) <> Chr$(0) Then
menu_item% = Asc(Mid$(pop.row_matrix, m.my + 1, 1))
If menu_item% <> oldmenu_item% Or m.lb_status = 1 Then
Select Case m.lb_status
Case -1: Exit Sub ' Do not repeat until mouse button is released.
Case 1: If m.lb_status = 1 Then m.lb_status = -1
End Select
h% = _InStrRev(m.mx, pop.col_matrix, Chr$(0)) + 1
temp$ = Mid$(pop.col_matrix, h%)
temp$ = Mid$(temp$, 1, InStr(temp$, Chr$(0)) - 1)
i% = Len(temp$)
j% = _InStrRev(m.my, pop.row_matrix, Chr$(0)) + 1
temp$ = Mid$(pop.row_matrix, j%)
temp$ = Mid$(temp$, 1, InStr(temp$, Chr$(0)) - 1)
k% = Len(temp$)
GoSub remove_prior_menu_item_highlighting
c1 = h% + pop.chr_wdth \ 2
r1 = j% - pop.chr_hght \ 4
c2 = h% + i% - pop.chr_wdth \ 2
r2 = j% + k% + pop.chr_hght \ 4
If m.lb_status = -1 Then _Display: _Delay .1
If Mid$(pop.restrict, menu_item%, 1) = "*" Then
Line (c1, r1)-(c2, r2), _RGB32(190, 190, 190, 255), BF
Color _RGB32(150, 150, 150, 190), _RGB32(190, 190, 190, 255)
Else
Line (c1, r1)-(c2, r2), _RGB32(0, 170, 250, 255), BF
Color _RGB32(0, 0, 0, 190), _RGB32(0, 170, 250, 255)
End If
_PrintString (pop.pc1 + pop.chr_wdth * 2, pop.pr1 + pop.chr_hght \ 2 + ((menu_item% - 1) * pop.chr_hght * 2)), menu_item$(menu_item%)
If m.lb_status = -1 Then
popup_select m, menu_item%
pop.status = 2 ' Close popup.
oldmenu_item% = 0
Exit Sub
End If
oldmenu_item% = menu_item%
End If
End If
End If
Exit Sub '-------------------------------->
remove_prior_menu_item_highlighting:
If c1 Then Line (c1, r1)-(c2, r2), _RGB32(pop.pbgcolor, 255), BF
If Mid$(pop.restrict, oldmenu_item%, 1) = "*" Then
Color _RGB32(150, 150, 150, 190), _RGB32(pop.pbgcolor, pop.pbgcolor, pop.pbgcolor, 255)
Else
Color _RGB32(0, 0, 0, 190), _RGB32(pop.pbgcolor, pop.pbgcolor, pop.pbgcolor, 255)
End If
_PrintString (pop.pc1 + pop.chr_wdth * 2, pop.pr1 + pop.chr_hght \ 2 + ((oldmenu_item% - 1) * pop.chr_hght * 2)), menu_item$(oldmenu_item%)
Return
End Sub
Sub popup_restrict (tx As textvar, m As mousevar, pop As popup)
pop.restrict = Space$(pop.nmi) ' Matrix for cut/copy/paste/delete/select all/hyperlink. Places an * in the string at the position of the menu item.
If m.CursorStyle = 1 Then ' +1 Hand cursor for links. Note: -1 is for buttons.
pop.restrict = ""
Else
If tx.hl = 0 Then pop.restrict = "** * *"
If _Clipboard$ = "" Then Mid$(pop.restrict, 3, 1) = "*"
If Mid$(tx.t$, 1, 1) = Chr$(0) Then Mid$(pop.restrict, 5, 1) = "*" ' No text so no select all.
End If
End Sub
Sub popup_select (m As mousevar, menu_item%)
Select Case m.CursorStyle
Case 0
Select Case menu_item%
Case 1
m.mousekey$ = Chr$(24) ' Cut.
Case 2
m.mousekey$ = Chr$(3) ' Copy.
Case 3
m.mousekey$ = Chr$(22) ' Paste.
Case 4
m.mousekey$ = Chr$(0) + "S" ' Delete.
Case 5
m.mousekey$ = Chr$(1) ' Select All.
Case 6
m.mousekey$ = Chr$(0) + Chr$(133) ' Link.
End Select
Case 1
m.mousekey$ = "Edit Link"
End Select
End Sub
Pete
- 5 out of 6 Russians recommend Russian Roulette to their gamblers who play Russian Roulette.
This is basically a continuation of some code I posted here.
I originally planned this for an upcoming update to InForm-PE's UiEditor. However, while experimenting with this, it turned out to be nice little 4-function cross-platform library. I am sharing it here hoping it might be useful.
The library has 4 functions:
Code: (Select All)
''' @brief Builds an array of fonts from that are available in the host OS (user installed + system installed).
''' @param fontList This a dynamic string array. The function will redimension fontList starting from 1.
''' @return The count of fonts found.
FUNCTION FontMgr_BuildList~& (fontList() AS STRING)
''' @brief Returns the font name by directly probing a font file.
''' @param filePath This the font file path name.
''' @param fontIndex This is the font index inside a TTC and it is always zero based. Must be 0 for TTF & OTF.
''' @param nameId The component needed from the font's name table
''' @return The name of the font. Invalid filePath or fontIndex will return an empty string.
FUNCTION FontMgr_GetName$ (filePath AS STRING, fontIndex AS _UNSIGNED LONG, nameId AS _UNSIGNED _BYTE)
''' @brief Returns the number of fonts in a collection (TTC).
''' @param filePath This the font file path name.
''' @return 1 or more for valid font files. 0 for invalid font files.
FUNCTION FontMgr_GetCount~& (filePath AS STRING)
''' @brief Probes and returns the supported font size range (useful for bitmap fonts).
''' @param filePath This the font file path name.
''' @param fontIndex This is the font index inside a TTC and it is always zero based. Must be 0 for TTF & OTF.
''' @param outMinSize [OUT] The minimum size supported by the font
''' @param outMaxSize [OUT] The maximum size supported by the font
''' @return True if a valid size range was probed
FUNCTION FontMgr_GetSizeRange%% (filePath AS STRING, fontIndex AS _UNSIGNED LONG, outMinSize AS _UNSIGNED _BYTE, outMaxSize AS _UNSIGNED _BYTE)
Demo output:
Update: Added functionality to read any string from the font name table like family name, style, full name, vendor, designer, copyright etc.
![[Image: Screenshot-2024-03-21-024631.png]](https://i.ibb.co/QN3z2Rb/Screenshot-2024-03-21-024631.png)
