OK I made a wrong turn when mouse over was all that was needed to change the Active Control. Nope you have to left or right click the control to make it active.
I also started printing out the List Box like I did with Text Box so that all the letters will align and wont be thrown off by more or less spaces.
Here is GUI Adding Machine. With the redeveloped BM still embedded in file, the vs GUI.BI, direntry.h file and arial.ttf you can get from 1st Post if you don't have it already.
Oh BTW, the o with 2 dots over it prints 2 zeros also notice NO DECIMAL POINT in keys, it is inserted when the number is printed. That is what the o with 3 dots is for, converting pennies to dollars. PS I eliminated 5 Keys from when I started that's why all the space under them.
I also started printing out the List Box like I did with Text Box so that all the letters will align and wont be thrown off by more or less spaces.
Here is GUI Adding Machine. With the redeveloped BM still embedded in file, the vs GUI.BI, direntry.h file and arial.ttf you can get from 1st Post if you don't have it already.
Code: (Select All)
'$include:'vs GUI.BI'
Option _Explicit
' Set Globals from BI
Xmax = 920: Ymax = 700: GuiTitle$ = "GUI Adding Machine"
OpenWindow Xmax, Ymax, GuiTitle$, "arial.ttf" ' need to do this before drawing anything from NewControls
Randomize Timer
Dim Shared As Long Btn(1 To 20), tbN, tbT, LB ' our 15 buttons now!
Dim Shared As _Integer64 Num, Total
Dim Shared B$, Tape$
init
MainRouter ' just wait for player to fire
Sub BtnClickEvent (i As Long)
Dim s$
_Delay .2 ' because the delay isn't done until after this is processed! need to fix that in MainRouter
'7890C
'456o<
'123+-
'Key# 12345678 9 00 10 <- 12345
'bt$ = "7890C456" + Chr$(148) + Chr$(27) + "123+-"
Select Case i
Case 1, 2, 3, 4, 6, 7, 8, 11, 12, 13 ' 7890 567 123
B$ = B$ + con(i).Text: Num = Val(B$): con(tbN).Text = Dot2_17$(Num): drwTB tbN, 0
Case 5 ' C
B$ = "": Num = 0: con(tbN).Text = Dot2_17$(Num): drwTB tbN, 0
Total = 0: con(tbT).Text = Dot2_17$(Total): drwTB tbT, 0
Tape$ = Tape$ + "~" + " "
GoSub updateLB
Case 9 ' chr$(148) for 00
B$ = B$ + "00": Num = Val(B$): con(tbN).Text = Dot2_17$(Num): drwTB tbN, 0
Case 10 ' backspace <-
If Len(B$) Then
B$ = Left$(B$, Len(B$) - 1): Num = Val(B$): con(tbN).Text = Dot2_17$(Num)
drwTB tbN, 0
End If
Case 14 ' +
If B$ <> "" Then Num = Val(B$) ' Else Num = num
Total = Total + Num
con(tbT).Text = Dot2_17$(Total): drwTB tbT, 0
B$ = "" ' my calc does not change the screen
Tape$ = Tape$ + "~" + "+ " + Dot2_17$(Num)
GoSub updateLB
Case 15 ' -
If B$ <> "" Then Num = Val(B$) ' Else Num = num
Total = Total - Num
con(tbT).Text = Dot2_17$(Total): drwTB tbT, 0
B$ = "" ' my calc does not change the screen
Tape$ = Tape$ + "~" + "- " + Dot2_17$(Num)
GoSub updateLB
End Select
Exit Sub
updateLB:
Tape$ = Tape$ + "~" + "T " + Dot2_17$(Total)
con(LB).Text = Tape$ ' sets the delimited string into lst's text for splitting
drwLst LB, 0 ' this updates list box with new line(s) splitting out the tape$
LstKeyEvent LB, 20224 ' this moves highlite to end and of the tape$
Return
End Sub
Sub LstSelectEvent (control As Long)
Select Case control
End Select
End Sub
Sub PicClickEvent (i As Long, Pmx As Long, Pmy As Long)
Select Case i
End Select
End Sub
Sub PicFrameUpdate (i As Long)
Select Case i
End Select
End Sub
' For Adding Machine
Sub init
Dim bt$
Dim As Long x, y, i
'7890C
'456o<
'123+-
'Key# 12345678 9 00 10 <- 12345
bt$ = "7890C456" + Chr$(148) + Chr$(27) + "123+-"
i = 1
For y = 0 To 2
For x = 0 To 4
Btn(i) = NewControl(1, x * 120 + 20, y * 120 + 220, 100, 100, 64, 99, 33, Mid$(bt$, i, 1))
i = i + 1
Next
Next
tbN = NewControl(2, 20, 20, 580, 80, 54, 0, 666, "")
tbT = NewControl(2, 20, 110, 580, 80, 54, 0, 666, Dot2_17$(0))
LB = NewControl(3, 620, 20, 280, 660, 20, 0, 888, "")
Tape$ = "T " + Dot2_17$(0)
con(LB).Text = Tape$
drwLst LB, 0
End Sub
' this formats a _integer64 type number into a right aligned 17 places and places dot 2 places in
' so fits up to 9,999,999,999.99 dollars or some other unit
Function Dot2_17$ (cents As _Integer64) ' modified for right aligned in 14 spaces
Dim s$, rtn$, sign$
s$ = _Trim$(Str$(cents)) ' TS$ is for long
If Left$(s$, 1) = "-" Then sign$ = "-": s$ = Mid$(s$, 2) Else sign$ = ""
If Len(s$) = 1 Then
s$ = sign$ + "0.0" + s$
ElseIf Len(s$) = 2 Then
s$ = sign$ + "0." + s$
Else
s$ = sign$ + Mid$(s$, 1, Len(s$) - 2) + "." + Mid$(s$, Len(s$) - 1)
End If
rtn$ = Space$(17)
s$ = _Trim$(s$)
Mid$(rtn$, 17 - Len(s$)) = s$
Dot2_17$ = rtn$
End Function
'''$include:'vs GUI.BM'
'=============================================================================================
' GUI.BM 2022-07-20 add Function LstHighliteItem$
' Change MainRouter clicking outside a control was changing the active control, no more!
' If Mouse Over a Control, that controls becomes active, don't try and Tab off a control that a
' mouse is over, mouse wins!
' 2022-07-25
' Do display after all drwX's
' Font Heights for Text Boxes, Btns, Pic Box (but that is stupid no room for pic) now only have to
' be 2 pixels less than Control Height.
' Removed N6, Text2, Fhdl, FontFile, ImgFile from the Control Type for vs GUI.
' Aha! to do an image file instead of Text use ">Filename.ext" for the text.
' 2022-07-26
' Another fix in MainRouter, Exit For when found the control mouse is inside. Needed this when a
' Click switched screens and threw errors because it was a whole different set of controls!
' GUI.BM 2022-07-28 More updates
' 1. Wrong turn was made activating controls with just MouseOver, wait for click into the control.
' Then use the clear button immediately because Main Router shoots all over updating controls.
' 2. Clear MouseButton as soon as we know it was released by user, use OldMoses method
' didn't work back to _delay 2 but immediately after click is detected.
' 3. I want aligned columns of text in list box, this means to print text like I do in Text Box.
' 4. Coming soon Speaking of Aligning, I want Labels aligned, N1 is for images, so N2 is next up.
' N1 for image handles, N2 Alinment = 0 for centered, = 1 Left Aligned, = 2 Right Aligned
' Reworking vs GUI.BM from new GUI Adding Machine app, then check it out with all the others.
Function LstHighliteItem$ (controlI As Long) ' 2022-07-20 adding this to BM
ReDim lst(1 To 1) As String 'need to find highlighted item
Split con(controlI).Text, "~", lst()
LstHighliteItem$ = lst((con(controlI).N1 - 1) * con(controlI).N4 + con(controlI).N2)
End Function
Function NewControl& (ConType As Long, X As Long, Y As Long, W As Long, H As Long,_
FontH As Long, FC As Long, BC As Long, s$) ' dims are pixels
Dim As Long a
NControls = NControls + 1
ReDim _Preserve con(0 To NControls) As Control
con(NControls).ConType = ConType
con(NControls).X = X
con(NControls).Y = Y
con(NControls).W = W
con(NControls).H = H
con(NControls).Text = s$
ActiveControl = 1
If NControls = 1 Then a = 1 Else a = 0
Select Case ConType
Case 1
con(NControls).N1 = 0
If Left$(s$, 1) = "<" Then
If _FileExists(Mid$(s$, 2)) Then con(NControls).N1 = _LoadImage(Mid$(s$, 2))
End If
If FontH < H - 1 Then con(NControls).FontH = FontH Else con(NControls).FontH = H - 2
If FC = 0 And BC = 0 Then ' use default colors
con(NControls).FC = C3(800): con(NControls).BC = C3(888)
Else ' convert to RGB
con(NControls).FC = C3(FC): con(NControls).BC = C3(BC)
End If
drwBtn NControls, a
Case 2
If FontH < H - 1 Then con(NControls).FontH = FontH Else con(NControls).FontH = H - 2
If FC = 0 And BC = 0 Then ' use default colors
con(NControls).FC = C3(778): con(NControls).BC = C3(225)
Else ' convert to RGB
con(NControls).FC = C3(FC): con(NControls).BC = C3(BC)
End If
con(NControls).N1 = 1 ' page/section
con(NControls).N2 = 1 ' highlite
con(NControls).N3 = Int(con(NControls).FontH * .65) ' width of character
con(NControls).N4 = Int((con(NControls).W - 4) / con(NControls).N3) ' width of section
con(NControls).N5 = Len(con(NControls).Text) + 1
drwTB NControls, a
Case 3
If FC = 0 And BC = 0 Then ' use default colors
con(NControls).FC = C3(889): con(NControls).BC = C3(336)
Else ' convert to RGB
con(NControls).FC = C3(FC): con(NControls).BC = C3(BC)
End If
If 3 * FontH > H Then con(NControls).FontH = Int(H / 3) Else con(NControls).FontH = FontH
con(NControls).N1 = 1 ' page number
con(NControls).N2 = 1 ' select highlite bar
con(NControls).N3 = W / Int(con(NControls).FontH * .65)
con(NControls).N4 = Int((H - 2 * con(NControls).FontH) / con(NControls).FontH)
' page height 2 empty lines for home, end, page up, page down clicking
' n5 changes according to lines delimiters in text
drwLst NControls, a
Case 4
con(NControls).N1 = 0
If Left$(s$, 1) = "<" Then
If _FileExists(Mid$(s$, 2)) Then con(NControls).N1 = _LoadImage(Mid$(s$, 2))
End If
If FontH <= H Then con(NControls).FontH = FontH Else con(NControls).FontH = H
If FC = 0 And BC = 0 Then ' use default colors
con(NControls).FC = C3(889): con(NControls).BC = screenBC
Else ' convert to RGB
con(NControls).FC = C3(FC): con(NControls).BC = C3(BC)
End If
drwLbl NControls
Case 5
If FontH < H - 1 Then con(NControls).FontH = FontH Else con(NControls).FontH = H - 2
If s$ <> "" Then ' label color is
If FC = 0 And BC = 0 Then ' use default colors
con(NControls).FC = C3(590): con(NControls).BC = C3(40)
Else ' convert to RGB
con(NControls).FC = C3(FC): con(NControls).BC = C3(BC)
End If
End If
con(NControls).N1 = _NewImage(con(NControls).W, con(NControls).H, 32)
_Dest con(NControls).N1
Line (0, 0)-Step(con(NControls).W - 1, con(NControls).H - 1), Black, BF
_Dest 0
drwPic NControls, a
End Select
NewControl& = NControls ' same as ID
End Function
Sub MainRouter
Dim As Long kh, mx, my, mb1, mb2, i, shift, temp
Do
' mouse clicks and tabs will decide the active control
While _MouseInput ' scroll lst if active while polling mouse
If con(ActiveControl).ConType = 3 Then
If _MouseWheel > 0 Then
LstKeyEvent ActiveControl, 20480
ElseIf _MouseWheel < 0 Then
LstKeyEvent ActiveControl, 18432
End If
End If
Wend
mx = _MouseX: my = _MouseY: mb1 = _MouseButton(1): mb2 = _MouseButton(2)
For i = 1 To NControls
If mx >= con(i).X And mx <= con(i).X + con(i).W Then
If my >= con(i).Y And my <= con(i).Y + con(i).H Then ' we are inside a control
' do we have a mouse click inside a control?
If mb1 Then ' click, find which type control we are in and exit for
_Delay .2
If i <> ActiveControl And con(i).ConType <> 4 Then ' active control is changed
activateControl ActiveControl, 0
ActiveControl = i
activateControl ActiveControl, -1
End If
If con(i).ConType = 1 Then
BtnClickEvent i
ElseIf con(i).ConType = 2 Then ' move cursor to click point
If mx > con(i).X + 4 And mx < con(i).X + con(i).W Then
If my >= con(i).Y And my <= con(i).Y + con(i).H Then
con(i).N2 = Int((mx - (con(i).X + 4)) / con(i).N3) + 1
If (con(i).N1 - 1) * con(i).N4 + con(i).N2 > con(i).N5 Then
If con(i).N5 Mod con(i).N4 = 0 Then
'last page exactly at end of it
con(i).N1 = Int(con(i).N5 / con(i).N4)
con(i).N2 = con(i).N4
Else
' last page with only some lines
con(i).N1 = Int(con(i).N5 / con(i).N4) + 1
con(i).N2 = con(i).N5 Mod con(i).N4
End If
End If
drwTB i, -1
End If
End If
ElseIf con(i).ConType = 3 Then
If my >= con(i).Y And my <= con(i).Y + con(i).FontH Then ' top empty
If mx < con(i).X + .5 * con(i).W Then 'home else pgUp
LstKeyEvent i, 18176 ' home
ElseIf mx > con(i).X + .5 * con(i).W Then
LstKeyEvent i, 18688 ' pgup
End If
ElseIf my >= con(i).Y + con(i).H - con(i).FontH Then
If my <= con(i).Y + con(i).H Then
If mx < con(i).X + .5 * con(i).W Then 'end else pgDn
LstKeyEvent i, 20224 ' end
ElseIf mx > con(i).X + .5 * con(i).W Then
LstKeyEvent i, 20736 ' pgdn
End If
End If
ElseIf my >= con(i).Y + con(i).FontH Then
If my < con(i).Y + con(i).H - con(i).FontH Then
temp = Int((my - con(i).Y - con(i).FontH) / con(i).FontH)
con(i).N2 = temp + 1
If (con(i).N1 - 1) * con(i).N4 + con(i).N2 > con(i).N5 Then
LstKeyEvent i, 20224 ' end
End If
drwLst i, -1
End If
End If
ElseIf con(i).ConType = 5 Then
PicClickEvent i, mx - con(i).X, my - con(i).Y 'picture box click event
End If ' what kind of control
End If ' left click a control check
If mb2 Then ' check right clicking to select
_Delay .2
If i <> ActiveControl And con(i).ConType <> 4 Then ' active control is changed
activateControl ActiveControl, 0
ActiveControl = i
activateControl ActiveControl, -1
End If
If con(i).ConType = 3 Then ' only selecting in lst box
LstSelectEvent i ' check event called for 5
End If ' control type 3
End If ' mb2
Exit For ' should only be inside one control
End If ' y is inside control
End If 'x inside control
Next
kh = _KeyHit ' now for key presses
shift = _KeyDown(100304) Or _KeyDown(100303)
If kh = 9 Then 'tab
If shift Then shiftActiveControl -1 Else shiftActiveControl 1
ElseIf kh = 13 And con(ActiveControl).ConType = 1 Then ' enter on a btn
BtnClickEvent ActiveControl
shiftActiveControl 1
ElseIf kh = 13 And con(ActiveControl).ConType = 2 Then
shiftActiveControl 1
ElseIf kh = 13 And con(ActiveControl).ConType = 3 Then
LstSelectEvent ActiveControl
shiftActiveControl 1
End If
If con(ActiveControl).ConType = 2 Then
TBKeyEvent ActiveControl, kh, shift ' this handles keypress in active textbox
ElseIf con(ActiveControl).ConType = 3 Then
LstKeyEvent ActiveControl, kh
End If
For i = 1 To NControls ' update active picture boxes
If con(i).ConType = 5 Then PicFrameUpdate i
Next
_Display
_Limit 60
Loop
System
End Sub
Sub shiftActiveControl (change As Long) ' change = 1 or -1
activateControl ActiveControl, 0 ' turn off last
Do
ActiveControl = ActiveControl + change
If ActiveControl > NControls Then ActiveControl = 1
If ActiveControl < 1 Then ActiveControl = NControls
Loop Until con(ActiveControl).ConType <> 4
activateControl ActiveControl, -1 ' turn on next
End Sub
Sub activateControl (i, activate)
Select Case con(i).ConType
Case 1: drwBtn i, activate
Case 2: drwTB i, activate
Case 3: drwLst i, activate
Case 5: drwPic i, activate
End Select
End Sub
Sub OpenWindow (WinWidth As Long, WinHeight As Long, title$, fontFile$)
Screen _NewImage(WinWidth, WinHeight, 32)
_ScreenMove 80, 0
_PrintMode _KeepBackground
_Title title$
curPath$ = _CWD$ ' might need this for file stuff
Color White, screenBC
Cls
Dim As Long j
For j = 6 To 128
fontHandle&(j) = _LoadFont(fontFile$, j)
If fontHandle&(j) <= 0 Then
Cls
Print "Font did not load (OpenWindow sub) at height" + Str$(j) + ", goodbye!"
Sleep: End
End If
Next
End Sub
Sub drwBtn (i As Long, active As Long) ' gray back, black text
Dim As Long tempX, tempY
If con(i).N1 > -2 Then ' no image
Line (con(i).X, con(i).Y)-Step(con(i).W, con(i).H), con(i).BC, BF
_Font fontHandle&(con(i).FontH)
tempX = con(i).X + (con(i).W - _PrintWidth(con(i).Text)) / 2
tempY = con(i).Y + (con(i).H - con(i).FontH) / 2
If con(i).FontH >= 20 Then
Color Black
_PrintString (tempX - 1, tempY - 1), con(i).Text
End If
Color con(i).FC
_PrintString (tempX, tempY), con(i).Text
Else
_PutImage (con(i).X, con(i).Y)-Step(con(i).W, con(i).H), con(i).N1, 0
End If
If active Then
Line (con(i).X, con(i).Y)-Step(con(i).W, con(i).H), White, B
Else
Line (con(i).X, con(i).Y)-Step(con(i).W, 0), White
Line (con(i).X, con(i).Y)-Step(0, con(i).H), White
Line (con(i).X + con(i).W, con(i).Y)-Step(0, con(i).H), Black
Line (con(i).X, con(i).Y + con(i).H)-Step(con(i).W, 0), Black
End If
_Display
End Sub
Sub drwTB (i As Long, active As Long) ' blue back, white text
' just like LstBox
' N1 = section / page number we are on
' N2 = current location of the highlight bar on the page 1 to page/section width
' N3 = char width allowed for char fontH * .65
' N4 = page height or section width
' N5 = len(text) + 1 upperbound of letters
Dim As Long j, xoff, tempX
Dim t$
Line (con(i).X, con(i).Y)-Step(con(i).W, con(i).H), con(i).BC, BF
If active Then
Line (con(i).X, con(i).Y)-Step(con(i).W, con(i).H), White, B
Else
Line (con(i).X, con(i).Y)-Step(con(i).W, 0), Black
Line (con(i).X, con(i).Y)-Step(0, con(i).H), Black
Line (con(i).X + con(i).W, con(i).Y)-Step(0, con(i).H), White
Line (con(i).X, con(i).Y + con(i).H)-Step(con(i).W, 0), White
End If
con(i).N5 = Len(con(i).Text) + 1 ' allow for 1 more char insertion or insertion on end
_Font fontHandle&(con(i).FontH)
For j = 1 To con(i).N4
If (con(i).N1 - 1) * con(i).N4 + j <= con(i).N5 Then
t$ = Mid$(con(i).Text, (con(i).N1 - 1) * con(i).N4 + j, 1)
xoff = (con(i).N3 - _PrintWidth(t$)) / 2
tempX = con(i).X + 4 + (j - 1) * con(i).N3
If j <> con(i).N2 Or active = 0 Then
Color con(i).FC
Else ' cursor
Line (tempX + 1, con(i).Y)-Step(con(i).N3, con(i).H - 2), con(i).FC, BF
Color con(i).BC
End If
_PrintString (tempX + xoff, con(i).Y + (con(i).H - con(i).FontH) / 2), t$
End If
Next
_Display
End Sub
Sub drwLst (i As Long, active As Long)
' new control will get numbers for constructing a screen
' N1 = page number we are on
' N2 = current location of the highlight bar on the page
' N3 = page width in chars
' N4 = page height + 2 lines are left blank at top and bottom
' N5 = Ubound of the list() base 1 ie last item number
Dim As Long j, k, listPos, tempY, charW, xo
Dim char$
Line (con(i).X, con(i).Y)-Step(con(i).W, con(i).H), con(i).BC, BF
If active Then
Line (con(i).X, con(i).Y)-Step(con(i).W, con(i).H), White, B
Else
Line (con(i).X, con(i).Y)-Step(con(i).W, 0), Black
Line (con(i).X, con(i).Y)-Step(0, con(i).H), Black
Line (con(i).X + con(i).W, con(i).Y)-Step(0, con(i).H), White
Line (con(i).X, con(i).Y + con(i).H)-Step(con(i).W, 0), White
End If
ReDim lst(1 To 1) As String
Split con(i).Text, "~", lst()
con(i).N5 = UBound(lst)
_Font fontHandle&(con(i).FontH)
charW = .65 * con(i).FontH
For j = 1 To con(i).N4 ' - 1
listPos = (con(i).N1 - 1) * con(i).N4 + j
If listPos <= con(i).N5 Then
tempY = con(i).Y + con(i).FontH + (j - 1) * con(i).FontH
If j <> con(i).N2 Then
Color con(i).FC
Else
Line (con(i).X + 1, tempY)-Step(con(i).W - 2, con(i).FontH), con(i).FC, BF
Color con(i).BC
End If
For k = 1 To con(i).N3
char$ = Mid$(lst(listPos), k, 1)
xo = .5 * (charW - _PrintWidth(char$))
_PrintString (con(i).X + 4 + (k - 1) * charW + xo, tempY), char$
Next
End If
Next
_Display
End Sub
Sub drwLbl (i As Long)
Dim As Long tempX
If con(i).N1 > -2 Then ' no image
Line (con(i).X, con(i).Y)-Step(con(i).W, con(i).H), con(i).BC, BF
_Font fontHandle&(con(i).FontH)
tempX = con(i).X + (con(i).W - _PrintWidth(con(i).Text)) / 2
If con(i).FontH >= 20 Then
Color Black
_PrintString (tempX + 1, con(i).Y + (con(i).H - con(i).FontH) / 2 + 1), con(i).Text
End If
Color con(i).FC
_PrintString (tempX, con(i).Y + (con(i).H - con(i).FontH) / 2), con(i).Text
Else
_PutImage (con(i).X, con(i).Y)-Step(con(i).W, con(i).H), con(i).N1, 0
End If
_Display
End Sub
Sub drwPic (i As Long, active As Long)
Dim As Long tempY
If con(i).Text <> "" Then ' title to display
Dim sd&
sd& = _Dest
_Dest con(i).N1
Line (0, con(i).H - con(i).FontH - 2)-Step(con(i).W - 1, con(i).FontH + 2), con(i).BC, BF
_Font fontHandle&(con(i).FontH)
Color con(i).FC, con(i).BC
tempY = con(i).H - con(i).FontH - 1
_PrintString ((con(i).W - _PrintWidth(con(i).Text)) / 2, tempY), con(i).Text
_Dest 0
_PutImage (con(i).X, con(i).Y)-Step(con(i).W, con(i).H), con(i).N1, 0
_Dest sd&
End If
If active Then
Line (con(i).X, con(i).Y)-Step(con(i).W, con(i).H), White, B
Else
Line (con(i).X, con(i).Y)-Step(con(i).W, con(i).H), Black, B
End If
_Display
End Sub
' this is standard for all Text Boxes
Sub TBKeyEvent (i As Long, ky As Long, shift As Long) ' for all text boxes
Dim As Long L
' just like LstBox
' N1 = section / page number we are on
' N2 = current location of the highlight bar on the page 1 to page/section width
' N3 = char width allowed for char fontH * .65
' N4 = page height or section width
' N5 = len(text) + 1 upperbound of letters
L = (con(i).N1 - 1) * con(i).N4 + con(i).N2 ' help shorten really long lines
If ky = 19200 Then 'left arrow
If con(i).N2 > 1 Then
con(i).N2 = con(i).N2 - 1: drwTB i, -1
Else
If con(i).N1 > 1 Then con(i).N1 = con(i).N1 - 1: con(i).N2 = con(i).N4: drwTB i, -1
End If
ElseIf ky = 19712 Then ' right arrow
If con(i).N2 < con(i).N4 And (con(i).N1 - 1) * con(i).N4 + con(i).N2 < con(i).N5 Then
con(i).N2 = con(i).N2 + 1: drwTB i, -1
Else
If con(i).N2 = con(i).N4 Then ' can we move to another page
If con(i).N1 < con(i).N5 / con(i).N4 Then
con(i).N1 = con(i).N1 + 1: con(i).N2 = 1: drwTB i, -1
End If
End If
End If
ElseIf ky = 18176 Then ' home
con(i).N1 = 1: con(i).N2 = 1: drwTB i, -1
ElseIf ky = 20224 Then ' end
If con(i).N5 Mod con(i).N4 = 0 Then
con(i).N1 = Int(con(i).N5 / con(i).N4)
con(i).N2 = con(i).N4
Else
con(i).N1 = Int(con(i).N5 / con(i).N4) + 1
con(i).N2 = con(i).N5 Mod con(i).N4
End If
drwTB i, -1
ElseIf ky = 18688 Then ' PgUp
If con(i).N1 > 1 Then con(i).N1 = con(i).N1 - 1: drwTB i, -1
ElseIf ky = 20736 Then ' PgDn
If con(i).N1 < con(i).N5 / con(i).N4 Then
con(i).N1 = con(i).N1 + 1: con(i).N2 = 1: drwTB i, -1
End If
ElseIf ky >= 32 And ky <= 128 Then ' normal letter or digit or symbol
con(i).Text = Mid$(con(i).Text, 1, L - 1) + Chr$(ky) + Mid$(con(i).Text, L)
con(i).N5 = Len(con(i).Text) + 1
' now do right arrow code
If con(i).N2 < con(i).N4 And (con(i).N1 - 1) * con(i).N4 + con(i).N2 < con(i).N5 Then
con(i).N2 = con(i).N2 + 1: drwTB i, -1
Else
If con(i).N2 = con(i).N4 Then ' can we move to another page
If con(i).N1 < con(i).N5 / con(i).N4 Then
con(i).N1 = con(i).N1 + 1: con(i).N2 = 1: drwTB i, -1
End If
End If
End If
ElseIf ky = 8 Then 'backspace
If shift Then
con(i).Text = "": con(i).N2 = 1: con(i).N1 = 1: con(i).N5 = 1: drwTB i, -1
Else
If con(i).N2 > 1 Then
con(i).Text = Mid$(con(i).Text, 1, L - 2) + Mid$(con(i).Text, L)
con(i).N5 = Len(con(i).Text) + 1
con(i).N2 = con(i).N2 - 1: drwTB i, -1
ElseIf con(i).N1 <> 1 Then
con(i).Text = Mid$(con(i).Text, 1, L - 2) + Mid$(con(i).Text, L)
con(i).N5 = Len(con(i).Text) + 1
con(i).N1 = con(i).N1 - 1: con(i).N2 = con(i).N4: drwTB i, -1
End If
End If
ElseIf ky = 21248 Then 'delete shift is super delete
If shift Then
con(i).Text = "": con(i).N2 = 1: con(i).N1 = 1: con(i).N5 = 1: drwTB i, -1
Else
con(i).Text = Mid$(con(i).Text, 1, L - 1) + Mid$(con(i).Text, L + 1)
con(i).N5 = Len(con(i).Text) + 1: drwTB i, -1
End If
End If
End Sub
' this is standard for all List Boxes
Sub LstKeyEvent (i As Long, ky As Long) ' for all text boxes
If ky = 18432 Then 'up arrow
If con(i).N2 > 1 Then
con(i).N2 = con(i).N2 - 1: drwLst i, -1
Else
If con(i).N1 > 1 Then con(i).N1 = con(i).N1 - 1: con(i).N2 = con(i).N4: drwLst i, -1
End If
ElseIf ky = 20480 Then ' down arrow
If con(i).N2 < con(i).N4 And (con(i).N1 - 1) * con(i).N4 + con(i).N2 < con(i).N5 Then
con(i).N2 = con(i).N2 + 1: drwLst i, -1
Else
If con(i).N2 = con(i).N4 Then ' can we start another page
If con(i).N1 < con(i).N5 / con(i).N4 Then
con(i).N1 = con(i).N1 + 1: con(i).N2 = 1: drwLst i, -1
End If
End If
End If
ElseIf ky = 18176 Then 'home
con(i).N1 = 1: con(i).N2 = 1: drwLst i, -1
ElseIf ky = 20224 Then ' end
If con(i).N5 Mod con(i).N4 = 0 Then
con(i).N1 = Int(con(i).N5 / con(i).N4)
con(i).N2 = con(i).N4
Else
con(i).N1 = Int(con(i).N5 / con(i).N4) + 1
con(i).N2 = con(i).N5 Mod con(i).N4
End If
drwLst i, -1
ElseIf ky = 18688 Then 'pgUp
If con(i).N1 > 1 Then con(i).N1 = con(i).N1 - 1: drwLst i, -1
ElseIf ky = 20736 Then 'pgDn
If con(i).N1 * con(i).N4 < con(i).N5 Then
con(i).N1 = con(i).N1 + 1
If con(i).N1 > Int(con(i).N5 / con(i).N4) Then ' > last whole page check high bar
If con(i).N2 > con(i).N5 Mod con(i).N4 Then con(i).N2 = con(i).N5 Mod con(i).N4
End If
drwLst i, -1
End If
End If
End Sub
' This is used and available for maniupating strings to arrays ie change delimiters to commas
Sub Split (SplitMeString As String, delim As String, loadArray() As String)
Dim curpos As Long, arrpos As Long, LD As Long, dpos As Long 'fix use the Lbound the array already has
curpos = 1: arrpos = LBound(loadArray): LD = Len(delim)
dpos = InStr(curpos, SplitMeString, delim)
Do Until dpos = 0
loadArray(arrpos) = Mid$(SplitMeString, curpos, dpos - curpos)
arrpos = arrpos + 1
If arrpos > UBound(loadArray) Then
ReDim _Preserve loadArray(LBound(loadArray) To UBound(loadArray) + 1000) As String
End If
curpos = dpos + LD
dpos = InStr(curpos, SplitMeString, delim)
Loop
loadArray(arrpos) = Mid$(SplitMeString, curpos)
ReDim _Preserve loadArray(LBound(loadArray) To arrpos) As String 'get the ubound correct
End Sub
' Available if need to create a string from an array
Function Join$ (arr() As String, delimiter$) ' modified to avoid blank lines
Dim i As Long, b$
For i = LBound(arr) To UBound(arr)
If arr(i) <> "" Then
If b$ = "" Then b$ = arr(i) Else b$ = b$ + delimiter$ + arr(i)
End If
Next
Join$ = b$
End Function
Function LeftOf$ (source$, of$)
If InStr(source$, of$) > 0 Then
LeftOf$ = Mid$(source$, 1, InStr(source$, of$) - 1)
Else
LeftOf$ = source$
End If
End Function
' update these 2 in case of$ is not found! 2021-02-13
Function RightOf$ (source$, of$)
If InStr(source$, of$) > 0 Then
RightOf$ = Mid$(source$, InStr(source$, of$) + Len(of$))
Else
RightOf$ = ""
End If
End Function
Function TS$ (n As Long)
TS$ = _Trim$(Str$(n))
End Function
Sub Remove (item$, a$())
Dim As Long i, c, lba
lba = LBound(a$)
Dim t$(lba To UBound(a$))
c = lba - 1
For i = lba To UBound(a$)
If a$(i) <> "" And a$(i) <> item$ Then c = c + 1: t$(c) = a$(i)
Next
ReDim a$(lba To c)
For i = lba To c
a$(i) = t$(i)
Next
End Sub
Function C3~& (i As Long) ' from 0 to 999 3 digit pos integers
Dim s$
s$ = Right$(" " + Str$(i), 3)
C3~& = _RGB32(Val(Mid$(s$, 1, 1)) * 28, Val(Mid$(s$, 2, 1)) * 28, Val(Mid$(s$, 3, 1)) * 28)
End Function
Sub drawGridRect (x, y, w, h, xstep, ystep)
Dim i
For i = 0 To w Step xstep
Line (x + i, y + 0)-(x + i, y + y + h)
Next
For i = 0 To h Step ystep
Line (x + 0, y + i)-(x + w, y + i)
Next
End Sub
Sub fellipse (CX As Long, CY As Long, xr As Long, yr As Long, C As _Unsigned Long)
If xr = 0 Or yr = 0 Then Exit Sub
Dim h2 As _Integer64, w2 As _Integer64, h2w2 As _Integer64
Dim x As Long, y As Long
w2 = xr * xr: h2 = yr * yr: h2w2 = h2 * w2
Line (CX - xr, CY)-(CX + xr, CY), C, BF
Do While y < yr
y = y + 1
x = Sqr((h2w2 - y * y * w2) \ h2)
Line (CX - x, CY + y)-(CX + x, CY + y), C, BF
Line (CX - x, CY - y)-(CX + x, CY - y), C, BF
Loop
End Sub
Sub fcirc (x As Long, y As Long, R As Long, C As _Unsigned Long) 'vince version
Dim x0 As Long, y0 As Long, e As Long
x0 = R: y0 = 0: e = 0
Do While y0 < x0
If e <= 0 Then
y0 = y0 + 1
Line (x - x0, y + y0)-(x + x0, y + y0), C, BF
Line (x - x0, y - y0)-(x + x0, y - y0), C, BF
e = e + 2 * y0
Else
Line (x - y0, y - x0)-(x + y0, y - x0), C, BF
Line (x - y0, y + x0)-(x + y0, y + x0), C, BF
x0 = x0 - 1: e = e - 2 * x0
End If
Loop
Line (x - R, y)-(x + R, y), C, BF
End Sub
Sub ftri (x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
Dim D As Long
Static a&
D = _Dest ' so important
If a& = 0 Then a& = _NewImage(1, 1, 32)
_Dest a&
_DontBlend a& ' '<<<< new 2019-12-16 fix
PSet (0, 0), K
_Blend a& '<<<< new 2019-12-16 fix
_Dest D
_MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)
End Sub
Sub ScnState (restoreTF As Long) 'Thanks Steve McNeill
Static defaultColor~&, backGroundColor~&
Static font&, dest&, source&, row&, col&, autodisplay&, mb&
If restoreTF Then
_Font font&
Color defaultColor~&, backGroundColor~&
_Dest dest&
_Source source&
Locate row&, col&
If autodisplay& Then _AutoDisplay Else _Display
_KeyClear
While _MouseInput: Wend 'clear mouse clicks
mb& = _MouseButton(1)
If mb& Then
Do
While _MouseInput: Wend
mb& = _MouseButton(1)
_Limit 100
Loop Until mb& = 0
End If
Else
font& = _Font: defaultColor~& = _DefaultColor: backGroundColor~& = _BackgroundColor
dest& = _Dest: source& = _Source
row& = CsrLin: col& = Pos(0): autodisplay& = _AutoDisplay
_KeyClear
End If
End Sub
'title$ limit is 57 chars, all lines are 58 chars max, version 2019-08-06
'THIS SUB NOW NEEDS SUB scnState(restoreTF) for saving and restoring screen settings
Sub mBox (title As String, m As String)
Dim bg As _Unsigned Long, fg As _Unsigned Long
fg = &HFF000055 '< change as desired prompt text color, back color or type in area
bg = &HFF6080CC '< change as desired used fore color in type in area
'first screen dimensions and items to restore at exit
Dim sw As Long, sh As Long
Dim curScrn As Long, backScrn As Long, mbx As Long 'some handles
Dim ti As Long, limit As Long 'ti = text index for t$(), limit is number of chars per line
Dim i As Long, j As Long, ff As _Bit, addb As _Byte 'index, flag and
Dim bxH As Long, bxW As Long 'first as cells then as pixels
Dim mb As Long, mx As Long, my As Long, mi As Long, grabx As Long, graby As Long
Dim tlx As Long, tly As Long 'top left corner of message box
Dim lastx As Long, lasty As Long, t As String, b As String, c As String, tail As String
Dim d As String, r As Single, kh As Long
'screen and current settings to restore at end ofsub
ScnState 0
sw = _Width: sh = _Height
_KeyClear '<<<<<<<<<<<<<<<<<<<< do i still need this? YES! 2019-08-06 update!
'screen snapshot
curScrn = _Dest
backScrn = _NewImage(sw, sh, 32)
_PutImage , curScrn, backScrn
'setup t() to store strings with ti as index, linit 58 chars per line max, b is for build
ReDim t(0) As String: ti = 0: limit = 58: b = ""
For i = 1 To Len(m)
c = Mid$(m, i, 1)
'are there any new line signals, CR, LF or both? take CRLF or LFCR as one break
'but dbl LF or CR means blank line
Select Case c
Case Chr$(13) 'load line
If Mid$(m, i + 1, 1) = Chr$(10) Then i = i + 1
t(ti) = b: b = "": ti = ti + 1: ReDim _Preserve t(ti) As String
Case Chr$(10)
If Mid$(m, i + 1, 1) = Chr$(13) Then i = i + 1
t(ti) = b: b = "": ti = ti + 1: ReDim _Preserve t(ti)
Case Else
If c = Chr$(9) Then c = Space$(4): addb = 4 Else addb = 1
If Len(b) + addb > limit Then
tail = "": ff = 0
For j = Len(b) To 1 Step -1 'backup,
d = Mid$(b, j, 1)
If d = " " Then ' until find a space
t(ti) = Mid$(b, 1, j - 1): b = tail + c 'save the tail
ti = ti + 1: ReDim _Preserve t(ti)
ff = 1 'found space flag
Exit For
Else
tail = d + tail 'the tail grows!
End If
Next
If ff = 0 Then 'no break? OK
t(ti) = b: b = c: ti = ti + 1: ReDim _Preserve t(ti)
End If
Else
b = b + c 'just keep building the line
End If
End Select
Next
t(ti) = b
bxH = ti + 3: bxW = limit + 2
'draw message box
mbx = _NewImage(60 * 8, (bxH + 1) * 16, 32)
_Dest mbx
Color _RGB32(128, 0, 0), _RGB32(225, 225, 255)
Locate 1, 1: Print Left$(Space$((bxW - Len(title) - 3) / 2) + title + Space$(bxW), bxW)
Color _RGB32(225, 225, 255), _RGB32(200, 0, 0)
Locate 1, bxW - 2: Print " X "
Color fg, bg
Locate 2, 1: Print Space$(bxW);
For r = 0 To ti
Locate 1 + r + 2, 1: Print Left$(" " + t(r) + Space$(bxW), bxW);
Next
Locate 1 + bxH, 1: Print Space$(limit + 2);
'now for the action
_Dest curScrn
'convert to pixels the top left corner of box at moment
bxW = bxW * 8: bxH = bxH * 16
tlx = (sw - bxW) / 2: tly = (sh - bxH) / 2
lastx = tlx: lasty = tly
'now allow user to move it around or just read it
While 1
Cls
_PutImage , backScrn
_PutImage (tlx, tly), mbx, curScrn
_Display
While _MouseInput: Wend
mx = _MouseX: my = _MouseY: mb = _MouseButton(1)
If mb Then 'is mouse down on title bar to grab and move ?
If mx >= tlx And mx <= tlx + bxW And my >= tly And my <= tly + 16 Then
If mx >= tlx + bxW - 24 Then Exit While
grabx = mx - tlx: graby = my - tly
Do While mb 'wait for release
mi = _MouseInput: mb = _MouseButton(1)
mx = _MouseX: my = _MouseY
If mx - grabx >= 0 And mx - grabx <= sw - bxW Then
If my - graby >= 0 And my - graby <= sh - bxH Then
'attempt to speed up with less updates
i = (lastx - (mx - grabx)) ^ 2 + (lasty - (my - graby)) ^ 2
If i ^ .5 > 10 Then
tlx = mx - grabx: tly = my - graby
Cls
_PutImage , backScrn
_PutImage (tlx, tly), mbx, curScrn
lastx = tlx: lasty = tly
_Display
End If
End If
End If
_Limit 400
Loop
End If
End If
kh = _KeyHit
If kh = 27 Or kh = 13 Or kh = 32 Then Exit While
_Limit 400
Wend
'put things back
Color _RGB32(255, 255, 255), _RGB32(0, 0, 0): Cls '
_PutImage , backScrn
_Display
_FreeImage backScrn
_FreeImage mbx
ScnState 1 'Thanks Steve McNeill
End Sub
' You can grab this box by title and drag it around screen for full viewing while answering prompt.
' Only one line allowed for prompt$
' boxWidth is 4 more than the allowed length of input, needs to be longer than title$ and prompt$
' Utilities > Input Box > Input Box 1 tester v 2019-07-31
Function inputBox$ (prompt$, title$, boxWidth As Long) ' boxWidthin default 8x16 chars!!!
Dim ForeColor As _Unsigned Long, BackColor As _Unsigned Long
Dim sw As Long, sh As Long, curScrn As Long, backScrn As Long, ibx As Long 'some handles
'colors
ForeColor = &HFF000055 '< change as desired prompt text color, back color or type in area
BackColor = &HFF6080CC '< change as desired used fore color in type in area
'items to restore at exit
ScnState 0
'screen snapshot
sw = _Width: sh = _Height: curScrn = _Dest
backScrn = _NewImage(sw, sh, 32)
_PutImage , curScrn, backScrn
'moving box around on screen
Dim As Long bxW, bxH, mb, mx, my, mi, grabx, graby, tlx, tly, lastx, lasty, dist
Dim inp$, kh&
'draw message box
bxW = boxWidth * 8: bxH = 7 * 16
ibx = _NewImage(bxW, bxH, 32)
_Dest ibx
Color &HFF880000, White
Locate 1, 1
Print Left$(Space$(Int((boxWidth - Len(title$) - 3)) / 2) + title$ + Space$(boxWidth), boxWidth)
Color White, &HFFBB0000
Locate 1, boxWidth - 2: Print " X "
Color ForeColor, BackColor
Locate 2, 1: Print Space$(boxWidth);
Locate 3, 1
Print Left$(Space$((boxWidth - Len(prompt$)) / 2) + prompt$ + Space$(boxWidth), boxWidth);
Locate 4, 1: Print Space$(boxWidth);
Locate 5, 1: Print Space$(boxWidth);
Locate 6, 1: Print Space$(boxWidth);
inp$ = ""
GoSub finishBox
'convert to pixels the top left corner of box at moment
bxW = boxWidth * 8: bxH = 5 * 16
tlx = (sw - bxW) / 2: tly = (sh - bxH) / 2
lastx = tlx: lasty = tly
_KeyClear
'now allow user to move it around or just read it
While 1
Cls
_PutImage , backScrn
_PutImage (tlx, tly), ibx, curScrn
_Display
While _MouseInput: Wend
mx = _MouseX: my = _MouseY: mb = _MouseButton(1)
If mb Then 'is mouse down on title bar for a grab and move?
If mx >= tlx And mx <= tlx + bxW And my >= tly And my <= tly + 16 Then
If mx >= tlx + bxW - 24 Then Exit While
grabx = mx - tlx: graby = my - tly
Do While mb 'wait for release
mi = _MouseInput: mb = _MouseButton(1)
mx = _MouseX: my = _MouseY
If mx - grabx >= 0 And mx - grabx <= sw - bxW Then
If my - graby >= 0 And my - graby <= sh - bxH Then
'attempt to speed up with less updates
dist = (lastx - (mx - grabx)) ^ 2 + (lasty - (my - graby)) ^ 2
If dist ^ .5 > 10 Then
tlx = mx - grabx: tly = my - graby
Cls
_PutImage , backScrn
_PutImage (tlx, tly), ibx, curScrn
lastx = tlx: lasty = tly
_Display
End If
End If
End If
_Limit 400
Loop
End If
End If
kh& = _KeyHit
Select Case kh& 'whew not much for the main event!
Case 13: Exit While
Case 27: inp$ = "": Exit While
Case 32 To 128: If Len(inp$) < boxWidth - 4 Then
inp$ = inp$ + Chr$(kh&): GoSub finishBox
Else
Beep
End If
Case 8: If Len(inp$) Then inp$ = Left$(inp$, Len(inp$) - 1): GoSub finishBox Else Beep
End Select
_Limit 60
Wend
'put things back
ScnState 1 'need fg and bg colors set to cls
Cls '? is this needed YES!!
_PutImage , backScrn
_Display
_FreeImage backScrn
_FreeImage ibx
ScnState 1 'because we have to call _display, we have to call this again
inputBox$ = inp$
Exit Function
finishBox:
_Dest ibx
Color BackColor, ForeColor
Locate 5, 2: Print Left$(" " + inp$ + Space$(boxWidth - 2), boxWidth - 2)
_Dest curScrn
Return
End Function
' for saving and restoring screen settins
Sub GetLists (SearchDirectory As String, DirList() As String, FileList() As String)
' Thanks SNcNeill ! for a cross platform method to get file and directory lists
'put this block in main code section of your program close to top
'' direntry.h needs to be in QB64 folder '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
'DECLARE CUSTOMTYPE LIBRARY ".\direntry"
' FUNCTION load_dir& (s AS STRING)
' FUNCTION has_next_entry& ()
' SUB close_dir ()
' SUB get_next_entry (s AS STRING, flags AS LONG, file_size AS LONG)
'END DECLARE
Const IS_DIR = 1
Const IS_FILE = 2
Dim As Long flags, file_size, length
Dim As Integer DirCount, FileCount
Dim nam$
ReDim _Preserve DirList(100), FileList(100)
DirCount = 0: FileCount = 0
If load_dir(SearchDirectory + Chr$(0)) Then
Do
length = has_next_entry
If length > -1 Then
nam$ = Space$(length)
get_next_entry nam$, flags, file_size
If (flags And IS_DIR) Then
DirCount = DirCount + 1
If DirCount > UBound(DirList) Then
ReDim _Preserve DirList(UBound(DirList) + 100)
End If
DirList(DirCount) = nam$
ElseIf (flags And IS_FILE) Then
FileCount = FileCount + 1
If FileCount > UBound(FileList) Then
ReDim _Preserve FileList(UBound(FileList) + 100)
End If
FileList(FileCount) = nam$
End If
End If
Loop Until length = -1
'close_dir 'move to after end if might correct the multi calls problem
Else
End If
close_dir 'this might correct the multi calls problem
ReDim _Preserve DirList(DirCount)
ReDim _Preserve FileList(FileCount)
End Sub
Sub GetListStrings (dirOut$, fileOut$)
ReDim Folders$(1 To 1), Files$(1 To 1) ' setup to call GetLists
If curPath$ = "" Then curPath$ = _CWD$
GetLists curPath$, Folders$(), Files$()
dirOut$ = Join$(Folders$(), "~")
fileOut$ = Join$(Files$(), "~")
End Sub ' 937 +50 = 987 now 2022-7-26Oh BTW, the o with 2 dots over it prints 2 zeros also notice NO DECIMAL POINT in keys, it is inserted when the number is printed. That is what the o with 3 dots is for, converting pennies to dollars. PS I eliminated 5 Keys from when I started that's why all the space under them.
b = b + ...