07-28-2024, 11:00 PM (This post was last modified: 07-28-2024, 11:02 PM by bplus.)
Here is my Editor project kind of stalled out for awhile. It is 820 LOC and has allot of standard features QB64 has including Cut, Copy and Paste. This is working condition before I attempted to add horizontal scrolling so that part is not working like QB64 yet. You have 100 chars wide plus?... screening.
You should have entire menu with one right click but F2 button not added yet. It pastes the entire file you are working on into the Clipboard to paste where-ever you want. So this thing should not need instructions to use, if it does I'd like to know. The menu lists the shortcut buttons with it's function.
' Screen, colors, font
Dim Shared As Long XMax: XMax = 1200 '109 chars wide minus 6 space for line numbers 100 chars
Dim Shared As Long YMax: YMax = 700 ' 30 chars high (600) + 100 pixels = 5 rows for Editor stuff
Screen _NewImage(XMax, YMax, 32): _ScreenMove 40, 35
Dim Shared As _Unsigned Long FG, BG, EFG, EBG: ColorTheme 1 ' Forest color theme
Dim Shared As Long Fnt, FW, FH: Fnt = _LoadFont("lucon.ttf", 18, "MONOSPACE") ' add font to folder
If Fnt <= 0 Then Print "Font failed to load, goodbye!": _Delay 5: System
_Font Fnt: FH = _FontHeight: FW = _FontWidth 'FW=11, FH=18 use 20 for row height, cursor fits below
' cursor on screen area
Dim Shared As Long MinCol: MinCol = 7 ' on left is 5 digits and space for line numbers
Dim Shared As Long MaxCol: MaxCol = 109 ' 109 no minus 6 for line numbers but text starts on col 7
Dim Shared As Long MaxRow: MaxRow = 30 ' 30 rows * 20
' for display, track the array index for top row of screen
Dim Shared As Long VsScreenTop: VsScreenTop = 1
Dim Shared As Long VsUB, VsIndex, VsCol ' <<< only set or updated in CheckShared
Dim Shared VsTail$, VsHead$ ' CheckShared but Backspace sets VsHead$ too
ReDim Shared VS$(1 To 1) ' VS$ Variable String main work array
' cursor
Dim Shared As Long CCol, CRow ' the cursor position on screen and actual text is 7 char position
'track selected text and highlighting it
Dim Shared As Long Shift ' Shared?? used in CheckShift sub, one line could be added back in main
Dim Shared As Long SelRow, SelCol ' these anchor the one point in text for cursor in any direction
' work file
Dim Shared Filename$ ' the working filename "untitled" no extension until SaveIt called
Dim Shared As Long NeedsSaving: NeedsSaving = 0 ' track whether the work needs to be saved
' search and change
Dim Shared Find$, CaseSense As Long, Change$, findR As Long, findC As Long
' locals
Dim As Long kh, ctrl, alt, b1, b2 ' key variables and booleans
Dim As Long scroll, mdx, mdy, mx, my, mb, mdFlag, saveTOP ' mouse and flags for mouse functions
Dim As Long saveMdx, saveMdy, saveMx, saveMy ' detecting pixel moves of mouse to select single char
Dim s$ ' to shorten super long code lines because of text ie messagebox text
FLoad
Do 'main interface loop
CheckShared ' the one and only place where all the Vs... Variables are set Except VsTopScreen!
Show ' replace CLS now draws cursor and _displays from sub
_Limit 60 'easy on the cpu?
kh = _KeyHit
Shift = _KeyDown(100304) Or _KeyDown(100303)
ctrl = _KeyDown(100306) Or _KeyDown(100305)
alt = _KeyDown(100308) Or _KeyDown(100307)
Do While _MouseInput ' scrolling just like an up or down arrow
scroll = _MouseWheel
If scroll = -1 Then 'up
CRow = 1 ' faster scrolling
kh = 18432
ElseIf scroll = 1 Then 'down
If VsScreenTop + 30 - 1 > VsUB Then CRow = VsUB - VsScreenTop + 1 Else CRow = 30
kh = 20480
End If
Loop
' MouseButton down and drag set MouseDown x, y for select anchor
'
' Yea! Finally this will highlite up and down screen by dragging mouse!
' Saved EDIT VSLA 2023-11-24 ***
'
mdFlag = 0: saveMdx = _MouseX: saveMdy = _MouseY ' get precise pixels for later
mdx = saveMdx \ FW + 1: mdy = saveMdy \ 20 + 1: mb = _MouseButton(1)
If mb And ((mdx >= MinCol) And ((mdx <= MaxCol) And (mdy <= MaxCol))) Then
SelRow = VsScreenTop + mdy - 1: SelCol = mdx - 6
mdFlag = 1: saveTOP = VsScreenTop ' this is for just a click? code
'Beep ' should only be once at mouse down OK
Do
While _MouseInput: Wend
saveMx = _MouseX: saveMy = _MouseY
mx = saveMx \ FW + 1: my = saveMy \ 20 + 1: mb = _MouseButton(1)
If ((mx >= MinCol) And (mx <= MaxCol)) And (mb And (my <= MaxRow)) Then
If (saveMy < 4) And ((mx >= MinCol) And (mx <= MaxCol)) Then 'scroll up
If VsScreenTop > 1 Then VsScreenTop = VsScreenTop - 1: _Delay .1
ElseIf (saveMy > 596) And ((mx >= MinCol) And (mx <= MaxCol)) Then 'scroll down?
If VsScreenTop < VsUB Then VsScreenTop = VsScreenTop + 1: _Delay .1
End If
CRow = my: CCol = mx
If CRow + VsScreenTop - 1 > VsUB Then CRow = VsUB - VsScreenTop + 1
Show
End If
Loop Until mb = 0
End If
If mdFlag Then ' was it just a click? Just the slightest drag is needed to select 1 char
b1 = Abs(saveMdx - saveMx) < 2: b2 = Abs(saveMdy - saveMy) < 2
If (b1 And b2) And (VsScreenTop = saveTOP) Then
SelRow = 0: SelCol = 0 ' yes just a click else select single char
End If
End If
Select Case kh
Case 96 And ctrl And Shift ' this is dummy thing because have really wierd error
Case 18176 And ctrl And Shift ' ctrl + shift + home
SelRow = VsScreenTop + CRow - 1: CCol = Len(VS$(SelRow)) + 6
VsScreenTop = 1: CRow = 1: CCol = 7
Case 20224 And ctrl And Shift ' ctrl + shift + end
SelRow = VsScreenTop + CRow - 1: CCol = 7
VsScreenTop = VsUB: CRow = 1: CCol = Len(VS$(VsUB)) + 6
Case 96 And ctrl ' tic + ctrl this is dummy thing because have really wierd error
Case 120 And ctrl: CopySelected: DeleteSelected: NeedsSaving = -1 ' ctrl and x cut
Case 99 And ctrl: CopySelected ' 11/25 fix changing CRow ' ctrl and c copy
Case 118 And ctrl: Paste: NeedsSaving = -1 ' ctrl and V paste
Case 110 And ctrl: New ' ctrl and N new file stuff
Case 111 And ctrl: FLoad ' ctrl and O open
Case 115 And ctrl: SaveIt ' ctrl and S Save
Case 97 And ctrl: SaveAsName ' ctrl and A Save As
Case 15616 And ctrl: FindWhat 1: FindNext 0 ' ctrl + F3 is Find...
Case 15616 And Shift: FindNext -1
Case 18176 And ctrl: VsScreenTop = 1: CRow = 1: CCol = 7 ' ctrl+home
Case 20224 And ctrl: VsScreenTop = VsUB: CRow = 1: CCol = Len(VS$(VsUB)) + 6 ' ctrl+end
Case 15616 And alt: ChangeToWhat 0 ' alt + F3
Case 21248 ' delete above my backspace keyboard
If SelRow Then
DeleteSelected
ElseIf VsTail$ = "" Then
VS$(VsIndex) = VsHead$ + VS$(VsIndex + 1)
DynArr_Delete VsIndex + 1, VS$()
Else
VS$(VsIndex) = VsHead$ + Right$(VsTail$, Len(VsTail$) - 1)
End If
NeedsSaving = -1: SelRow = 0
Case 8 ' backspace drag text at the cursor
If SelRow Then DeleteSelected
If CCol > 7 Then ' to left one space
VS$(VsIndex) = Mid$(VsHead$, 1, Len(VsHead$) - 1) + VsTail$
CCol = CCol - 1: NeedsSaving = -1
ElseIf CCol = 7 And CRow > 1 Then 'drag VsTail$ up to end of back row
CRow = CRow - 1: NeedsSaving = -1
VsHead$ = VS$(VsIndex - 1)
CCol = Len(VsHead$) + 1 + 6
VS$(VsIndex - 1) = VsHead$ + VsTail$
DynArr_Delete VsIndex, VS$() 'delete line at vsIndex
End If
NeedsSaving = -1: SelRow = 0
Case 13 ' enter
If SelRow Then DeleteSelected
If CCol = 7 Then ' blank line here and all else moved down
DynArr_Insert "", VsIndex, VS$()
ElseIf CCol >= Len(VS$(VsIndex)) + 1 + 6 Then ' next line is blank
DynArr_Insert "", VsIndex + 1, VS$()
Else ' in the middle of the text line
VS$(VsIndex) = VsHead$
DynArr_Insert VsTail$, VsIndex + 1, VS$()
End If
CCol = 1 + 6
If CRow < MaxRow Then ' fix curs going down past screen!
CRow = CRow + 1
Else
VsScreenTop = VsScreenTop + 1
End If
NeedsSaving = -1: SelRow = 0
Case 32 To 255 And (ctrl = 0)
If SelRow Then DeleteSelected
If CCol < MaxCol Then ' insert chr$ and advance
VS$(VsIndex) = VsHead$ + Chr$(kh) + VsTail$
CCol = CCol + 1
Else
s$ = "You are at the end of line for editing."
_MessageBox "Keypress ignored.", s$, "warning"
End If
NeedsSaving = -1: SelRow = 0
Case 18432 ' up
CheckShift
If CRow > 1 Then
CRow = CRow - 1
ElseIf VsScreenTop > 1 Then
VsScreenTop = VsScreenTop - 1
End If
Case 20480 ' down
CheckShift
If CRow < MaxRow And CRow + VsScreenTop <= VsUB Then
CRow = CRow + 1
ElseIf VsScreenTop < VsUB And CRow + VsScreenTop <= VsUB Then
VsScreenTop = VsScreenTop + 1
End If
Case 19200 ' left
CheckShift: If CCol > 7 Then CCol = CCol - 1
Case 19712 ' right
CheckShift: If CCol < MaxCol Then CCol = CCol + 1
Case 18176 ' home
CheckShift: CCol = 7
Case 20224 ' end vs$(index) = VsScreenTop + Crow-1
CheckShift: CCol = Len(VS$(VsScreenTop + CRow - 1)) + 7
If CCol > MaxCol Then CCol = MaxCol
Case 18688 ' page up
CheckShift
If VsScreenTop > MaxRow Then VsScreenTop = VsScreenTop - MaxRow Else VsScreenTop = 1
Case 20736 ' page down
CheckShift: If VsScreenTop + MaxRow <= VsUB Then VsScreenTop = VsScreenTop + MaxRow
If CRow + VsScreenTop > VsUB Then CRow = VsUB - VsScreenTop + 1
If CRow < 1 Then Beep: CRow = 1 ' needed ?
Case 27: CheckSave: System ' esc exec keys
Case 15104: Menu ' F1 help
Case 15360: LoadClip ' F2 loads file array into Clipboard
Case 15616: FindNext 0 ' F3 Find Next
Case 15872: ChangeToWhat -1 ' F4 Change all
End Select
If _MouseButton(2) Then Menu
Loop
' ========================================File Handling Stuff might make a nice ToolBox !
Sub CheckSave
Dim a As Long, s$
If NeedsSaving = -1 Then
s$ = "Do you want to save changes to " + Filename$
a = _MessageBox("Save work?", s$, "yesno", "question")
If a = 1 Then SaveIt
End If
End Sub
Sub New
CheckSave
ReDim VS$(1 To 1)
CCol = 7: CRow = 1: VsScreenTop = 1: NeedsSaving = 0
Filename$ = "untitled": SelRow = 0: SelCol = 0
End Sub
Sub FLoad () 'to do a .txt file getter plug-in here
Dim fn$, fline$
Dim As Long lc, ub
CheckSave
fn$ = _OpenFileDialog$("Select File to Edit", , "*.txt|*.bas", "Text or Basic files")
If fn$ <> "" Then
If _FileExists(fn$) Then
ReDim VS$(1 To 100)
Open fn$ For Input As #1
While Not EOF(1)
Line Input #1, fline$
lc = lc + 1
ub = UBound(VS$)
If lc > UBound(VS$) Then ReDim _Preserve VS$(1 To ub + 100)
VS$(lc) = fline$
Wend
Close #1
ReDim _Preserve VS$(1 To lc)
Filename$ = fn$
CCol = 7: CRow = 1: VsScreenTop = 1: NeedsSaving = 0
SelRow = 0: SelCol = 0
End If
End If
End Sub
Sub SaveIt
Dim lb As Long, i As Long, fini As Long
If Filename$ = "untitled" Then SaveAsName: Exit Sub ' get a name going
lb = LBound(VS$)
i = UBound(VS$) ' dont save a bunch of emptiness
While _Trim$(VS$(i)) = "" ' don't go below lb
If i - 1 > lb Then i = i - 1 Else Exit While
Wend
fini = i
Open Filename$ For Output As #1
For i = 1 To fini
Print #1, VS$(i)
Next
Close
NeedsSaving = 0
_MessageBox "Saved", Filename$
End Sub
Sub SaveAsName ' reset a file name then save to that
Dim answer$, t$, w$, m$, n$, yn As Long
t$ = "Save As Warning:"
w$ = "warning"
n$ = "Nothing has been saved yet."
answer$ = _SaveFileDialog$("Save File As:", _CWD$, "*.txt|*.bas", "txt or bas file")
If answer$ <> "" Then
If _FileExists(answer$) Then
m$ = answer$ + ", File already exists. Do you wish to Start Over?"
yn = _MessageBox("Write Over Existing File?", m$, "yesno", w$)
If yn <> 1 Then _MessageBox t$, n$, w$: Exit Sub
End If
Filename$ = answer$
_Delay .1 'make sure the name is changed Why the hell is this asking me twice!!!!!!!!
SaveIt
Else
_MessageBox t$, n$, w$
End If
End Sub
' ========================================================= End of File Handling Stuff
Sub CheckShared
Dim s$, ls As Long
If CRow < 1 Then CRow = CRow + 1
While CRow > MaxRow
CRow = CRow - 1
Wend
While CCol < MinCol
CCol = CCol + 1
Wend
While CCol > MaxCol ' get col in screen
CCol = CCol - 1
Wend
VsUB = UBound(VS$)
If VsScreenTop > VsUB Then VsScreenTop = VsUB
While VsScreenTop + CRow - 1 > VsUB
CRow = CRow - 1
Wend
VsIndex = VsScreenTop + CRow - 1
VsCol = CCol - 6
s$ = VS$(VsIndex): ls = Len(s$)
If VsCol > ls Then
s$ = Left$(s$ + Space$(103), 103)
VsTail$ = RTrim$(Mid$(s$, VsCol))
Else
VsTail$ = Mid$(s$, VsCol)
End If
If VsCol > 1 Then VsHead$ = Mid$(s$, 1, VsCol - 1) Else VsHead$ = ""
End Sub
Sub CheckShift ' do I need this? oh yeah now I do!!! use only on navigator keys
If SelRow And Shift Then
' ok
ElseIf SelRow = 0 And Shift Then ' select on
SelRow = VsScreenTop + CRow - 1: SelCol = CCol - 6 ' set anchor point
Else
SelRow = 0: SelCol = 0 ' select off
End If
End Sub
Sub DrwCurs ' for this app specially for font
Static As Long loops
loops = loops + 1
If loops Mod 30 < 15 Then
Line ((CCol - 1) * FW, (CRow - 1) * 20 + 19)-Step(FW, 1), FG, BF
End If
If loops Mod 30 = 0 Then loops = 1
End Sub
Sub Show ' and tell when the line is getting dangerously long, no word wrap
Dim As Long i, r, fini
Dim As Long selLow, selHigh, selRow2, selCol2, lC, rCol ' for showing selected text
Dim s$
Line (0, 0)-(6 * FW, _Height), EBG, BF
Line (0, 30.5 * 20)-(_Width, _Height), EBG, BF
Line (6 * FW, 0)-(_Width, 30.5 * 20), BG, BF
Color FG
If SelRow Then ' we have selected text get our ducks in order
selRow2 = VsScreenTop + CRow - 1 ' update this shared variable
selCol2 = CCol - 6 ' no if's this has to be set , this shouldn't be shared
If SelRow = selRow2 Then
If SelCol < selCol2 Then lC = SelCol: rCol = selCol2 Else lC = selCol2: rCol = SelCol
selLow = SelRow: selHigh = selRow2
ElseIf SelRow < selRow2 Then
selLow = SelRow: selHigh = selRow2
ElseIf SelRow > selRow2 Then
selLow = selRow2: selHigh = SelRow
End If
End If
If VsScreenTop + 29 <= VsUB Then fini = VsScreenTop + 29 Else fini = VsUB '? last page
Color EFG, EBG ' print the line numbers
For i = VsScreenTop To fini
r = r + 1
_PrintString (0, (r - 1) * 20), (Right$(Space$(4) + _Trim$(Str$(i)), 5)) ' + " "
Next
r = 0
Color FG, BG ' main part of screen
For i = VsScreenTop To fini
r = r + 1
If (selLow = selHigh) And (i = selLow) Then ' highlite partial section on 1 line
_PrintString (6 * FW + 1, (r - 1) * 20), Mid$(VS$(i), 1, lC - 1)
Color BG, FG
_PrintString ((6 + lC - 1) * FW + 1, (r - 1) * 20), Mid$(VS$(i), lC, rCol - lC + 1)
Color FG, BG
_PrintString ((6 + rCol) * FW + 1, (r - 1) * 20), Mid$(VS$(i), rCol + 1)
ElseIf (selLow <> selHigh) And ((i >= selLow) And (i <= selHigh)) Then
Color BG, FG ' highlight whole line
_PrintString (6 * FW + 1, (r - 1) * 20), VS$(i)
Else
Color FG, BG ' normal line no highlites
_PrintString (6 * FW + 1, (r - 1) * 20), VS$(i)
End If
Next
Color EFG, EBG ' Bottom section
If Len(Filename$) <= 100 Then
s$ = Filename$
Else
s$ = Left$(Filename$, 10) + "... " + Right$(Filename$, 86)
End If
CP 32, s$
s$ = "Menu/Help F1" + Spc(20)
s$ = s$ + "Cursor Row, Col:" + n3$(CRow) + "," + n3$(CCol - 6)
If NeedsSaving = 0 Then s$ = s$ + Spc(20) + "Saved" Else s$ = s$ + Spc(20) + "NOT saved"
CP 33, s$
s$ = "Selected Text Anchor Row, Col: " + n3$(SelRow) + "," + n3$(SelCol)
s$ = s$ + Spc(10) + "Find: '" + Find$ + "'"
PS 3, 34, s$
s$ = "Selected Text End Row, Col: " + n3$(selRow2) + "," + n3$(selCol2)
s$ = s$ + Spc(8) + "Change: '" + Change$ + "'"
PS 6, 35, s$
DrwCurs
_Display
End Sub
Sub CopySelected ' now copy to clipboard
Dim As Long i ' multi lines
Dim As Long selLow, selHigh, selRow2, selCol2, lCol, rCol ' for selected text
If SelRow = 0 Then _Clipboard$ = "": Exit Sub ' nothing to see here
If SelRow Then ' we have selected text get our ducks in order
selRow2 = VsScreenTop + CRow - 1 ' update this shared variable
selCol2 = CCol - 6 ' no if's this has to be set , this shouldn't be shared
If SelRow = selRow2 Then
If SelCol < selCol2 Then
lCol = SelCol: rCol = selCol2
Else
lCol = selCol2: rCol = SelCol
End If
selLow = SelRow: selHigh = selRow2
ElseIf SelRow < selRow2 Then
selLow = SelRow: selHigh = selRow2
ElseIf SelRow > selRow2 Then
selLow = selRow2: selHigh = SelRow
End If
End If
If selLow = selHigh Then ' using lc and rc no row deletions from VS$
_Clipboard$ = Mid$(VS$(selLow), lCol, rCol - lCol + 1)
Else ' for deleting we will have to work backwards in VS$()
_Clipboard$ = "" ' clear contents
For i = selLow To selHigh ' these are vs$ array indexes
If i = selLow Then
_Clipboard$ = VS$(i) ' clear contents
Else
_Clipboard$ = _Clipboard$ + Chr$(13) + Chr$(10) + VS$(i)
End If
Next
End If
'_MessageBox "Copy in Clipboard$", _Clipboard$
End Sub
Sub DeleteSelected ' built from redundant model from Show to cover all vs$()
' save what we are deleting just in case?
Dim As Long i, Nlines, Sline
Dim As Long selLow, selHigh, selRow2, selCol2, lCol, rCol ' for showing selected text
Dim s$
If SelRow = 0 Then Exit Sub ' nothing to see here
If SelRow Then ' we have selected text get our ducks in order
selRow2 = VsScreenTop + CRow - 1 ' update this shared variable
selCol2 = CCol - 6 ' no if's this has to be set , this shouldn't be shared
If SelRow = selRow2 Then
If SelCol < selCol2 Then
lCol = SelCol: rCol = selCol2
Else
lCol = selCol2: rCol = SelCol
End If
selLow = SelRow: selHigh = selRow2
ElseIf SelRow < selRow2 Then
selLow = SelRow: selHigh = selRow2
ElseIf SelRow > selRow2 Then
selLow = selRow2: selHigh = SelRow
End If
End If
Nlines = selHigh - selLow + 1
Sline = Nlines
If selLow = selHigh Then ' using lc and rc no row deletions from VS$
s$ = Mid$(VS$(selLow), 1, lCol - 1)
s$ = s$ + Mid$(VS$(selLow), rCol + 1)
VS$(selLow) = s$
CCol = lCol + 6
Else ' for deleting we will have to work backwards in VS$()
For i = selHigh To selLow Step -1 ' these are vs$ array indexes
DynArr_Delete i, VS$()
Sline = Sline - 1
Next
If selLow - 1 > 0 Then CRow = selLow - 1 Else CRow = 1
CCol = 7
End If
SelRow = 0: SelCol = 0
CheckShared ' <<< do i have to??? it keeps everything in bounds safe hopefully
End Sub
Sub Paste ' check clipboard for CRLF, LF, if non found assume single line paste
Dim As Long ubClip, i, currentRow
Dim c$, d$, s$, t$
If SelRow Then DeleteSelected ' does CheckShared
currentRow = VsScreenTop + CRow - 1 ' need a CheckShared first?
c$ = _Clipboard$
If c$ = "" Then Exit Sub
If InStr(c$, Chr$(13) + Chr$(10)) Then
d$ = Chr$(13) + Chr$(10)
ElseIf InStr(c$, Chr$(10)) Then
d$ = Chr$(10)
Else ' it's a oneliner or less
s$ = Mid$(VS$(currentRow), 1, CCol - 7) ' 6 is 1 too far right
t$ = s$ + c$ + Mid$(VS$(currentRow), CCol - 6)
VS$(currentRow) = t$
CCol = CCol + Len(c$)
Exit Sub
End If
ReDim clip$(1 To 1)
Split c$, d$, clip$()
ubClip = UBound(clip$)
For i = 1 To ubClip
DynArr_Insert clip$(i), currentRow, VS$()
currentRow = currentRow + 1
Next
CRow = CRow + currentRow ' put cursor at end of inserted
CheckShared ' makesure CRow ok and update vs variables
CCol = Len(VS$(VsScreenTop + CRow - 1)) + 7
End Sub
Function n3$ (n As Long)
n3$ = Right$(Spc(2) + Str$(n), 3)
End Function
Sub PS (Col&, Row&, txt$) ' for this app
_PrintString ((Col& - 1) * 11, (Row& - 1) * 20), txt$
End Sub
Sub CP (row, txt$) 'on row center Print txt$ modified for this app
Dim col As Long, s$
If _PrintWidth(txt$) > _Width Then
s$ = Right$(txt$, Int(_Width / FW))
Else
s$ = txt$
End If
col = (_Width / FW - Len(txt$)) \ 2
_PrintString (col * FW, (row - 1) * 20), s$
End Sub
Sub Split (SplitMeString As String, delim As String, loadMeArray() As String)
Dim curpos As Long, arrpos As Long, LD As Long, dpos As Long 'fix use the Lbound
curpos = 1: arrpos = LBound(loadMeArray): LD = Len(delim)
dpos = InStr(curpos, SplitMeString, delim)
Do Until dpos = 0
loadMeArray(arrpos) = Mid$(SplitMeString, curpos, dpos - curpos)
arrpos = arrpos + 1
If arrpos > UBound(loadMeArray) Then
ReDim _Preserve loadMeArray(LBound(loadMeArray) To UBound(loadMeArray) + 1000) As String
End If
curpos = dpos + LD
dpos = InStr(curpos, SplitMeString, delim)
Loop
loadMeArray(arrpos) = Mid$(SplitMeString, curpos)
ReDim _Preserve loadMeArray(LBound(loadMeArray) To arrpos) As String 'get the ubound correct
End Sub
Function Join$ (arr() As String, delimiter$)
Dim i As Long, b$
For i = LBound(arr) To UBound(arr)
If i = LBound(arr) Then b$ = arr(LBound(arr)) Else b$ = b$ + delimiter$ + arr(i)
Next
Join$ = b$
End Function
'2023-11-14 \QB64 Files\000 work QB64\000 Test\Array Tools_
' \Dynamic Array Tools\DynArr_Insert and Delete.bas"
Sub DynArr_Insert (Text$, Place&, DynArr$())
' Text$ is a string of text, or empty string
' Place& is insertion index
' DynArr$() is an array that can be resized, the first step in fact
' to insert the line we increase the array ubound by 0ne
' copy all lines below up one
' finally insert the line into place&
' ah! what if Place& is > ub ? then just add it to end or place it exactly?
' I say place it exactly!
Dim As Long lb, ub, i, diff
Dim m$ ' message too long for one line
lb = LBound(DynArr$)
If Place& < lb Then
m$ = "The Place& argument < Lbound(DynArr$), skipping insertion."
_MessageBox "Sub DynArr_Insert Error", m$, "warning"
Exit Sub ' no since shutting down program for little error
End If
ub = UBound(DynArr$)
If Place& > ub Then
diff = Place& - ub
ReDim _Preserve DynArr$(lb To ub + diff)
For i = ub + 1 To ub + diff - 1
DynArr$(i) = "" ' fill in between
Next
Else
ReDim _Preserve DynArr$(lb To ub + 1)
For i = ub To Place& Step -1
DynArr$(i + 1) = DynArr$(i) ' copy lines up one
Next
End If
DynArr$(Place&) = Text$ ' finally add the insertion
End Sub
'2023-11-14 \QB64 Files\000 work QB64\000 Test\Array Tools_
' \Dynamic Array Tools\DynArr_Insert and Delete.bas"
Sub DynArr_Delete (Place&, DynArr$())
' the reverse of an insertion
' Place& is deletion index
' DynArr$() is an array that can be resized
' to delete the line we copy all the lines above, down one
' then remove the last line by Redim one line less
Dim As Long lb, ub, i
Dim m$ ' message too long for one line
lb = LBound(DynArr$)
ub = UBound(DynArr$)
If ub = lb Then Exit Sub
If Place& < lb Or Place& > ub Then ' nope!
m$ = "The Place& argument is outside the bounds of array, skipping deletion."
_MessageBox "Sub DynArr_Delete Error", m$, "warning"
Exit Sub ' no since shutting down program for little error
End If
If Place& < ub Then
For i = Place& To ub - 1
DynArr$(i) = DynArr$(i + 1) ' copy lines up one
Next
End If
ReDim _Preserve DynArr$(lb To ub - 1)
End Sub
Sub Menu ' modified for this app
'this sub uses drwBtn
Dim As Long ub, lb, b, col, row, mx, my, mb, topChoice
topChoice = 15
Dim choice$(1 To topChoice), s$
ub = UBound(choice$): lb = LBound(choice$)
For b = lb To ub ' drawing a column of buttons at _width - 210 starting at y = 10
col = Int((b - 1) / 8)
If b Mod 8 = 0 Then row = 8 Else row = b Mod 8
drwBtn col * 290 + 40, row * 60 + 10, choice$(b)
Next
Do
While _MouseInput: Wend
mx = _MouseX: my = _MouseY: mb = _MouseButton(1)
If mb Then
_Delay .25 ' delay to give user time to release mouse button
For b = lb To ub
col = Int((b - 1) / 8)
If b Mod 8 = 0 Then row = 8 Else row = b Mod 8
If mx > col * 290 + 40 And mx <= col * 290 + 290 Then
If my >= row * 60 + 10 And my <= row * 60 + 60 Then
Exit Do
End If
End If
Next
End If
_Display
_Limit 60
Loop
s$ = "Enter: 1 = Forest, 2 = Patriot, 3 = Orange or ? = Mystery"
Select Case b
Case 1: New
Case 2: FLoad
Case 3: SaveIt
Case 4: SaveAsName
Case 5: CopySelected: DeleteSelected: NeedsSaving = -1
Case 6: CopySelected
Case 7: Paste: NeedsSaving = -1
Case 8: Exit Sub
Case 9: FindWhat 1: FindNext (0) ' get find$ and start search
Case 10: FindNext 0 ' search forward
Case 11: FindNext -1 ' serach reverse
Case 12: ChangeToWhat 0 ' alt + F3
Case 13: ChangeToWhat -1 ' F4 change all
Case 14: b = Val(_InputBox$("Color Theme:", s$, "1")): ColorTheme b
Case 15: CheckSave: System
End Select
_KeyClear
End Sub
Sub drwBtn (x, y, s$) '250 x 50 modified for this app
Dim fc~&, bc~&
Line (x + 2, y + 2)-Step(248, 48), _RGB32(0), BF ' shadow
Line (x, y)-Step(244, 44), _RGB32(255), BF ' highlight edge
Line (x + 2, y + 2)-Step(243, 43), _RGB32(190), BF ' face color
fc~& = _DefaultColor: bc~& = _BackgroundColor ' save color before we change
Color _RGB32(0), _RGB32(190)
_PrintString (x + 125 - .5 * FW * Len(s$) + 1, y + 16 + 1), s$
Color fc~&, bc~& ' restore color
End Sub
Sub ColorTheme (n%)
Select Case n%
Case 1 ' Forest Theme sky, leaves, earth
FG = _RGB32(160, 160, 255): BG = _RGB32(0, 60, 0): EFG = FG: EBG = _RGB32(40, 20, 10)
Case 2 ' Patriot Theme edge of eye watering white, OldGloryRed, OldGloryBlue
FG = &HFFDDDDDD: BG = &HFFBF0A30: EFG = FG: EBG = &HFF002868 '
Case 3 ' Orange Theme light, low, med red/low (no blue)
FG = _RGB32(200, 250, 200): BG = _RGB32(240, 120, 0): EFG = FG: EBG = _RGB32(160, 30, 0)
Case Else ' Gray Theme
FG = _RGB32(0): BG = _RGB32(160): EBG = _RGB32(80)
End Select
End Sub
Sub FindWhat (title As Long)
Dim t$, s$
If title = 1 Then t$ = "Find..."
If title = 2 Then t$ = "Change..."
If title = 3 Then t$ = "Change All"
s$ = SelectedLine$
If Len(s$) Then
Find$ = _InputBox$(t$, "Find what?", s$)
Else
Find$ = _InputBox$(t$, "Find what?")
End If
CaseSense = _MessageBox("Case Sensitive?", "Match case exactly?", "yesno")
If CaseSense = 1 Then CaseSense = -1 Else CaseSense = 0
findR = 0: findC = 0: Change$ = ""
End Sub
Sub ChangeToWhat (all As Long)
Dim As Long i, startRow, startCol, cpos, yn, countChanges
If all Then FindWhat 3 Else FindWhat 2
Change$ = _InputBox$("Change:", "Change " + Find$ + " to what?")
i = VsScreenTop + CRow - 1: startRow = i: startCol = 1
Do
checkRow:
If CaseSense Then ' exact match
cpos = InStr(startCol, VS$(i), Find$)
Else
cpos = InStr(startCol, UCase$(VS$(i)), UCase$(Find$))
End If
If cpos Then
startCol = cpos + 1 ' set next find
If all = 0 Then
SelRow = i: SelCol = cpos ' setting up for display of find, select anchor
VsScreenTop = i: CRow = 1: CCol = 6 + cpos + Len(Find$) - 1 ' display find
Show
yn = _MessageBox("Change to:", Change$, "yesnocancel", "question")
If yn = 0 Then ' Cancel
SelRow = 0: SelCol = 0
Exit Sub
ElseIf yn = 1 Then ' change
VS$(i) = Mid$(VS$(i), 1, cpos - 1) + Change$ + Mid$(VS$(i), cpos + Len(Find$))
SelRow = 0: SelCol = 0
Show
NeedsSaving = -1
countChanges = countChanges + 1
'ElseIf yn = 2 Then ' dont change it but continue search
End If
GoTo checkRow ' search row some more!
Else
VS$(i) = Mid$(VS$(i), 1, cpos - 1) + Change$ + Mid$(VS$(i), cpos + Len(Find$))
NeedsSaving = -1
countChanges = countChanges + 1
GoTo checkRow ' search row some more!
End If
End If
i = i + 1: If i > VsUB Then i = 1
startCol = 1
If i = startRow And startCol = 1 Then Exit Do ' we are back to where we started
Loop
_MessageBox "Change...", "There were" + Str$(countChanges) + " changes made.", "info"
Change$ = ""
_KeyClear
End Sub
Sub FindNext (reverse As Long)
Dim As Long i, saveRow, start, cpos
If Find$ = "" Then FindWhat 1
i = VsScreenTop + CRow - 1: start = findC + 1: saveRow = i
Do
If CaseSense Then ' exact match
cpos = InStr(start, VS$(i), Find$)
Else
cpos = InStr(start, UCase$(VS$(i)), UCase$(Find$))
End If
If cpos Then
findR = i: findC = cpos ' save last find
SelRow = i: SelCol = cpos ' select anchor
VsScreenTop = i: CRow = 1: CCol = 6 + cpos + Len(Find$) - 1 ' display find
Show
Exit Sub
End If
If reverse Then
i = i - 1: If i < 1 Then i = VsUB
Else
i = i + 1: If i > VsUB Then i = 1
End If
start = 1
If i > VsUB Then i = 1
If i = 0 Then i = VsUB
If i = saveRow And start = 1 Then Exit Do
Loop
_MessageBox "Find Next", "Match not found.", "info"
End Sub
Sub LoadClip ' F2 instead of select all just load clipboard with vs$
Dim i As Long, crlf$
crlf$ = Chr$(13) + Chr$(10)
_Clipboard$ = VS$(1)
For i = 2 To VsUB
_Clipboard$ = _Clipboard$ + crlf$ + VS$(i)
Next
_MessageBox "Clipboard Update:", "File loaded into Clipboard.", "info"
End Sub
Function SelectedLine$
Dim selRow2, selcol2, lCol, rCol
If SelRow Then ' we have selected text get our ducks in order
selRow2 = VsScreenTop + CRow - 1 ' update this shared variable
selcol2 = CCol - 6 ' no if's this has to be set , this shouldn't be shared
If SelRow = selRow2 Then
If SelCol < selcol2 Then
lCol = SelCol: rCol = selcol2
Else
lCol = selcol2: rCol = SelCol
End If
SelectedLine$ = Mid$(VS$(SelRow), lCol, rCol - lCol + 1)
End If
End If
End Function
Theme 1 Forest
Theme 2 Patriot
Theme 3 Orange with Menu popup buttons
Although not complete, it is a good step further than other efforts and might give an aspiring editor builder some helpful ideas.
Oh for Linux users lucon.ttf (all lower case) attached here :
(07-28-2024, 11:00 PM)bplus Wrote: Here is my Editor project kind of stalled out for awhile. It is 820 LOC and has allot of standard features QB64 has including Cut, Copy and Paste. This is working condition before I attempted to add horizontal scrolling so that part is not working like QB64 yet. You have 100 chars wide plus?... screening.
You should have entire menu with one right click but F2 button not added yet. It pastes the entire file you are working on into the Clipboard to paste where-ever you want. So this thing should not need instructions to use, if it does I'd like to know. The menu lists the shortcut buttons with it's function.
' Screen, colors, font
Dim Shared As Long XMax: XMax = 1200 '109 chars wide minus 6 space for line numbers 100 chars
Dim Shared As Long YMax: YMax = 700 ' 30 chars high (600) + 100 pixels = 5 rows for Editor stuff
Screen _NewImage(XMax, YMax, 32): _ScreenMove 40, 35
Dim Shared As _Unsigned Long FG, BG, EFG, EBG: ColorTheme 1 ' Forest color theme
Dim Shared As Long Fnt, FW, FH: Fnt = _LoadFont("lucon.ttf", 18, "MONOSPACE") ' add font to folder
If Fnt <= 0 Then Print "Font failed to load, goodbye!": _Delay 5: System
_Font Fnt: FH = _FontHeight: FW = _FontWidth 'FW=11, FH=18 use 20 for row height, cursor fits below
' cursor on screen area
Dim Shared As Long MinCol: MinCol = 7 ' on left is 5 digits and space for line numbers
Dim Shared As Long MaxCol: MaxCol = 109 ' 109 no minus 6 for line numbers but text starts on col 7
Dim Shared As Long MaxRow: MaxRow = 30 ' 30 rows * 20
' for display, track the array index for top row of screen
Dim Shared As Long VsScreenTop: VsScreenTop = 1
Dim Shared As Long VsUB, VsIndex, VsCol ' <<< only set or updated in CheckShared
Dim Shared VsTail$, VsHead$ ' CheckShared but Backspace sets VsHead$ too
ReDim Shared VS$(1 To 1) ' VS$ Variable String main work array
' cursor
Dim Shared As Long CCol, CRow ' the cursor position on screen and actual text is 7 char position
'track selected text and highlighting it
Dim Shared As Long Shift ' Shared?? used in CheckShift sub, one line could be added back in main
Dim Shared As Long SelRow, SelCol ' these anchor the one point in text for cursor in any direction
' work file
Dim Shared Filename$ ' the working filename "untitled" no extension until SaveIt called
Dim Shared As Long NeedsSaving: NeedsSaving = 0 ' track whether the work needs to be saved
' search and change
Dim Shared Find$, CaseSense As Long, Change$, findR As Long, findC As Long
' locals
Dim As Long kh, ctrl, alt, b1, b2 ' key variables and booleans
Dim As Long scroll, mdx, mdy, mx, my, mb, mdFlag, saveTOP ' mouse and flags for mouse functions
Dim As Long saveMdx, saveMdy, saveMx, saveMy ' detecting pixel moves of mouse to select single char
Dim s$ ' to shorten super long code lines because of text ie messagebox text
FLoad
Do 'main interface loop
CheckShared ' the one and only place where all the Vs... Variables are set Except VsTopScreen!
Show ' replace CLS now draws cursor and _displays from sub
_Limit 60 'easy on the cpu?
kh = _KeyHit
Shift = _KeyDown(100304) Or _KeyDown(100303)
ctrl = _KeyDown(100306) Or _KeyDown(100305)
alt = _KeyDown(100308) Or _KeyDown(100307)
Do While _MouseInput ' scrolling just like an up or down arrow
scroll = _MouseWheel
If scroll = -1 Then 'up
CRow = 1 ' faster scrolling
kh = 18432
ElseIf scroll = 1 Then 'down
If VsScreenTop + 30 - 1 > VsUB Then CRow = VsUB - VsScreenTop + 1 Else CRow = 30
kh = 20480
End If
Loop
' MouseButton down and drag set MouseDown x, y for select anchor
'
' Yea! Finally this will highlite up and down screen by dragging mouse!
' Saved EDIT VSLA 2023-11-24 ***
'
mdFlag = 0: saveMdx = _MouseX: saveMdy = _MouseY ' get precise pixels for later
mdx = saveMdx \ FW + 1: mdy = saveMdy \ 20 + 1: mb = _MouseButton(1)
If mb And ((mdx >= MinCol) And ((mdx <= MaxCol) And (mdy <= MaxCol))) Then
SelRow = VsScreenTop + mdy - 1: SelCol = mdx - 6
mdFlag = 1: saveTOP = VsScreenTop ' this is for just a click? code
'Beep ' should only be once at mouse down OK
Do
While _MouseInput: Wend
saveMx = _MouseX: saveMy = _MouseY
mx = saveMx \ FW + 1: my = saveMy \ 20 + 1: mb = _MouseButton(1)
If ((mx >= MinCol) And (mx <= MaxCol)) And (mb And (my <= MaxRow)) Then
If (saveMy < 4) And ((mx >= MinCol) And (mx <= MaxCol)) Then 'scroll up
If VsScreenTop > 1 Then VsScreenTop = VsScreenTop - 1: _Delay .1
ElseIf (saveMy > 596) And ((mx >= MinCol) And (mx <= MaxCol)) Then 'scroll down?
If VsScreenTop < VsUB Then VsScreenTop = VsScreenTop + 1: _Delay .1
End If
CRow = my: CCol = mx
If CRow + VsScreenTop - 1 > VsUB Then CRow = VsUB - VsScreenTop + 1
Show
End If
Loop Until mb = 0
End If
If mdFlag Then ' was it just a click? Just the slightest drag is needed to select 1 char
b1 = Abs(saveMdx - saveMx) < 2: b2 = Abs(saveMdy - saveMy) < 2
If (b1 And b2) And (VsScreenTop = saveTOP) Then
SelRow = 0: SelCol = 0 ' yes just a click else select single char
End If
End If
Select Case kh
Case 96 And ctrl And Shift ' this is dummy thing because have really wierd error
Case 18176 And ctrl And Shift ' ctrl + shift + home
SelRow = VsScreenTop + CRow - 1: CCol = Len(VS$(SelRow)) + 6
VsScreenTop = 1: CRow = 1: CCol = 7
Case 20224 And ctrl And Shift ' ctrl + shift + end
SelRow = VsScreenTop + CRow - 1: CCol = 7
VsScreenTop = VsUB: CRow = 1: CCol = Len(VS$(VsUB)) + 6
Case 96 And ctrl ' tic + ctrl this is dummy thing because have really wierd error
Case 120 And ctrl: CopySelected: DeleteSelected: NeedsSaving = -1 ' ctrl and x cut
Case 99 And ctrl: CopySelected ' 11/25 fix changing CRow ' ctrl and c copy
Case 118 And ctrl: Paste: NeedsSaving = -1 ' ctrl and V paste
Case 110 And ctrl: New ' ctrl and N new file stuff
Case 111 And ctrl: FLoad ' ctrl and O open
Case 115 And ctrl: SaveIt ' ctrl and S Save
Case 97 And ctrl: SaveAsName ' ctrl and A Save As
Case 15616 And ctrl: FindWhat 1: FindNext 0 ' ctrl + F3 is Find...
Case 15616 And Shift: FindNext -1
Case 18176 And ctrl: VsScreenTop = 1: CRow = 1: CCol = 7 ' ctrl+home
Case 20224 And ctrl: VsScreenTop = VsUB: CRow = 1: CCol = Len(VS$(VsUB)) + 6 ' ctrl+end
Case 15616 And alt: ChangeToWhat 0 ' alt + F3
Case 21248 ' delete above my backspace keyboard
If SelRow Then
DeleteSelected
ElseIf VsTail$ = "" Then
VS$(VsIndex) = VsHead$ + VS$(VsIndex + 1)
DynArr_Delete VsIndex + 1, VS$()
Else
VS$(VsIndex) = VsHead$ + Right$(VsTail$, Len(VsTail$) - 1)
End If
NeedsSaving = -1: SelRow = 0
Case 8 ' backspace drag text at the cursor
If SelRow Then DeleteSelected
If CCol > 7 Then ' to left one space
VS$(VsIndex) = Mid$(VsHead$, 1, Len(VsHead$) - 1) + VsTail$
CCol = CCol - 1: NeedsSaving = -1
ElseIf CCol = 7 And CRow > 1 Then 'drag VsTail$ up to end of back row
CRow = CRow - 1: NeedsSaving = -1
VsHead$ = VS$(VsIndex - 1)
CCol = Len(VsHead$) + 1 + 6
VS$(VsIndex - 1) = VsHead$ + VsTail$
DynArr_Delete VsIndex, VS$() 'delete line at vsIndex
End If
NeedsSaving = -1: SelRow = 0
Case 13 ' enter
If SelRow Then DeleteSelected
If CCol = 7 Then ' blank line here and all else moved down
DynArr_Insert "", VsIndex, VS$()
ElseIf CCol >= Len(VS$(VsIndex)) + 1 + 6 Then ' next line is blank
DynArr_Insert "", VsIndex + 1, VS$()
Else ' in the middle of the text line
VS$(VsIndex) = VsHead$
DynArr_Insert VsTail$, VsIndex + 1, VS$()
End If
CCol = 1 + 6
If CRow < MaxRow Then ' fix curs going down past screen!
CRow = CRow + 1
Else
VsScreenTop = VsScreenTop + 1
End If
NeedsSaving = -1: SelRow = 0
Case 32 To 255 And (ctrl = 0)
If SelRow Then DeleteSelected
If CCol < MaxCol Then ' insert chr$ and advance
VS$(VsIndex) = VsHead$ + Chr$(kh) + VsTail$
CCol = CCol + 1
Else
s$ = "You are at the end of line for editing."
_MessageBox "Keypress ignored.", s$, "warning"
End If
NeedsSaving = -1: SelRow = 0
Case 18432 ' up
CheckShift
If CRow > 1 Then
CRow = CRow - 1
ElseIf VsScreenTop > 1 Then
VsScreenTop = VsScreenTop - 1
End If
Case 20480 ' down
CheckShift
If CRow < MaxRow And CRow + VsScreenTop <= VsUB Then
CRow = CRow + 1
ElseIf VsScreenTop < VsUB And CRow + VsScreenTop <= VsUB Then
VsScreenTop = VsScreenTop + 1
End If
Case 19200 ' left
CheckShift: If CCol > 7 Then CCol = CCol - 1
Case 19712 ' right
CheckShift: If CCol < MaxCol Then CCol = CCol + 1
Case 18176 ' home
CheckShift: CCol = 7
Case 20224 ' end vs$(index) = VsScreenTop + Crow-1
CheckShift: CCol = Len(VS$(VsScreenTop + CRow - 1)) + 7
If CCol > MaxCol Then CCol = MaxCol
Case 18688 ' page up
CheckShift
If VsScreenTop > MaxRow Then VsScreenTop = VsScreenTop - MaxRow Else VsScreenTop = 1
Case 20736 ' page down
CheckShift: If VsScreenTop + MaxRow <= VsUB Then VsScreenTop = VsScreenTop + MaxRow
If CRow + VsScreenTop > VsUB Then CRow = VsUB - VsScreenTop + 1
If CRow < 1 Then Beep: CRow = 1 ' needed ?
Case 27: CheckSave: System ' esc exec keys
Case 15104: Menu ' F1 help
Case 15360: LoadClip ' F2 loads file array into Clipboard
Case 15616: FindNext 0 ' F3 Find Next
Case 15872: ChangeToWhat -1 ' F4 Change all
End Select
If _MouseButton(2) Then Menu
Loop
' ========================================File Handling Stuff might make a nice ToolBox !
Sub CheckSave
Dim a As Long, s$
If NeedsSaving = -1 Then
s$ = "Do you want to save changes to " + Filename$
a = _MessageBox("Save work?", s$, "yesno", "question")
If a = 1 Then SaveIt
End If
End Sub
Sub New
CheckSave
ReDim VS$(1 To 1)
CCol = 7: CRow = 1: VsScreenTop = 1: NeedsSaving = 0
Filename$ = "untitled": SelRow = 0: SelCol = 0
End Sub
Sub FLoad () 'to do a .txt file getter plug-in here
Dim fn$, fline$
Dim As Long lc, ub
CheckSave
fn$ = _OpenFileDialog$("Select File to Edit", , "*.txt|*.bas", "Text or Basic files")
If fn$ <> "" Then
If _FileExists(fn$) Then
ReDim VS$(1 To 100)
Open fn$ For Input As #1
While Not EOF(1)
Line Input #1, fline$
lc = lc + 1
ub = UBound(VS$)
If lc > UBound(VS$) Then ReDim _Preserve VS$(1 To ub + 100)
VS$(lc) = fline$
Wend
Close #1
ReDim _Preserve VS$(1 To lc)
Filename$ = fn$
CCol = 7: CRow = 1: VsScreenTop = 1: NeedsSaving = 0
SelRow = 0: SelCol = 0
End If
End If
End Sub
Sub SaveIt
Dim lb As Long, i As Long, fini As Long
If Filename$ = "untitled" Then SaveAsName: Exit Sub ' get a name going
lb = LBound(VS$)
i = UBound(VS$) ' dont save a bunch of emptiness
While _Trim$(VS$(i)) = "" ' don't go below lb
If i - 1 > lb Then i = i - 1 Else Exit While
Wend
fini = i
Open Filename$ For Output As #1
For i = 1 To fini
Print #1, VS$(i)
Next
Close
NeedsSaving = 0
_MessageBox "Saved", Filename$
End Sub
Sub SaveAsName ' reset a file name then save to that
Dim answer$, t$, w$, m$, n$, yn As Long
t$ = "Save As Warning:"
w$ = "warning"
n$ = "Nothing has been saved yet."
answer$ = _SaveFileDialog$("Save File As:", _CWD$, "*.txt|*.bas", "txt or bas file")
If answer$ <> "" Then
If _FileExists(answer$) Then
m$ = answer$ + ", File already exists. Do you wish to Start Over?"
yn = _MessageBox("Write Over Existing File?", m$, "yesno", w$)
If yn <> 1 Then _MessageBox t$, n$, w$: Exit Sub
End If
Filename$ = answer$
_Delay .1 'make sure the name is changed Why the hell is this asking me twice!!!!!!!!
SaveIt
Else
_MessageBox t$, n$, w$
End If
End Sub
' ========================================================= End of File Handling Stuff
Sub CheckShared
Dim s$, ls As Long
If CRow < 1 Then CRow = CRow + 1
While CRow > MaxRow
CRow = CRow - 1
Wend
While CCol < MinCol
CCol = CCol + 1
Wend
While CCol > MaxCol ' get col in screen
CCol = CCol - 1
Wend
VsUB = UBound(VS$)
If VsScreenTop > VsUB Then VsScreenTop = VsUB
While VsScreenTop + CRow - 1 > VsUB
CRow = CRow - 1
Wend
VsIndex = VsScreenTop + CRow - 1
VsCol = CCol - 6
s$ = VS$(VsIndex): ls = Len(s$)
If VsCol > ls Then
s$ = Left$(s$ + Space$(103), 103)
VsTail$ = RTrim$(Mid$(s$, VsCol))
Else
VsTail$ = Mid$(s$, VsCol)
End If
If VsCol > 1 Then VsHead$ = Mid$(s$, 1, VsCol - 1) Else VsHead$ = ""
End Sub
Sub CheckShift ' do I need this? oh yeah now I do!!! use only on navigator keys
If SelRow And Shift Then
' ok
ElseIf SelRow = 0 And Shift Then ' select on
SelRow = VsScreenTop + CRow - 1: SelCol = CCol - 6 ' set anchor point
Else
SelRow = 0: SelCol = 0 ' select off
End If
End Sub
Sub DrwCurs ' for this app specially for font
Static As Long loops
loops = loops + 1
If loops Mod 30 < 15 Then
Line ((CCol - 1) * FW, (CRow - 1) * 20 + 19)-Step(FW, 1), FG, BF
End If
If loops Mod 30 = 0 Then loops = 1
End Sub
Sub Show ' and tell when the line is getting dangerously long, no word wrap
Dim As Long i, r, fini
Dim As Long selLow, selHigh, selRow2, selCol2, lC, rCol ' for showing selected text
Dim s$
Line (0, 0)-(6 * FW, _Height), EBG, BF
Line (0, 30.5 * 20)-(_Width, _Height), EBG, BF
Line (6 * FW, 0)-(_Width, 30.5 * 20), BG, BF
Color FG
If SelRow Then ' we have selected text get our ducks in order
selRow2 = VsScreenTop + CRow - 1 ' update this shared variable
selCol2 = CCol - 6 ' no if's this has to be set , this shouldn't be shared
If SelRow = selRow2 Then
If SelCol < selCol2 Then lC = SelCol: rCol = selCol2 Else lC = selCol2: rCol = SelCol
selLow = SelRow: selHigh = selRow2
ElseIf SelRow < selRow2 Then
selLow = SelRow: selHigh = selRow2
ElseIf SelRow > selRow2 Then
selLow = selRow2: selHigh = SelRow
End If
End If
If VsScreenTop + 29 <= VsUB Then fini = VsScreenTop + 29 Else fini = VsUB '? last page
Color EFG, EBG ' print the line numbers
For i = VsScreenTop To fini
r = r + 1
_PrintString (0, (r - 1) * 20), (Right$(Space$(4) + _Trim$(Str$(i)), 5)) ' + " "
Next
r = 0
Color FG, BG ' main part of screen
For i = VsScreenTop To fini
r = r + 1
If (selLow = selHigh) And (i = selLow) Then ' highlite partial section on 1 line
_PrintString (6 * FW + 1, (r - 1) * 20), Mid$(VS$(i), 1, lC - 1)
Color BG, FG
_PrintString ((6 + lC - 1) * FW + 1, (r - 1) * 20), Mid$(VS$(i), lC, rCol - lC + 1)
Color FG, BG
_PrintString ((6 + rCol) * FW + 1, (r - 1) * 20), Mid$(VS$(i), rCol + 1)
ElseIf (selLow <> selHigh) And ((i >= selLow) And (i <= selHigh)) Then
Color BG, FG ' highlight whole line
_PrintString (6 * FW + 1, (r - 1) * 20), VS$(i)
Else
Color FG, BG ' normal line no highlites
_PrintString (6 * FW + 1, (r - 1) * 20), VS$(i)
End If
Next
Color EFG, EBG ' Bottom section
If Len(Filename$) <= 100 Then
s$ = Filename$
Else
s$ = Left$(Filename$, 10) + "... " + Right$(Filename$, 86)
End If
CP 32, s$
s$ = "Menu/Help F1" + Spc(20)
s$ = s$ + "Cursor Row, Col:" + n3$(CRow) + "," + n3$(CCol - 6)
If NeedsSaving = 0 Then s$ = s$ + Spc(20) + "Saved" Else s$ = s$ + Spc(20) + "NOT saved"
CP 33, s$
s$ = "Selected Text Anchor Row, Col: " + n3$(SelRow) + "," + n3$(SelCol)
s$ = s$ + Spc(10) + "Find: '" + Find$ + "'"
PS 3, 34, s$
s$ = "Selected Text End Row, Col: " + n3$(selRow2) + "," + n3$(selCol2)
s$ = s$ + Spc(8) + "Change: '" + Change$ + "'"
PS 6, 35, s$
DrwCurs
_Display
End Sub
Sub CopySelected ' now copy to clipboard
Dim As Long i ' multi lines
Dim As Long selLow, selHigh, selRow2, selCol2, lCol, rCol ' for selected text
If SelRow = 0 Then _Clipboard$ = "": Exit Sub ' nothing to see here
If SelRow Then ' we have selected text get our ducks in order
selRow2 = VsScreenTop + CRow - 1 ' update this shared variable
selCol2 = CCol - 6 ' no if's this has to be set , this shouldn't be shared
If SelRow = selRow2 Then
If SelCol < selCol2 Then
lCol = SelCol: rCol = selCol2
Else
lCol = selCol2: rCol = SelCol
End If
selLow = SelRow: selHigh = selRow2
ElseIf SelRow < selRow2 Then
selLow = SelRow: selHigh = selRow2
ElseIf SelRow > selRow2 Then
selLow = selRow2: selHigh = SelRow
End If
End If
If selLow = selHigh Then ' using lc and rc no row deletions from VS$
_Clipboard$ = Mid$(VS$(selLow), lCol, rCol - lCol + 1)
Else ' for deleting we will have to work backwards in VS$()
_Clipboard$ = "" ' clear contents
For i = selLow To selHigh ' these are vs$ array indexes
If i = selLow Then
_Clipboard$ = VS$(i) ' clear contents
Else
_Clipboard$ = _Clipboard$ + Chr$(13) + Chr$(10) + VS$(i)
End If
Next
End If
'_MessageBox "Copy in Clipboard$", _Clipboard$
End Sub
Sub DeleteSelected ' built from redundant model from Show to cover all vs$()
' save what we are deleting just in case?
Dim As Long i, Nlines, Sline
Dim As Long selLow, selHigh, selRow2, selCol2, lCol, rCol ' for showing selected text
Dim s$
If SelRow = 0 Then Exit Sub ' nothing to see here
If SelRow Then ' we have selected text get our ducks in order
selRow2 = VsScreenTop + CRow - 1 ' update this shared variable
selCol2 = CCol - 6 ' no if's this has to be set , this shouldn't be shared
If SelRow = selRow2 Then
If SelCol < selCol2 Then
lCol = SelCol: rCol = selCol2
Else
lCol = selCol2: rCol = SelCol
End If
selLow = SelRow: selHigh = selRow2
ElseIf SelRow < selRow2 Then
selLow = SelRow: selHigh = selRow2
ElseIf SelRow > selRow2 Then
selLow = selRow2: selHigh = SelRow
End If
End If
Nlines = selHigh - selLow + 1
Sline = Nlines
If selLow = selHigh Then ' using lc and rc no row deletions from VS$
s$ = Mid$(VS$(selLow), 1, lCol - 1)
s$ = s$ + Mid$(VS$(selLow), rCol + 1)
VS$(selLow) = s$
CCol = lCol + 6
Else ' for deleting we will have to work backwards in VS$()
For i = selHigh To selLow Step -1 ' these are vs$ array indexes
DynArr_Delete i, VS$()
Sline = Sline - 1
Next
If selLow - 1 > 0 Then CRow = selLow - 1 Else CRow = 1
CCol = 7
End If
SelRow = 0: SelCol = 0
CheckShared ' <<< do i have to??? it keeps everything in bounds safe hopefully
End Sub
Sub Paste ' check clipboard for CRLF, LF, if non found assume single line paste
Dim As Long ubClip, i, currentRow
Dim c$, d$, s$, t$
If SelRow Then DeleteSelected ' does CheckShared
currentRow = VsScreenTop + CRow - 1 ' need a CheckShared first?
c$ = _Clipboard$
If c$ = "" Then Exit Sub
If InStr(c$, Chr$(13) + Chr$(10)) Then
d$ = Chr$(13) + Chr$(10)
ElseIf InStr(c$, Chr$(10)) Then
d$ = Chr$(10)
Else ' it's a oneliner or less
s$ = Mid$(VS$(currentRow), 1, CCol - 7) ' 6 is 1 too far right
t$ = s$ + c$ + Mid$(VS$(currentRow), CCol - 6)
VS$(currentRow) = t$
CCol = CCol + Len(c$)
Exit Sub
End If
ReDim clip$(1 To 1)
Split c$, d$, clip$()
ubClip = UBound(clip$)
For i = 1 To ubClip
DynArr_Insert clip$(i), currentRow, VS$()
currentRow = currentRow + 1
Next
CRow = CRow + currentRow ' put cursor at end of inserted
CheckShared ' makesure CRow ok and update vs variables
CCol = Len(VS$(VsScreenTop + CRow - 1)) + 7
End Sub
Function n3$ (n As Long)
n3$ = Right$(Spc(2) + Str$(n), 3)
End Function
Sub PS (Col&, Row&, txt$) ' for this app
_PrintString ((Col& - 1) * 11, (Row& - 1) * 20), txt$
End Sub
Sub CP (row, txt$) 'on row center Print txt$ modified for this app
Dim col As Long, s$
If _PrintWidth(txt$) > _Width Then
s$ = Right$(txt$, Int(_Width / FW))
Else
s$ = txt$
End If
col = (_Width / FW - Len(txt$)) \ 2
_PrintString (col * FW, (row - 1) * 20), s$
End Sub
Sub Split (SplitMeString As String, delim As String, loadMeArray() As String)
Dim curpos As Long, arrpos As Long, LD As Long, dpos As Long 'fix use the Lbound
curpos = 1: arrpos = LBound(loadMeArray): LD = Len(delim)
dpos = InStr(curpos, SplitMeString, delim)
Do Until dpos = 0
loadMeArray(arrpos) = Mid$(SplitMeString, curpos, dpos - curpos)
arrpos = arrpos + 1
If arrpos > UBound(loadMeArray) Then
ReDim _Preserve loadMeArray(LBound(loadMeArray) To UBound(loadMeArray) + 1000) As String
End If
curpos = dpos + LD
dpos = InStr(curpos, SplitMeString, delim)
Loop
loadMeArray(arrpos) = Mid$(SplitMeString, curpos)
ReDim _Preserve loadMeArray(LBound(loadMeArray) To arrpos) As String 'get the ubound correct
End Sub
Function Join$ (arr() As String, delimiter$)
Dim i As Long, b$
For i = LBound(arr) To UBound(arr)
If i = LBound(arr) Then b$ = arr(LBound(arr)) Else b$ = b$ + delimiter$ + arr(i)
Next
Join$ = b$
End Function
'2023-11-14 \QB64 Files\000 work QB64\000 Test\Array Tools_
' \Dynamic Array Tools\DynArr_Insert and Delete.bas"
Sub DynArr_Insert (Text$, Place&, DynArr$())
' Text$ is a string of text, or empty string
' Place& is insertion index
' DynArr$() is an array that can be resized, the first step in fact
' to insert the line we increase the array ubound by 0ne
' copy all lines below up one
' finally insert the line into place&
' ah! what if Place& is > ub ? then just add it to end or place it exactly?
' I say place it exactly!
Dim As Long lb, ub, i, diff
Dim m$ ' message too long for one line
lb = LBound(DynArr$)
If Place& < lb Then
m$ = "The Place& argument < Lbound(DynArr$), skipping insertion."
_MessageBox "Sub DynArr_Insert Error", m$, "warning"
Exit Sub ' no since shutting down program for little error
End If
ub = UBound(DynArr$)
If Place& > ub Then
diff = Place& - ub
ReDim _Preserve DynArr$(lb To ub + diff)
For i = ub + 1 To ub + diff - 1
DynArr$(i) = "" ' fill in between
Next
Else
ReDim _Preserve DynArr$(lb To ub + 1)
For i = ub To Place& Step -1
DynArr$(i + 1) = DynArr$(i) ' copy lines up one
Next
End If
DynArr$(Place&) = Text$ ' finally add the insertion
End Sub
'2023-11-14 \QB64 Files\000 work QB64\000 Test\Array Tools_
' \Dynamic Array Tools\DynArr_Insert and Delete.bas"
Sub DynArr_Delete (Place&, DynArr$())
' the reverse of an insertion
' Place& is deletion index
' DynArr$() is an array that can be resized
' to delete the line we copy all the lines above, down one
' then remove the last line by Redim one line less
Dim As Long lb, ub, i
Dim m$ ' message too long for one line
lb = LBound(DynArr$)
ub = UBound(DynArr$)
If ub = lb Then Exit Sub
If Place& < lb Or Place& > ub Then ' nope!
m$ = "The Place& argument is outside the bounds of array, skipping deletion."
_MessageBox "Sub DynArr_Delete Error", m$, "warning"
Exit Sub ' no since shutting down program for little error
End If
If Place& < ub Then
For i = Place& To ub - 1
DynArr$(i) = DynArr$(i + 1) ' copy lines up one
Next
End If
ReDim _Preserve DynArr$(lb To ub - 1)
End Sub
Sub Menu ' modified for this app
'this sub uses drwBtn
Dim As Long ub, lb, b, col, row, mx, my, mb, topChoice
topChoice = 15
Dim choice$(1 To topChoice), s$
ub = UBound(choice$): lb = LBound(choice$)
For b = lb To ub ' drawing a column of buttons at _width - 210 starting at y = 10
col = Int((b - 1) / 8)
If b Mod 8 = 0 Then row = 8 Else row = b Mod 8
drwBtn col * 290 + 40, row * 60 + 10, choice$(b)
Next
Do
While _MouseInput: Wend
mx = _MouseX: my = _MouseY: mb = _MouseButton(1)
If mb Then
_Delay .25 ' delay to give user time to release mouse button
For b = lb To ub
col = Int((b - 1) / 8)
If b Mod 8 = 0 Then row = 8 Else row = b Mod 8
If mx > col * 290 + 40 And mx <= col * 290 + 290 Then
If my >= row * 60 + 10 And my <= row * 60 + 60 Then
Exit Do
End If
End If
Next
End If
_Display
_Limit 60
Loop
s$ = "Enter: 1 = Forest, 2 = Patriot, 3 = Orange or ? = Mystery"
Select Case b
Case 1: New
Case 2: FLoad
Case 3: SaveIt
Case 4: SaveAsName
Case 5: CopySelected: DeleteSelected: NeedsSaving = -1
Case 6: CopySelected
Case 7: Paste: NeedsSaving = -1
Case 8: Exit Sub
Case 9: FindWhat 1: FindNext (0) ' get find$ and start search
Case 10: FindNext 0 ' search forward
Case 11: FindNext -1 ' serach reverse
Case 12: ChangeToWhat 0 ' alt + F3
Case 13: ChangeToWhat -1 ' F4 change all
Case 14: b = Val(_InputBox$("Color Theme:", s$, "1")): ColorTheme b
Case 15: CheckSave: System
End Select
_KeyClear
End Sub
Sub drwBtn (x, y, s$) '250 x 50 modified for this app
Dim fc~&, bc~&
Line (x + 2, y + 2)-Step(248, 48), _RGB32(0), BF ' shadow
Line (x, y)-Step(244, 44), _RGB32(255), BF ' highlight edge
Line (x + 2, y + 2)-Step(243, 43), _RGB32(190), BF ' face color
fc~& = _DefaultColor: bc~& = _BackgroundColor ' save color before we change
Color _RGB32(0), _RGB32(190)
_PrintString (x + 125 - .5 * FW * Len(s$) + 1, y + 16 + 1), s$
Color fc~&, bc~& ' restore color
End Sub
Sub ColorTheme (n%)
Select Case n%
Case 1 ' Forest Theme sky, leaves, earth
FG = _RGB32(160, 160, 255): BG = _RGB32(0, 60, 0): EFG = FG: EBG = _RGB32(40, 20, 10)
Case 2 ' Patriot Theme edge of eye watering white, OldGloryRed, OldGloryBlue
FG = &HFFDDDDDD: BG = &HFFBF0A30: EFG = FG: EBG = &HFF002868 '
Case 3 ' Orange Theme light, low, med red/low (no blue)
FG = _RGB32(200, 250, 200): BG = _RGB32(240, 120, 0): EFG = FG: EBG = _RGB32(160, 30, 0)
Case Else ' Gray Theme
FG = _RGB32(0): BG = _RGB32(160): EBG = _RGB32(80)
End Select
End Sub
Sub FindWhat (title As Long)
Dim t$, s$
If title = 1 Then t$ = "Find..."
If title = 2 Then t$ = "Change..."
If title = 3 Then t$ = "Change All"
s$ = SelectedLine$
If Len(s$) Then
Find$ = _InputBox$(t$, "Find what?", s$)
Else
Find$ = _InputBox$(t$, "Find what?")
End If
CaseSense = _MessageBox("Case Sensitive?", "Match case exactly?", "yesno")
If CaseSense = 1 Then CaseSense = -1 Else CaseSense = 0
findR = 0: findC = 0: Change$ = ""
End Sub
Sub ChangeToWhat (all As Long)
Dim As Long i, startRow, startCol, cpos, yn, countChanges
If all Then FindWhat 3 Else FindWhat 2
Change$ = _InputBox$("Change:", "Change " + Find$ + " to what?")
i = VsScreenTop + CRow - 1: startRow = i: startCol = 1
Do
checkRow:
If CaseSense Then ' exact match
cpos = InStr(startCol, VS$(i), Find$)
Else
cpos = InStr(startCol, UCase$(VS$(i)), UCase$(Find$))
End If
If cpos Then
startCol = cpos + 1 ' set next find
If all = 0 Then
SelRow = i: SelCol = cpos ' setting up for display of find, select anchor
VsScreenTop = i: CRow = 1: CCol = 6 + cpos + Len(Find$) - 1 ' display find
Show
yn = _MessageBox("Change to:", Change$, "yesnocancel", "question")
If yn = 0 Then ' Cancel
SelRow = 0: SelCol = 0
Exit Sub
ElseIf yn = 1 Then ' change
VS$(i) = Mid$(VS$(i), 1, cpos - 1) + Change$ + Mid$(VS$(i), cpos + Len(Find$))
SelRow = 0: SelCol = 0
Show
NeedsSaving = -1
countChanges = countChanges + 1
'ElseIf yn = 2 Then ' dont change it but continue search
End If
GoTo checkRow ' search row some more!
Else
VS$(i) = Mid$(VS$(i), 1, cpos - 1) + Change$ + Mid$(VS$(i), cpos + Len(Find$))
NeedsSaving = -1
countChanges = countChanges + 1
GoTo checkRow ' search row some more!
End If
End If
i = i + 1: If i > VsUB Then i = 1
startCol = 1
If i = startRow And startCol = 1 Then Exit Do ' we are back to where we started
Loop
_MessageBox "Change...", "There were" + Str$(countChanges) + " changes made.", "info"
Change$ = ""
_KeyClear
End Sub
Sub FindNext (reverse As Long)
Dim As Long i, saveRow, start, cpos
If Find$ = "" Then FindWhat 1
i = VsScreenTop + CRow - 1: start = findC + 1: saveRow = i
Do
If CaseSense Then ' exact match
cpos = InStr(start, VS$(i), Find$)
Else
cpos = InStr(start, UCase$(VS$(i)), UCase$(Find$))
End If
If cpos Then
findR = i: findC = cpos ' save last find
SelRow = i: SelCol = cpos ' select anchor
VsScreenTop = i: CRow = 1: CCol = 6 + cpos + Len(Find$) - 1 ' display find
Show
Exit Sub
End If
If reverse Then
i = i - 1: If i < 1 Then i = VsUB
Else
i = i + 1: If i > VsUB Then i = 1
End If
start = 1
If i > VsUB Then i = 1
If i = 0 Then i = VsUB
If i = saveRow And start = 1 Then Exit Do
Loop
_MessageBox "Find Next", "Match not found.", "info"
End Sub
Sub LoadClip ' F2 instead of select all just load clipboard with vs$
Dim i As Long, crlf$
crlf$ = Chr$(13) + Chr$(10)
_Clipboard$ = VS$(1)
For i = 2 To VsUB
_Clipboard$ = _Clipboard$ + crlf$ + VS$(i)
Next
_MessageBox "Clipboard Update:", "File loaded into Clipboard.", "info"
End Sub
Function SelectedLine$
Dim selRow2, selcol2, lCol, rCol
If SelRow Then ' we have selected text get our ducks in order
selRow2 = VsScreenTop + CRow - 1 ' update this shared variable
selcol2 = CCol - 6 ' no if's this has to be set , this shouldn't be shared
If SelRow = selRow2 Then
If SelCol < selcol2 Then
lCol = SelCol: rCol = selcol2
Else
lCol = selcol2: rCol = SelCol
End If
SelectedLine$ = Mid$(VS$(SelRow), lCol, rCol - lCol + 1)
End If
End If
End Function
Theme 1 Forest
Theme 2 Patriot
Theme 3 Orange with Menu popup buttons
Although not complete, it is a good step further than other efforts and might give an aspiring editor builder some helpful ideas.
Oh for Linux users lucon.ttf (all lower case) attached here :
This is the commenting I was referring to - even if I don't understand all of it, I can see what each function does, and why it was used! Good job.
Of all the places on Earth, and all the planets in the Universe, I'd rather live here (Perth, W.A.)
Please visit my Website at: http://oldendayskids.blogspot.com/
07-29-2024, 12:41 AM (This post was last modified: 07-29-2024, 12:14 PM by bplus.)
Oh thankyou Phil,
for this project I kept a Project Notes Journal it might have been useful day to day but 6 years later, not so much. Except F2, I forgot I had used Ctrl + A for Save As because I used F2 to not only select All, the whole file, but to also load it into the clipboard, I think it saves a step unless you wanted to delete everything!?!
Update: OMG 6 years later?!?! I am thinking of Battleship Mod 842 the code I was hoping to get Phil interested in helping me comment because that is the one I've forgotten and my clues I left behind 6 years ago ain't helping me when I port stuff to JB to show off my game AI
This code is a little better than 6 months old! I agree with Phil the documentation on this one is first rate for me specially the crucial variables shared throughout the program.
As Terry says, it takes real discipline to practice this type of commenting. And patience I would add because this is time consuming to read over and over the code and get wording right in attempts to be meaningful in future like you are reading it for the first time.
07-31-2024, 04:33 PM (This post was last modified: 07-31-2024, 04:34 PM by aadityap0901.)
Here is my update about my text editor:
Advanced Controls: F4 to toggle Symbol Viewer, F6 or Mouseclick for Single Cursor, Alt + Mouseclick for multiple cursors
Symbol Viewer is made for qb64 only, may not work correctly...
Code: (Select All)
'$Dynamic
$Resize:On
Do While _Resize: Loop
Screen _NewImage(960, 540, 32)
Type Vec2
As _Unsigned Integer X, Y
End Type
Dim As Vec2 Cursor_Position(1 To 1)
Cursor_Position(1).X = 1
Cursor_Position(1).Y = 1
Cursor_Character$ = Chr$(95)
Dim Shared Lines$(0), SymbolVariableList$, SymbolTypeList$, SymbolFunctionList$, SymbolSubroutinesList$: SymbolVariableList$ = ListNew$: SymbolTypeList$ = ListNew$: SymbolFunctionList$ = ListNew$: SymbolSubroutinesList$ = ListNew$
Dim Shared As Long SymbolsWindowScrollOffset, VerticalScrollOffset, HorizontalScrollOffset, TextFrameOffset, VerticalLines
SymbolsWindowScrollOffset = 1
VerticalScrollOffset = 1
HorizontalScrollOffset = 1
Dim Shared As _Byte GenerateSymbols, SymbolsWindow: SymbolsWindow = -1
Const LineNumbersWidth = 5
$If WIN Then
If _FileExists(Command$(1)) Then
FilePath$ = Command$(1)
ElseIf _FileExists(_StartDir$ + "\" + Command$(1)) Then
FilePath$ = _StartDir$ + "\" + Command$(1)
End If
$Else
If _FileExists(Command$(1)) Then
FilePath$ = Command$(1)
ElseIf _FileExists(_StartDir$ + "/" + Command$(1)) Then
FilePath$ = _StartDir$ + "/" + Command$(1)
End If
$End If
If FilePath$ = "" Then FilePath$ = "Untitled.txt"
If _FileExists(FilePath$) Then GoSub OpenFile
$If WIN Then
If _InStrRev(FilePath$, "\") Then FileName$ = Mid$(FilePath$, _InStrRev(FilePath$, "\") + 1) Else FileName$ = FilePath$
$Else
If _InStrRev(FilePath$, "/") Then FileName$ = Mid$(FilePath$, _InStrRev(FilePath$, "/") + 1) Else FileName$ = FilePath$
$End If
TITLE$ = FileName$ + " - TEdi"
Color _RGB32(255), _RGB32(0)
Do
_Limit 30
If _Resize Then
Screen _NewImage(_ResizeWidth, _ResizeHeight, 32)
Color _RGB32(255), _RGB32(16)
End If
Cls , _RGB32(16)
'Print Text
J = 0
For I = VerticalScrollOffset To VerticalScrollOffset + VerticalLines
If UBound(Lines$) < I Then Exit For
Color _RGB32(255), _RGB32(32)
_PrintString (TextFrameOffset, J * _FontHeight), " " + _Trim$(Str$(I)) + Space$(LineNumbersWidth - Len(_Trim$(Str$(I))))
Color _RGB32(255), 0
_PrintString (TextFrameOffset + (LineNumbersWidth + 1) * _FontWidth, J * _FontHeight), Mid$(Lines$(I), HorizontalScrollOffset, HorizontalCharsVisible)
J = J + 1
Next I
Line (TextFrameOffset, 0)-(TextFrameOffset, _Height - 1), _RGB32(255)
'----------
'Show Scroll Bar
Line (_Width - 16, 0)-(_Width, _Height), _RGB32(16), BF
Line (_Width - 16, ScrollBO)-(_Width, ScrollBO + ScrollBP), _RGB32(64), BF
'---------------
'Generate Symbols
If FileSaved = 0 Then GenerateSymbols = -1
For I = 1 To 16
If GenerateSymbolsI >= UBound(Lines$) Then GenerateSymbolsI = 0: GenerateSymbols = 0
If GenerateSymbols Then
GenerateSymbolsI = GenerateSymbolsI + 1
If InRange(LBound(Lines$), GenerateSymbolsI, UBound(Lines$)) Then T$ = Tokenizer$(Lines$(GenerateSymbolsI)) Else T$ = ListNew$
If GenerateSymbolsFunction = 0 And GenerateSymbolsSubroutine = 0 Then
T = ListISearch~&(T$, "Dim")
If T Then
For J = 1 To ListLength~&(T$)
E$ = ListGet$(T$, J)
If InStr("dimsharedcommonas_bit_byteintegerlong_integer64singledouble_float_unsigned_mem_offsetto", LCase$(E$)) Or InRange(65, Asc(UCase$(E$), 1), 90) = 0 Then _Continue
If ListISearch~&(SymbolVariableList$, E$) = 0 And ListISearch~&(SymbolTypeList$, E$) = 0 Then SymbolVariableList$ = ListAdd$(SymbolVariableList$, E$)
Next J
End If
T = ListISearch~&(T$, "Type")
If InStr(LCase$(Lines$(GenerateSymbolsI)), "end type") Then
GenerateSymbolsType = 0
SymbolTypeList$ = ListAdd$(SymbolTypeList$, Left$(SymbolType$, Len(SymbolType$) - 1) + "}")
SymbolType$ = ""
End If
If T Or GenerateSymbolsType Then
For J = 1 To ListLength~&(T$)
E$ = ListGet$(T$, J)
If _StriCmp(E$, "Type") = 0 Then
J = J + 1
SymbolType$ = ListGet$(T$, J) + " {"
_Continue
End If
If E$ = "," Then _Continue
If _StriCmp(E$, "As") = 0 Then
J = J + 1
_Continue
End If
SymbolType$ = SymbolType$ + E$ + ","
Next J
If T Then GenerateSymbolsType = -1
End If
End If
T = ListISearch~&(T$, "Function")
If T Then
For J = 1 To ListLength~&(T$)
E$ = ListGet$(T$, J)
If _StriCmp(E$, "Function") = 0 Then
GenerateSymbolsFunction = -1
J = J + 1
E$ = ListGet$(T$, J)
If ListISearch(SymbolFunctionList$, E$) = 0 Then SymbolFunctionList$ = ListAdd$(SymbolFunctionList$, E$)
End If
If _StriCmp(E$, "End") = 0 And _StriCmp(ListGet$(T$, J + 1), "Function") = 0 Then J = J + 1: GenerateSymbolsFunction = 0
Next J
End If
T = ListISearch~&(T$, "Sub")
If T Then
For J = 1 To ListLength~&(T$)
E$ = ListGet$(T$, J)
If _StriCmp(E$, "Sub") = 0 Then
GenerateSymbolsSubroutine = -1
J = J + 1
E$ = ListGet$(T$, J)
If ListISearch(SymbolSubroutinesList$, E$) = 0 Then SymbolSubroutinesList$ = ListAdd$(SymbolSubroutinesList$, E$)
End If
If _StriCmp(E$, "End") = 0 And _StriCmp(ListGet$(T$, J + 1), "Sub") = 0 Then J = J + 1: GenerateSymbolsSubroutine = 0
Next J
End If
End If
Next I
If SymbolsWindow Then
Color _RGB32(255), 0
Line (0, _FontHeight + _Height \ 4)-(TextFrameOffset, _FontHeight + _Height \ 4), _RGB32(255)
Line (0, _FontHeight + _Height \ 2)-(TextFrameOffset, _FontHeight + _Height \ 2), _RGB32(255)
Line (0, _FontHeight + 3 * _Height \ 4)-(TextFrameOffset, _FontHeight + 3 * _Height \ 4), _RGB32(255)
_PrintString (0, 0), "Variables:"
_PrintString (0, _FontHeight + _Height \ 4), "Types:"
_PrintString (0, _FontHeight + _Height \ 2), "Functions:"
_PrintString (0, _FontHeight + 3 * _Height \ 4), "Subroutines:"
For I = SymbolsWindowScrollOffset To Min(ListLength~&(SymbolVariableList$), SymbolsWindowScrollOffset + VerticalLines \ 4 - 1)
_PrintString (0, (I - SymbolsWindowScrollOffset + 1) * _FontHeight), Left$(ListGet$(SymbolVariableList$, I), TextFrameOffset \ _FontWidth)
Next I: For I = SymbolsWindowScrollOffset To Min(ListLength~&(SymbolTypeList$), SymbolsWindowScrollOffset + VerticalLines \ 4 - 2)
_PrintString (0, (I - SymbolsWindowScrollOffset + 2) * _FontHeight + _Height / 4), Left$(ListGet$(SymbolTypeList$, I), TextFrameOffset \ _FontWidth)
Next I: For I = SymbolsWindowScrollOffset To Min(ListLength~&(SymbolFunctionList$), SymbolsWindowScrollOffset + VerticalLines \ 4 - 2)
_PrintString (0, (I - SymbolsWindowScrollOffset + 2) * _FontHeight + _Height / 2), Left$(ListGet$(SymbolFunctionList$, I), TextFrameOffset \ _FontWidth)
Next I: For I = SymbolsWindowScrollOffset To Min(ListLength~&(SymbolSubroutinesList$), SymbolsWindowScrollOffset + VerticalLines \ 4 - 2)
_PrintString (0, (I - SymbolsWindowScrollOffset + 2) * _FontHeight + 3 * _Height / 4), Left$(ListGet$(SymbolSubroutinesList$, I), TextFrameOffset \ _FontWidth)
Next I
End If
'AutoSave after 0.5 Second of Sleep
If Timer(0.1) - KeyPressTimer >= 0.5 And FileSaved = 0 Then
GoSub SaveFile
FileSaved = -1
End If
'------------------------
On _Exit GOTO SaveExit
If FileSaved <> OldFileSaved Then
OldFileSaved = FileSaved
If FileSaved Then _Title TITLE$ Else _Title TITLE$ + "*"
End If
_Display
Loop
System
SaveExit:
GoSub SaveFile
System
ClearFile:
ReDim Lines$(0 To 0)
Return
OpenFile:
If _FileExists(FilePath$) = 0 Then Return
Open FilePath$ For Input As #1
If LOF(1) Then
Do
Line Input #1, L$
If UBound(Lines$) = 0 Then ReDim _Preserve Lines$(1 To 1) Else ReDim _Preserve Lines$(1 To UBound(Lines$) + 1)
Lines$(UBound(Lines$)) = L$
If EOF(1) Then Exit Do
Loop
End If
Close #1
Return
SaveFile:
If FilePath$ = "" Then Return
Open FilePath$ For Output As #1
For I = 1 To UBound(Lines$)
If I = UBound(Lines$) And Lines$(I) = "" Then _Continue
Print #1, Lines$(I)
Next I
Close #1
Return
Function Tokenizer$ (L$)
Dim Tokens(1) As String, nToken As _Unsigned Integer
nToken = 1
TokenList$ = ListNew$
For I = 1 To Len(L$)
Select Case Asc(L$, I)
Case 32
If StringMode = 0 Then
If Tokens(nToken) <> "" Then
TokenList$ = ListAdd$(TokenList$, Tokens(nToken))
nToken = nToken + 1
ReDim _Preserve Tokens(nToken) As String
End If
Else
Tokens(nToken) = Tokens(nToken) + Mid$(L$, I, 1)
End If
Case 34: StringMode = Not StringMode: Tokens(nToken) = Tokens(nToken) + Chr$(34)
Case 40 To 47, 58 To 64, 91 To 94, 96, 123 To 125
If StringMode = 0 Then
If Tokens(nToken) <> "" Then
TokenList$ = ListAdd$(TokenList$, Tokens(nToken))
nToken = nToken + 1
ReDim _Preserve Tokens(nToken) As String
End If
Tokens(nToken) = Mid$(L$, I, 1)
TokenList$ = ListAdd$(TokenList$, Tokens(nToken))
nToken = nToken + 1
ReDim _Preserve Tokens(nToken) As String
Else
Tokens(nToken) = Tokens(nToken) + Mid$(L$, I, 1)
End If
Case 39: If StringMode = 0 Then Exit For
Case Else: Tokens(nToken) = Tokens(nToken) + Mid$(L$, I, 1)
End Select
Next I
If Len(Tokens(nToken)) Then TokenList$ = ListAdd$(TokenList$, Tokens(nToken))
Tokenizer$ = TokenList$
End Function
Sub IncrementINT (A As Integer)
A = A + 1
End Sub
Sub DecrementINT (A As Integer)
A = A - 1
End Sub
Sub IncrementULNG (A As _Unsigned Long)
A = A + 1
End Sub
Sub DecrementULNG (A As _Unsigned Long)
A = A - 1
End Sub
Function Max (A, B)
If A > B Then Max = A Else Max = B
End Function
Function Min (A, B)
If A < B Then Min = A Else Min = B
End Function
Function InRange (A, B, C)
If A < B And B < C Then InRange = -1
End Function
Function ListNew$
ListNew$ = MKL$(0)
End Function
Function ListNewRaw$ (__ListRaw As String)
Dim As _Unsigned Long __I, __nItem, __Nested
Dim As _Unsigned _Byte __C, __StringMode1, __StringMode2
Dim As String __List, __ListArray(0): __nItem = 1
For __I = 2 To Len(__ListRaw) - 1
__C = Asc(__ListRaw, __I)
Select Case __C
Case 34: __StringMode1 = Not __StringMode1
Case 39: __StringMode2 = Not __StringMode2
Case 44: If __StringMode1 = 0 And __StringMode2 = 0 And __Nested = 0 Then __nItem = __nItem + 1: _Continue
Case 91, 123: __Nested = __Nested + 1
Case 93, 125: __Nested = __Nested - 1
End Select
If __nItem > UBound(__ListArray) Then ReDim _Preserve __ListArray(1 To __nItem) As String
__ListArray(__nItem) = __ListArray(__nItem) + Chr$(__C)
Next __I
__List = MKL$(__nItem)
For __I = 1 To __nItem
__List = __List + MKI$(Len(__ListArray(__I))) + __ListArray(__I)
Next __I
ListNewRaw$ = __List
End Function
Function ListLength~& (__List As String)
ListLength~& = CVL(Mid$(__List, 1, 4))
End Function
Function ListAdd$ (__List As String, __Item As String)
ListAdd$ = MKL$(CVL(Mid$(__List, 1, 4)) + 1) + Mid$(__List, 5) + MKI$(Len(__Item)) + __Item
End Function
Sub ListPrint (__List As String)
Dim As _Unsigned Long __nItems, __I, __OFFSET
Dim As _Unsigned Integer __LEN
__nItems = CVL(Mid$(__List, 1, 4))
__OFFSET = 5
Print "[";
For __I = 1 To __nItems
__LEN = CVI(Mid$(__List, __OFFSET, 2))
Print Mid$(__List, __OFFSET + 2, __LEN);
If __I < __nItems Then Print ",";
__OFFSET = __OFFSET + __LEN + 2
Next __I
Print "]"
End Sub
Function ListGet$ (__List As String, __ItemNumber As _Unsigned Long)
Dim As _Unsigned Long __nItems, __I, __OFFSET
Dim As _Unsigned Integer __LEN
__nItems = CVL(Mid$(__List, 1, 4))
If __ItemNumber > __nItems Then Exit Function
__OFFSET = 5
For __I = 1 To __nItems
__LEN = CVI(Mid$(__List, __OFFSET, 2))
If __I = __ItemNumber Then ListGet$ = Mid$(__List, __OFFSET + 2, __LEN): Exit Function
__OFFSET = __OFFSET + __LEN + 2
Next __I
End Function
Function ListSearch~& (__List As String, __Item As String)
Dim As _Unsigned Long __nItems, __I, __OFFSET
Dim As _Unsigned Integer __LEN
__nItems = CVL(Mid$(__List, 1, 4))
__OFFSET = 5
For __I = 1 To __nItems
__LEN = CVI(Mid$(__List, __OFFSET, 2))
If _StrCmp(Mid$(__List, __OFFSET + 2, __LEN), __Item) = 0 Then ListSearch~& = __I: Exit Function
__OFFSET = __OFFSET + __LEN + 2
Next __I
End Function
Function ListISearch~& (__List As String, __Item As String)
Dim As _Unsigned Long __nItems, __I, __OFFSET
Dim As _Unsigned Integer __LEN
__nItems = CVL(Mid$(__List, 1, 4))
__OFFSET = 5
For __I = 1 To __nItems
__LEN = CVI(Mid$(__List, __OFFSET, 2))
If _StriCmp(Mid$(__List, __OFFSET + 2, __LEN), __Item) = 0 Then ListISearch~& = __I: Exit Function
__OFFSET = __OFFSET + __LEN + 2
Next __I
End Function
Function ListEdit$ (__List As String, __ItemNumber As _Unsigned Long, __Item As String)
Dim As _Unsigned Long __nItems, __I, __OFFSET
Dim As _Unsigned Integer __LEN
__nItems = CVL(Mid$(__List, 1, 4))
__OFFSET = 5
If __ItemNumber > __nItems Then Exit Function
For __I = 1 To __nItems
__LEN = CVI(Mid$(__List, __OFFSET, 2))
If __I = __ItemNumber Then
Mid$(__List, __OFFSET, 2) = MKI$(Len(__Item))
ListEdit$ = Left$(__List, __OFFSET + 1) + __Item + Mid$(__List, __OFFSET + __LEN + 2)
Exit Function
End If
__OFFSET = __OFFSET + __LEN + 2
Next __I
End Function
Function ListDelete$ (__List As String, __ItemNumber As _Unsigned Long)
Dim As _Unsigned Long __nItems, __I, __OFFSET
Dim As _Unsigned Integer __LEN
__nItems = CVL(Mid$(__List, 1, 4))
__OFFSET = 5
For __I = 1 To __nItems
__LEN = CVI(Mid$(__List, __OFFSET, 2))
If __I = __ItemNumber Then
ListDelete$ = MKL$(__nItems - 1) + Mid$(__List, 5, __OFFSET - 5) + Mid$(__List, __OFFSET + __LEN + 2)
Exit Function
End If
__OFFSET = __OFFSET + __LEN + 2
Next __I
End Function
Function ListAppend$ (__List As String, __ListAppend As String)
ListAppend$ = MKL$(CVL(Mid$(__List, 1, 4)) + CVL(Mid$(__ListAppend, 1, 4))) + Mid$(__List, 5) + Mid$(__ListAppend, 5)
End Function
Implementing cut copy paste find replace is hard until I add selection function, so I am not doing that currently. File mgmt is just handled with command$(1)
It's a feature to save the file after half a second. I made this for my personal use, and added this feature for the power cut in my house.
08-12-2024, 06:48 AM (This post was last modified: 08-12-2024, 03:15 PM by aadityap0901.)
A new update:
Introducing Fast Syntax Highlighting (but it doesn't highlight keywords yet)
You can change the Comment$ = "'" to view qb64 code, it will highlight code in c / c++ currently.
Code: (Select All)
'$Dynamic
$Resize:On
Do While _Resize: Loop
Screen _NewImage(960, 540, 32)
Type Vec2
As _Unsigned Integer X, Y
End Type
Dim As Vec2 Cursors(1 To 1)
Cursors(1).X = 1
Cursors(1).Y = 1
Cursor_Character$ = Chr$(95)
Dim Shared Lines$(1 To 1)
Dim Shared FormattedLines$(1 To 1), Colorize_StringMode As _Byte, Colorize_CommentMode As _Byte
Dim Shared Comment$, MultiLineCommentOn$, MultiLineCommentOff$
Dim Shared As Long VerticalScrollOffset, HorizontalScrollOffset, TextFrameOffset, VerticalLines
Comment$ = "//"
MultiLineCommentOn$ = "/*"
MultiLineCommentOff$ = "*/"
VerticalScrollOffset = 1
HorizontalScrollOffset = 1
Const LineNumbersWidth = 6
$If WIN Then
FILESEP$ = "\"
$Else
FILESEP$ = "/"
$End If
If _FileExists(Command$(1)) Then
FilePath$ = Command$(1)
ElseIf _FileExists(_StartDir$ + FILESEP$ + Command$(1)) Then
FilePath$ = _StartDir$ + FILESEP$ + Command$(1)
End If
If FilePath$ = "" Then FilePath$ = "Untitled.txt"
If _FileExists(FilePath$) Then GoSub OpenFile
If _InStrRev(FilePath$, FILESEP$) Then FileName$ = Mid$(FilePath$, _InStrRev(FilePath$, FILESEP$) + 1) Else FileName$ = FilePath$
TITLE$ = FileName$ + " - TEdi"
DirPath$ = _StartDir$ 'Left$(FilePath$, _InStrRev(FilePath$, FileName$) - 1)
If Len(DirPath$) Then If _DirExists(DirPath$) Then ChDir DirPath$
Color _RGB32(255), _RGB32(0)
Do
_Limit 30
If _Resize Then
Screen _NewImage(_ResizeWidth, _ResizeHeight, 32)
Color _RGB32(255), _RGB32(16)
End If
If _WindowHasFocus = 0 Then GoTo SKIPDISPLAY
Cls , _RGB32(16)
If DISPLAY Then
'Print Text
J = 0: For I = VerticalScrollOffset To VerticalScrollOffset + VerticalLines: If UBound(Lines$) < I Then Exit For
Color _RGB32(255), _RGB32(32): _PrintString (TextFrameOffset, J * _FontHeight), " " + _Trim$(Str$(I)) + Space$(LineNumbersWidth - Len(_Trim$(Str$(I))))
If Len(FormattedLines$(I)) Then
For K = HorizontalScrollOffset To HorizontalScrollOffset + HorizontalCharsVisible - 1
If K > Len(Lines$(I)) Then Exit For
C& = ColorListGet&(FormattedLines$(I), K)
If C& = 0 Then C& = _RGB32(255, 0, 0)
Color C&, 0
_PrintString (TextFrameOffset + (LineNumbersWidth + K - HorizontalScrollOffset + 1) * _FontWidth, J * _FontHeight), Mid$(Lines$(I), K, 1)
Next K
Else Color _RGB32(255), 0: _PrintString (TextFrameOffset + (LineNumbersWidth + 1) * _FontWidth, J * _FontHeight), Mid$(Lines$(I), HorizontalScrollOffset, HorizontalCharsVisible)
End If
J = J + 1: Next I
Line (TextFrameOffset, 0)-(TextFrameOffset, _Height - 1), _RGB32(255)
'----------
'Show Scroll Bar
Line (_Width - 16, 0)-(_Width, _Height), _RGB32(16), BF
Line (_Width - 16, ScrollBO)-(_Width, ScrollBO + ScrollBP), _RGB32(127), BF
'---------------
_Display
End If
SKIPDISPLAY:
If FileSaved = 0 Then ColorizeLines = -1
If ColorizeLines Then
For I = 1 To 64
ColorizeLines_LineOffset = ColorizeLines_LineOffset + 1
FormattedLines$(ColorizeLines_LineOffset) = Colorize$(Lines$(ColorizeLines_LineOffset))
If ColorizeLines_LineOffset = UBound(Lines$) Then ColorizeLines = 0: ColorizeLines_LineOffset = 0: Exit For
Next I
Else
Colorize_StringMode = 0
Colorize_CommentMode = 0
End If
'AutoSave after 0.5 Second of Sleep
If Timer(0.1) - KeyPressTimer >= 0.5 And FileSaved = 0 Then
GoSub SaveFile
FileSaved = -1
End If
'------------------------
On _Exit GOTO SaveExit
If FileSaved <> OldFileSaved Then
OldFileSaved = FileSaved
If FileSaved Then _Title TITLE$ Else _Title TITLE$ + "*"
End If
Loop
System
SaveExit:
GoSub SaveFile
System
ClearFile:
ReDim Lines$(0 To 0)
Return
OpenFile:
Cls , _RGB32(32)
_PrintString (_Width / 2 - 6 * _FontHeight, _Height / 2 - _FontHeight / 2), "Reading File"
_Display
If _FileExists(FilePath$) = 0 Then Return
ReDim Lines$(0)
Open FilePath$ For Input As #1
If LOF(1) Then
Do
Line Input #1, L$
If UBound(Lines$) = 0 Then
ReDim Lines$(1 To 1)
Else
ReDim _Preserve Lines$(1 To UBound(Lines$) + 1)
End If
Lines$(UBound(Lines$)) = L$
If EOF(1) Then Exit Do
Loop
End If
Close #1
ReDim FormattedLines$(1 To UBound(Lines$))
ColorizeLines = -1
Return
SaveFile:
If FilePath$ = "" Then Return
Open FilePath$ For Output As #1
For I = 1 To UBound(Lines$)
If I = UBound(Lines$) Then Print #1, Lines$(I); Else Print #1, Lines$(I)
Next I
Close #1
Return
Sub AddLine
ReDim _Preserve Lines$(1 To UBound(Lines$) + 1)
ReDim _Preserve FormattedLines$(1 To UBound(Lines$))
End Sub
Sub InsertLine (__LN)
AddLine
For I = UBound(Lines$) - 1 To __LN Step -1
Lines$(I + 1) = Lines$(I)
FormattedLines$(I + 1) = FormattedLines$(I)
Next I
End Sub
Sub RemoveLine (__LN)
For I = __LN To UBound(Lines$) - 1
Lines$(I) = Lines$(I + 1)
FormattedLines$(I) = FormattedLines$(I + 1)
Next I
DeleteLine
End Sub
Sub DeleteLine
ReDim _Preserve Lines$(1 To UBound(Lines$) - 1)
ReDim _Preserve FormattedLines$(1 To UBound(Lines$))
End Sub
Sub IncrementINT (A As Integer)
A = A + 1
End Sub
Sub DecrementINT (A As Integer)
A = A - 1
End Sub
Sub IncrementULNG (A As _Unsigned Long)
A = A + 1
End Sub
Sub DecrementULNG (A As _Unsigned Long)
A = A - 1
End Sub
Function Max (A, B)
If A > B Then Max = A Else Max = B
End Function
Function Min (A, B)
If A < B Then Min = A Else Min = B
End Function
Function InRange (A, B, C)
If A < B And B < C Then InRange = -1
End Function
Function Colorize$ (L$)
If Colorize_CommentMode = 1 Then Colorize_CommentMode = 0
ColorList$ = ColorListNew$
For I = 1 To Len(L$)
C~%% = Asc(L$, I)
If Colorize_StringMode Then
ColorList$ = ColorListAdd$(ColorList$, _RGB32(255, 167, 0))
If C~%% = 34 And Colorize_StringMode = 1 Then Colorize_StringMode = 0
If C~%% = 39 And Colorize_StringMode = 2 Then Colorize_StringMode = 0
Else
If InStr(L$, Comment$) = I Then Colorize_CommentMode = 1
If InStr(L$, MultiLineCommentOn$) = I Then Colorize_CommentMode = 2
If InStr(L$, MultiLineCommentOff$) = I And Colorize_CommentMode = 2 Then Colorize_CommentMode = 0
If Colorize_CommentMode > 0 Then
ColorList$ = ColorListAdd$(ColorList$, _RGB32(127))
Else
Select Case C~%%
Case 9, 32: ColorList$ = ColorListAdd$(ColorList$, _RGB32(0))
Case 34: Colorize_StringMode = 1: ColorList$ = ColorListAdd$(ColorList$, _RGB32(255, 127, 0))
Case 39: Colorize_StringMode = 2: ColorList$ = ColorListAdd$(ColorList$, _RGB32(255, 127, 0))
Case 33, 35 To 38, 40 To 47, 58 To 64, 91 To 96, 123 To 126: ColorList$ = ColorListAdd$(ColorList$, _RGB32(0, 255, 0))
Case 48 To 57: ColorList$ = ColorListAdd$(ColorList$, _RGB32(255, 127, 255))
Case 65 To 90, 97 To 122: ColorList$ = ColorListAdd$(ColorList$, _RGB32(255))
Case Else: ColorList$ = ColorListAdd$(ColorList$, _RGB32(255, 0, 0))
End Select: End If: End If: Next I
Colorize$ = ColorList$: End Function
Function ColorListNew$
ColorListNew$ = MKL$(0)
End Function
Function ColorListLength~& (__ColorList As String)
If Len(__ColorList) < 4 Then ColorListLength~& = 0 Else ColorListLength~& = CVL(Mid$(__ColorList, 1, 4))
End Function
Function ColorListAdd$ (__ColorList As String, __Color As Long)
If Len(__ColorList) < 4 Then __ColorList = MKL$(0)
ColorListAdd$ = MKL$(CVL(Mid$(__ColorList, 1, 4)) + 1) + Mid$(__ColorList, 5) + MKL$(__Color)
End Function
Function ColorListGet& (__ColorList As String, __ItemNumber As _Unsigned Long)
If Len(__ColorList) < 4 Then Exit Function
Dim As _Unsigned Long __nItems, __I, __OFFSET
__nItems = CVL(Mid$(__ColorList, 1, 4))
If __ItemNumber > __nItems Then Exit Function
__OFFSET = 5
For __I = 1 To __nItems
If __I = __ItemNumber Then ColorListGet& = CVL(Mid$(__ColorList, __OFFSET, 4)): Exit Function
__OFFSET = __OFFSET + 4
Next __I
End Function
Function ColorListDelete$ (__ColorList As String, __ItemNumber As _Unsigned Long)
If ColorListLength~&(__ColorList) < __ItemNumber Then Exit Function
If __ItemNumber = 0 Then Exit Function
Dim As _Unsigned Long __nItems, __I, __OFFSET
__nItems = CVL(Mid$(__ColorList, 1, 4))
__OFFSET = 5
For __I = 1 To __nItems
If __I = __ItemNumber Then
ColorListDelete$ = MKL$(__nItems - 1) + Mid$(__ColorList, 5, __OFFSET - 5) + Mid$(__ColorList, __OFFSET + 4)
Exit Function
End If
__OFFSET = __OFFSET + 4
Next __I
End Function
11-13-2024, 04:55 PM (This post was last modified: 11-14-2024, 08:43 AM by aadityap0901.)
A new massive update:
Implement VS-Code style scroll bar, and improved scrolling with mouse (with just adding a '+' in a single line )
Implemented Ctrl Key Combinations:
Ctrl + C -> Copy Current Line ONLY
Ctrl + L -> Delete Whole Line
Ctrl + M -> Overwrite previous line on current line (current line = previous line)
Ctrl + V -> Paste One Line ONLY
No Undo Functions added, cause that's hard too, like colouring keywords.
It's fast, and looks better now.
Still doesn't highlight keywords though
Code: (Select All)
'$Dynamic
$Resize:On
Do While _Resize: Loop
Screen _NewImage(960, 540, 32)
Color -1, 0
Type Vec2
As _Unsigned Integer X, Y
End Type
Dim As Vec2 Cursors(1 To 1)
Cursors(1).X = 1
Cursors(1).Y = 1
Cursor_Character$ = Chr$(95)
Dim Shared Lines$(1 To 1)
Dim Shared FormattedLines$(1 To 1), Colorize_StringMode As _Byte, Colorize_CommentMode As _Byte
Dim Shared Comment$, MultiLineCommentOn$, MultiLineCommentOff$
Dim Shared As Long VerticalScrollOffset, HorizontalScrollOffset, TextFrameOffset, VerticalLines, TotalLines
Dim Shared As _Bit COLOR_MODE: COLOR_MODE = -1
Comment$ = "//"
MultiLineCommentOn$ = "/*"
MultiLineCommentOff$ = "*/"
VerticalScrollOffset = 1
HorizontalScrollOffset = 1
Const LineNumbersWidth = 6
$If WIN Then
FILESEP$ = "\"
$Else
FILESEP$ = "/"
$End If
If _FileExists(Command$(1)) Then
FilePath$ = Command$(1)
ElseIf _FileExists(_StartDir$ + FILESEP$ + Command$(1)) Then
FilePath$ = _StartDir$ + FILESEP$ + Command$(1)
End If
If FilePath$ = "" Then FilePath$ = "Untitled.txt"
If _FileExists(FilePath$) Then GoSub OpenFile
If _InStrRev(FilePath$, FILESEP$) Then FileName$ = Mid$(FilePath$, _InStrRev(FilePath$, FILESEP$) + 1) Else FileName$ = FilePath$
TITLE$ = FileName$ + " - TEdi"
DirPath$ = _StartDir$ 'Left$(FilePath$, _InStrRev(FilePath$, FileName$) - 1)
If Len(DirPath$) Then If _DirExists(DirPath$) Then ChDir DirPath$
DISPLAY = -1
Do
_Limit 30
If _Resize Then
Screen _NewImage(_ResizeWidth, _ResizeHeight, 32)
Color _RGB32(255), _RGB32(16)
End If
If _WindowHasFocus = 0 Then GoTo SKIPDISPLAY
Cls , _RGB32(16)
If DISPLAY Then
VerticalScrollOffset = Max(Min(VerticalScrollOffset, TotalLines), 1)
'Print Text
J = 0: For I = VerticalScrollOffset To VerticalScrollOffset + VerticalLines: If TotalLines < I Then Exit For
Color _RGB32(255), _RGB32(32): _PrintString (TextFrameOffset, J * _FontHeight), " " + _Trim$(Str$(I)) + Space$(LineNumbersWidth - Len(_Trim$(Str$(I))))
If Len(FormattedLines$(I)) Then
If COLOR_MODE Then
For K = HorizontalScrollOffset To HorizontalScrollOffset + HorizontalCharsVisible - 1
If K > Len(Lines$(I)) Then Exit For
C& = ColorListGet&(FormattedLines$(I), K)
If C& = 0 Then C& = _RGB32(255, 0, 0)
Color C&, 0
_PrintString (TextFrameOffset + (LineNumbersWidth + K - HorizontalScrollOffset + 1) * _FontWidth, J * _FontHeight), Mid$(Lines$(I), K, 1)
Next K
Else Color _RGB32(255), 0: _PrintString (TextFrameOffset + (LineNumbersWidth - HorizontalScrollOffset + 2) * _FontWidth, J * _FontHeight), Mid$(Lines$(I), HorizontalScrollOffset, HorizontalCharsVisible)
End If
Else Color _RGB32(255), 0: _PrintString (TextFrameOffset + (LineNumbersWidth + 1) * _FontWidth, J * _FontHeight), Mid$(Lines$(I), HorizontalScrollOffset, HorizontalCharsVisible)
End If
J = J + 1: Next I
Line (TextFrameOffset, 0)-(TextFrameOffset, _Height - 1), _RGB32(255)
'----------
'Show Scroll Bar
Line (_Width - 16, 0)-(_Width, _Height), _RGB32(15), BF
Line (_Width - 16, ScrollBO)-(_Width, ScrollBO + ScrollBP), _RGB32(127), BF
'---------------
'Color Scroll Bar
Line (_Width - 146, 0)-(_Width - 16, _Height), _RGB32(31), BF
S = Min(Max(1, VerticalScrollOffset - _Height / 2), TotalLines - _Height / 2)
Line (_Width - 146, VerticalScrollOffset - S)-(_Width - 16, VerticalScrollOffset - S + VerticalLines), _RGB32(255, 127), BF
For I = S To Max(1, Min(S + _Height, TotalLines))
If I < LBound(Lines$) Or I > TotalLines Then Exit For
For J = 1 To 128
If J > Len(Lines$(I)) Then Exit For
If Asc(Lines$(I), J) = 32 Then _Continue
C& = ColorListGet&(FormattedLines$(I), J)
If C& = 0 Then C& = _RGB32(255, 0, 0)
PSet (_Width - 146 + J, I - S), C&
Next J
For CursorID = LBound(Cursors) To UBound(Cursors)
If Cursors(CursorID).Y = I Then Line (_Width - 146, I - S)-(_Width - 16, I - S), _RGB32(255, 0, 0, 191)
Next CursorID
Next I
_Display
End If
SKIPDISPLAY:
If FileSaved = 0 Then ColorizeLines = -1
If ColorizeLines And TotalLines > 1 Then
For I = 1 To 64
ColorizeLines_LineOffset = ColorizeLines_LineOffset + 1
FormattedLines$(ColorizeLines_LineOffset) = Colorize$(Lines$(ColorizeLines_LineOffset))
If ColorizeLines_LineOffset = TotalLines Then ColorizeLines = 0: ColorizeLines_LineOffset = 0: Colorize_StringMode = 0: Exit For
Next I
Else
Colorize_StringMode = 0
Colorize_CommentMode = 0
End If
'AutoSave after 0.5 Second of Sleep
If Timer(0.1) - KeyPressTimer >= 0.5 And FileSaved = 0 Then
GoSub SaveFile
FileSaved = -1
End If
'------------------------
On _Exit GOTO SaveExit
If FileSaved <> OldFileSaved Then
OldFileSaved = FileSaved
If FileSaved Then _Title TITLE$ Else _Title TITLE$ + "*"
End If
Loop
System
SaveExit:
GoSub SaveFile
System
ClearFile:
ReDim Lines$(0 To 0)
Return
OpenFile:
Cls , _RGB32(32)
_PrintString (_Width / 2 - 6 * _FontHeight, _Height / 2 - _FontHeight / 2), "Reading File"
_Display
If _FileExists(FilePath$) = 0 Then Return
ReDim Lines$(0)
Open FilePath$ For Input As #1
If LOF(1) Then
Do
Line Input #1, L$
If UBound(Lines$) = 0 Then
ReDim Lines$(1 To 1)
Else
ReDim _Preserve Lines$(1 To UBound(Lines$) + 1)
End If
Lines$(UBound(Lines$)) = L$
If EOF(1) Then Exit Do
Loop
Else
ReDim Lines$(1 To 1)
End If
Close #1
ReDim FormattedLines$(1 To UBound(Lines$))
ColorizeLines = -1
Return
SaveFile:
If FilePath$ = "" Then Return
Open FilePath$ For Output As #1
For I = 1 To TotalLines
If I = TotalLines Then Print #1, Lines$(I); Else Print #1, Lines$(I)
Next I
Close #1
Return
Sub AddLine
ReDim _Preserve Lines$(1 To UBound(Lines$) + 1)
ReDim _Preserve FormattedLines$(1 To UBound(Lines$))
End Sub
Sub InsertLine (__LN)
AddLine
For I = UBound(Lines$) - 1 To __LN Step -1
Lines$(I + 1) = Lines$(I)
FormattedLines$(I + 1) = FormattedLines$(I)
Next I
End Sub
Sub RemoveLine (__LN)
For I = __LN To UBound(Lines$) - 1
Lines$(I) = Lines$(I + 1)
FormattedLines$(I) = FormattedLines$(I + 1)
Next I
DeleteLine
End Sub
Sub DeleteLine
ReDim _Preserve Lines$(1 To UBound(Lines$) - 1)
ReDim _Preserve FormattedLines$(1 To UBound(Lines$))
End Sub
Sub IncrementINT (A As Integer)
A = A + 1
End Sub
Sub DecrementINT (A As Integer)
A = A - 1
End Sub
Sub IncrementULNG (A As _Unsigned Long)
A = A + 1
End Sub
Sub DecrementULNG (A As _Unsigned Long)
A = A - 1
End Sub
Function Max (A, B)
If A > B Then Max = A Else Max = B
End Function
Function Min (A, B)
If A < B Then Min = A Else Min = B
End Function
Function InRange (A, B, C)
If A < B And B < C Then InRange = -1
End Function
Function Colorize$ (L$)
If Colorize_CommentMode = 1 Then Colorize_CommentMode = 0
ColorList$ = ColorListNew$
For I = 1 To Len(L$)
C~%% = Asc(L$, I)
If Colorize_StringMode Then
ColorList$ = ColorListAdd$(ColorList$, _RGB32(255, 167, 0))
If C~%% = 34 And Colorize_StringMode = 1 Then Colorize_StringMode = 0
If C~%% = 39 And Colorize_StringMode = 2 Then Colorize_StringMode = 0
Else
If InStr(L$, Comment$) = I Then Colorize_CommentMode = 1
If InStr(L$, MultiLineCommentOn$) = I Then Colorize_CommentMode = 2
If InStr(L$, MultiLineCommentOff$) = I And Colorize_CommentMode = 2 Then Colorize_CommentMode = 0
If Colorize_CommentMode > 0 Then
ColorList$ = ColorListAdd$(ColorList$, _RGB32(127))
Else
Select Case C~%%
Case 9, 32: ColorList$ = ColorListAdd$(ColorList$, _RGB32(0))
Case 34: Colorize_StringMode = 1: ColorList$ = ColorListAdd$(ColorList$, _RGB32(255, 127, 0))
Case 39: Colorize_StringMode = 2: ColorList$ = ColorListAdd$(ColorList$, _RGB32(255, 127, 0))
Case 33, 35 To 38, 40 To 47, 58 To 64, 91 To 96, 123 To 126: ColorList$ = ColorListAdd$(ColorList$, _RGB32(0, 127, 255))
Case 48 To 57: ColorList$ = ColorListAdd$(ColorList$, _RGB32(95, 191, 0))
Case 65 To 90, 97 To 122: ColorList$ = ColorListAdd$(ColorList$, _RGB32(255))
Case Else: ColorList$ = ColorListAdd$(ColorList$, _RGB32(255, 0, 0))
End Select: End If: End If: Next I
Colorize$ = ColorList$: End Function
Function ColorListNew$
ColorListNew$ = MKL$(0)
End Function
Function ColorListLength~& (__ColorList As String)
If Len(__ColorList) < 4 Then ColorListLength~& = 0 Else ColorListLength~& = CVL(Mid$(__ColorList, 1, 4))
End Function
Function ColorListAdd$ (__ColorList As String, __Color As Long)
If Len(__ColorList) < 4 Then __ColorList = MKL$(0)
ColorListAdd$ = MKL$(CVL(Mid$(__ColorList, 1, 4)) + 1) + Mid$(__ColorList, 5) + MKL$(__Color)
End Function
Function ColorListGet& (__ColorList As String, __ItemNumber As _Unsigned Long)
If Len(__ColorList) < 4 Then Exit Function
Dim As _Unsigned Long __nItems, __I, __OFFSET
__nItems = CVL(Mid$(__ColorList, 1, 4))
If __ItemNumber > __nItems Then Exit Function
__OFFSET = 5
For __I = 1 To __nItems
If __I = __ItemNumber Then ColorListGet& = CVL(Mid$(__ColorList, __OFFSET, 4)): Exit Function
__OFFSET = __OFFSET + 4
Next __I
End Function
Function ColorListDelete$ (__ColorList As String, __ItemNumber As _Unsigned Long)
If ColorListLength~&(__ColorList) < __ItemNumber Then Exit Function
If __ItemNumber = 0 Then Exit Function
Dim As _Unsigned Long __nItems, __I, __OFFSET
__nItems = CVL(Mid$(__ColorList, 1, 4))
__OFFSET = 5
For __I = 1 To __nItems
If __I = __ItemNumber Then
ColorListDelete$ = MKL$(__nItems - 1) + Mid$(__ColorList, 5, __OFFSET - 5) + Mid$(__ColorList, __OFFSET + 4)
Exit Function
End If
__OFFSET = __OFFSET + 4
Next __I
End Function
Fixed a bug: VS Code Scroll Bar was empty for small files
Code: (Select All)
'$Dynamic
$Resize:On
Do While _Resize: Loop
Screen _NewImage(960, 540, 32)
Color -1, 0
Type Vec2
As _Unsigned Integer X, Y
End Type
Dim As Vec2 Cursors(1 To 1)
Cursors(1).X = 1
Cursors(1).Y = 1
Cursor_Character$ = Chr$(95)
Dim Shared Lines$(1 To 1)
Dim Shared FormattedLines$(1 To 1), Colorize_StringMode As _Byte, Colorize_CommentMode As _Byte
Dim Shared Comment$, MultiLineCommentOn$, MultiLineCommentOff$
Dim Shared As Long VerticalScrollOffset, HorizontalScrollOffset, TextFrameOffset, VerticalLines, TotalLines
Dim Shared As _Bit COLOR_MODE: COLOR_MODE = -1
Comment$ = "//"
MultiLineCommentOn$ = "/*"
MultiLineCommentOff$ = "*/"
VerticalScrollOffset = 1
HorizontalScrollOffset = 1
Const LineNumbersWidth = 6
$If WIN Then
FILESEP$ = "\"
$Else
FILESEP$ = "/"
$End If
If _FileExists(Command$(1)) Then
FilePath$ = Command$(1)
ElseIf _FileExists(_StartDir$ + FILESEP$ + Command$(1)) Then
FilePath$ = _StartDir$ + FILESEP$ + Command$(1)
End If
If FilePath$ = "" Then FilePath$ = "Untitled.txt"
If _FileExists(FilePath$) Then GoSub OpenFile
If _InStrRev(FilePath$, FILESEP$) Then FileName$ = Mid$(FilePath$, _InStrRev(FilePath$, FILESEP$) + 1) Else FileName$ = FilePath$
TITLE$ = FileName$ + " - TEdi"
DirPath$ = _StartDir$ 'Left$(FilePath$, _InStrRev(FilePath$, FileName$) - 1)
If Len(DirPath$) Then If _DirExists(DirPath$) Then ChDir DirPath$
DISPLAY = -1
Do
_Limit 30
If _Resize Then
Screen _NewImage(_ResizeWidth, _ResizeHeight, 32)
Color _RGB32(255), _RGB32(16)
End If
If _WindowHasFocus = 0 Then GoTo SKIPDISPLAY
Cls , _RGB32(16)
If DISPLAY Then
VerticalScrollOffset = Max(Min(VerticalScrollOffset, TotalLines), 1)
'Print Text
J = 0: For I = VerticalScrollOffset To VerticalScrollOffset + VerticalLines: If TotalLines < I Then Exit For
Color _RGB32(255), _RGB32(32): _PrintString (TextFrameOffset, J * _FontHeight), " " + _Trim$(Str$(I)) + Space$(LineNumbersWidth - Len(_Trim$(Str$(I))))
If Len(FormattedLines$(I)) Then
If COLOR_MODE Then
For K = HorizontalScrollOffset To HorizontalScrollOffset + HorizontalCharsVisible - 1
If K > Len(Lines$(I)) Then Exit For
C& = ColorListGet&(FormattedLines$(I), K)
If C& = 0 Then C& = _RGB32(255, 0, 0)
Color C&, 0
_PrintString (TextFrameOffset + (LineNumbersWidth + K - HorizontalScrollOffset + 1) * _FontWidth, J * _FontHeight), Mid$(Lines$(I), K, 1)
Next K
Else Color _RGB32(255), 0: _PrintString (TextFrameOffset + (LineNumbersWidth - HorizontalScrollOffset + 2) * _FontWidth, J * _FontHeight), Mid$(Lines$(I), HorizontalScrollOffset, HorizontalCharsVisible)
End If
Else Color _RGB32(255), 0: _PrintString (TextFrameOffset + (LineNumbersWidth + 1) * _FontWidth, J * _FontHeight), Mid$(Lines$(I), HorizontalScrollOffset, HorizontalCharsVisible)
End If
J = J + 1: Next I
Line (TextFrameOffset, 0)-(TextFrameOffset, _Height - 1), _RGB32(255)
'----------
'Show Scroll Bar
Line (_Width - 16, 0)-(_Width, _Height), _RGB32(15), BF
Line (_Width - 16, ScrollBO)-(_Width, ScrollBO + ScrollBP), _RGB32(127), BF
'---------------
'Color Scroll Bar
Line (_Width - 146, 0)-(_Width - 16, _Height), _RGB32(31), BF
S = Min(Max(1, VerticalScrollOffset - _Height / 2), TotalLines - _Height / 2)
Line (_Width - 146, VerticalScrollOffset - S)-(_Width - 16, VerticalScrollOffset - S + VerticalLines), _RGB32(255, 31), BF
For I = S To Max(1, Min(S + _Height, TotalLines))
If I < LBound(Lines$) Or I > TotalLines Then _Continue
For J = 1 To 128
If J > Len(Lines$(I)) Then Exit For
If Asc(Lines$(I), J) = 32 Then _Continue
C& = ColorListGet&(FormattedLines$(I), J)
If C& = 0 Then C& = _RGB32(255, 0, 0)
PSet (_Width - 146 + J, I - S), C&
Next J
For CursorID = LBound(Cursors) To UBound(Cursors)
If Cursors(CursorID).Y = I Then Line (_Width - 146, I - S)-(_Width - 16, I - S), _RGB32(255, 0, 0, 191)
Next CursorID
Next I
'----------------
_Display
End If
SKIPDISPLAY:
TotalLines = UBound(Lines$)
If FileSaved = 0 Then ColorizeLines = -1
If ColorizeLines And TotalLines > 1 Then
For I = 1 To 64
ColorizeLines_LineOffset = ColorizeLines_LineOffset + 1
FormattedLines$(ColorizeLines_LineOffset) = Colorize$(Lines$(ColorizeLines_LineOffset))
If ColorizeLines_LineOffset = TotalLines Then ColorizeLines = 0: ColorizeLines_LineOffset = 0: Colorize_StringMode = 0: Exit For
Next I
Else
Colorize_StringMode = 0
Colorize_CommentMode = 0
End If
'AutoSave after 0.5 Second of Sleep
If Timer(0.1) - KeyPressTimer >= 0.5 And FileSaved = 0 Then
GoSub SaveFile
FileSaved = -1
End If
'------------------------
On _Exit GOTO SaveExit
If FileSaved <> OldFileSaved Then
OldFileSaved = FileSaved
If FileSaved Then _Title TITLE$ Else _Title TITLE$ + "*"
End If
Loop
System
SaveExit:
GoSub SaveFile
System
ClearFile:
ReDim Lines$(0 To 0)
Return
OpenFile:
Cls , _RGB32(32)
_PrintString (_Width / 2 - 6 * _FontHeight, _Height / 2 - _FontHeight / 2), "Reading File"
_Display
If _FileExists(FilePath$) = 0 Then Return
ReDim Lines$(0)
Open FilePath$ For Input As #1
If LOF(1) Then
Do
Line Input #1, L$
If UBound(Lines$) = 0 Then
ReDim Lines$(1 To 1)
Else
ReDim _Preserve Lines$(1 To UBound(Lines$) + 1)
End If
Lines$(UBound(Lines$)) = L$
If EOF(1) Then Exit Do
Loop
Else
ReDim Lines$(1 To 1)
End If
Close #1
ReDim FormattedLines$(1 To UBound(Lines$))
ColorizeLines = -1
Return
SaveFile:
If FilePath$ = "" Then Return
Open FilePath$ For Output As #1
For I = 1 To TotalLines
If I = TotalLines Then Print #1, Lines$(I); Else Print #1, Lines$(I)
Next I
Close #1
Return
Sub AddLine
ReDim _Preserve Lines$(1 To UBound(Lines$) + 1)
ReDim _Preserve FormattedLines$(1 To UBound(Lines$))
End Sub
Sub InsertLine (__LN)
AddLine
For I = UBound(Lines$) - 1 To __LN Step -1
Lines$(I + 1) = Lines$(I)
FormattedLines$(I + 1) = FormattedLines$(I)
Next I
End Sub
Sub RemoveLine (__LN)
For I = __LN To UBound(Lines$) - 1
Lines$(I) = Lines$(I + 1)
FormattedLines$(I) = FormattedLines$(I + 1)
Next I
DeleteLine
End Sub
Sub DeleteLine
ReDim _Preserve Lines$(1 To UBound(Lines$) - 1)
ReDim _Preserve FormattedLines$(1 To UBound(Lines$))
End Sub
Sub IncrementINT (A As Integer)
A = A + 1
End Sub
Sub DecrementINT (A As Integer)
A = A - 1
End Sub
Sub IncrementULNG (A As _Unsigned Long)
A = A + 1
End Sub
Sub DecrementULNG (A As _Unsigned Long)
A = A - 1
End Sub
Function Max (A, B)
If A > B Then Max = A Else Max = B
End Function
Function Min (A, B)
If A < B Then Min = A Else Min = B
End Function
Function InRange (A, B, C)
If A < B And B < C Then InRange = -1
End Function
Function Colorize$ (L$)
If Colorize_CommentMode = 1 Then Colorize_CommentMode = 0
ColorList$ = ColorListNew$
For I = 1 To Len(L$)
C~%% = Asc(L$, I)
If Colorize_StringMode Then
ColorList$ = ColorListAdd$(ColorList$, _RGB32(255, 167, 0))
If C~%% = 34 And Colorize_StringMode = 1 Then Colorize_StringMode = 0
If C~%% = 39 And Colorize_StringMode = 2 Then Colorize_StringMode = 0
Else
If InStr(L$, Comment$) = I Then Colorize_CommentMode = 1
If InStr(L$, MultiLineCommentOn$) = I Then Colorize_CommentMode = 2
If InStr(L$, MultiLineCommentOff$) = I And Colorize_CommentMode = 2 Then Colorize_CommentMode = 0
If Colorize_CommentMode > 0 Then
ColorList$ = ColorListAdd$(ColorList$, _RGB32(127))
Else
Select Case C~%%
Case 9, 32: ColorList$ = ColorListAdd$(ColorList$, _RGB32(0))
Case 34: Colorize_StringMode = 1: ColorList$ = ColorListAdd$(ColorList$, _RGB32(255, 127, 0))
Case 39: Colorize_StringMode = 2: ColorList$ = ColorListAdd$(ColorList$, _RGB32(255, 127, 0))
Case 33, 35 To 38, 40 To 47, 58 To 64, 91 To 96, 123 To 126: ColorList$ = ColorListAdd$(ColorList$, _RGB32(0, 127, 255))
Case 48 To 57: ColorList$ = ColorListAdd$(ColorList$, _RGB32(95, 191, 0))
Case 65 To 90, 97 To 122: ColorList$ = ColorListAdd$(ColorList$, _RGB32(255))
Case Else: ColorList$ = ColorListAdd$(ColorList$, _RGB32(255, 0, 0))
End Select: End If: End If: Next I
Colorize$ = ColorList$: End Function
Function ColorListNew$
ColorListNew$ = MKL$(0)
End Function
Function ColorListLength~& (__ColorList As String)
If Len(__ColorList) < 4 Then ColorListLength~& = 0 Else ColorListLength~& = CVL(Mid$(__ColorList, 1, 4))
End Function
Function ColorListAdd$ (__ColorList As String, __Color As Long)
If Len(__ColorList) < 4 Then __ColorList = MKL$(0)
ColorListAdd$ = MKL$(CVL(Mid$(__ColorList, 1, 4)) + 1) + Mid$(__ColorList, 5) + MKL$(__Color)
End Function
Function ColorListGet& (__ColorList As String, __ItemNumber As _Unsigned Long)
If Len(__ColorList) < 4 Then Exit Function
Dim As _Unsigned Long __nItems, __I, __OFFSET
__nItems = CVL(Mid$(__ColorList, 1, 4))
If __ItemNumber > __nItems Then Exit Function
__OFFSET = 5
For __I = 1 To __nItems
If __I = __ItemNumber Then ColorListGet& = CVL(Mid$(__ColorList, __OFFSET, 4)): Exit Function
__OFFSET = __OFFSET + 4
Next __I
End Function
Function ColorListDelete$ (__ColorList As String, __ItemNumber As _Unsigned Long)
If ColorListLength~&(__ColorList) < __ItemNumber Then Exit Function
If __ItemNumber = 0 Then Exit Function
Dim As _Unsigned Long __nItems, __I, __OFFSET
__nItems = CVL(Mid$(__ColorList, 1, 4))
__OFFSET = 5
For __I = 1 To __nItems
If __I = __ItemNumber Then
ColorListDelete$ = MKL$(__nItems - 1) + Mid$(__ColorList, 5, __OFFSET - 5) + Mid$(__ColorList, __OFFSET + 4)
Exit Function
End If
__OFFSET = __OFFSET + 4
Next __I
End Function
