07-28-2024, 11:50 PM
(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.
Code: (Select All)Option _Explicit
_Title "Edit VLSA" ' bplus start 2023-11-12 Edit - Variable Length String Arrays
' 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$
'box min width 35 - 19 + 1 = 17 *11 = 187 ' 17 chars wide
'box min height topchoice * 20 = 160
choice$(1) = "New File ctrl+N": choice$(9) = "Find... ctrl+F3"
choice$(2) = "Open File ctrl+O": choice$(10) = "Find Next F3"
choice$(3) = "Save ctrl+S": choice$(11) = "Find < shift+F3"
choice$(4) = "Save As ctrl+A": choice$(12) = "Change... Alt+F3"
choice$(5) = "Cut ctrl+X": choice$(13) = "Change All F4"
choice$(6) = "Copy ctrl+C": choice$(14) = "Color Theme... "
choice$(7) = "Paste ctrl+V": choice$(15) = "Quit Editor esc"
choice$(8) = "Exit Menu"
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/
Please visit my Website at: http://oldendayskids.blogspot.com/