09-10-2024, 12:14 PM
I wrote my own version of inputbox. Its limitation is that it is only intended for a resolution of 1920x1080 (my default), so it was satisfactory for the program for which it was intended.
It supports marking and deleting part of the text, the clipboard and scrolling on the monitor if the dialog is caught by the mouse by the upper edge. Maybe it could be of interest to someone.
It supports marking and deleting part of the text, the clipboard and scrolling on the monitor if the dialog is caught by the mouse by the upper edge. Maybe it could be of interest to someone.
Code: (Select All)
Screen _NewImage(1920, 1080, 32)
Cls 'need for black with alpha 255 in background (or can be used image)
_FullScreen
D$ = "programmer"
N = Val(InputBoxZ("Window title", "This program now tests:", D$, 1, 0))
_Display
Print N, D$ 'N = buttons status, D$ = text inserted in box
_Display
End
Function InputBoxZ$ (Tit As String, Message As String, Default As String, DefaultVal, BoxType)
'designated for 1920 x 1080 resolution only!
'ESC = -1; OK = 1; CANCEL = 0
B.Height = 125
B.Width = 351
B.X = B.Width \ 2 - _Width \ 2
If B.X < 0 Then
B.X = _Width \ 2 - B.Width \ 2
End If
B.Y = B.Height \ 2 - _Height \ 2
If B.Y < 0 Then
B.Y = _Height \ 2 - B.Height \ 2
End If
'It saves the background in ram during the dialog, nothing
'else happens until it is confirmed or finished, it is not a pass-through function
Backgr& = _CopyImage(0, 32) '
GPos = _PrintWidth(Default)
t$ = Default$
Do Until Done
_PutImage , Backgr&, _Dest
K& = _KeyHit
Select Case K&
Case 27: InputBoxZ$ = "-1": Exit Function 'After Esc return -1
Case 13: InputBoxZ$ = Str$(DefaultVal): Exit Function 'After Enter is returned defaultval (is changed by user)
'OK = 1, Cancel = 0,
End Select
While _MouseInput
Wend
MX = _MouseX
MY = _MouseY
LB = _MouseButton(1)
'solution for moving dialog on the screen by mouse
If PLock Then GoTo Shift 'GoTo enables scrolling for as long as the button is pressed, even if you escape from the dialog's coordinates
If MX >= B.X And MX <= B.Width + B.X Then
If MY >= B.Y And MY <= B.Y + 24 Then
Shift:
If LB = -1 Then
PLock = 1
If DoX = 0 Then
DoX = MX - B.X
DoY = MY - B.Y
End If
B.X = MX - DoX
B.Y = MY - DoY
Else
DoX = 0
PLock = 0
End If
End If
End If
Line (B.X, B.Y)-(B.Width + B.X, B.Height + B.Y), _RGB32(240), BF 'whole box area
Line (B.X, B.Y)-(B.Width + B.X, B.Y + 24), _RGB32(255), BF ' title area
_PrintMode _KeepBackground
Color _RGB32(188, 153, 171)
_PrintString (B.X + 5, B.Y + 5), Tit$
Color _RGB32(0)
_PrintString (B.X + 9, B.Y + 34), Message$
BoxZ B.X + 12, B.Y + 57, B.X + B.Width - 12, B.Y + 77 'draw box for inserting text
'axis X
ButtonWdth = 78
ButtonRightOkraj = 13
ButtonMezi = 13
'axis Y
ButtonHght = 20
ButtonSpodniOkraj = 15
LHx = B.X + B.Width - ButtonWdth - ButtonRightOkraj ' left upper X Cancel button
PHx = LHx + ButtonWdth ' right upper X Cancel button
LDy = B.Y + B.Height - ButtonSpodniOkraj - ButtonHght 'left bottom Y Cancel button
Lhy = LDy + ButtonHght ' left upper Y Cancel button
PHx1 = PHx - ButtonMezi - ButtonWdth
LHx1 = PHx1 - ButtonWdth
ButtonActive$ = ""
Select Case BoxType
Case 0
'defaultVal set, which button is after run set as default
Buttons = 2
B1$ = "OK"
B2$ = "Cancel"
'Right button: Cancel
BoxButtonZ LHx, LDy, PHx, Lhy ' cancel
BoxButtonZ LHx1, LDy, PHx1, Lhy 'OK
CPW = _PrintWidth(B2$)
OPW = _PrintWidth(B1$)
T1 = LHx + (PHx - LHx) \ 2 - CPW \ 2
T2 = LHx1 + (PHx1 - LHx1) \ 2 - OPW \ 2
TY = Lhy + (LDy - Lhy) \ 2 - _FontHeight \ 2 + 2
'ocad poanglictovat dolu
' If DefaultVal = 0 Then Color _RGB32(0) Else Color _RGB32(188, 153, 171) 'original ma oba popisky cerne,
_PrintString (T1, TY), B2$ ' pri kliknuti na volbu zustane text cerny,
' If DefaultVal = 1 Then Color _RGB32(0) Else Color _RGB32(188, 153, 171) ' oramovani se ale zmeni z BoxButtonZ na BoxZ
_PrintString (T2, TY), B1$ ' a okolo textu se udela jeste binarni Line B
If LB = -1 And MX > LHx1 And MX < PHx1 And MY > LDy And MY < Lhy Then DefaultVal = 1: ButtonActive$ = "OK"
If LB = -1 And MX > LHx And MX < PHx And MY > LDy And MY < Lhy Then DefaultVal = 0: ButtonActive$ = "Cancel"
If MX > B.X + 12 And MX < B.X + B.Width - 12 And MY > B.Y + 57 And MY < B.Y + 77 Then _MouseShow "Text" Else _MouseShow "default"
If LB = -1 And MX > B.X + 12 And MX < B.X + B.Width - 12 And MY > B.Y + 57 And MY < B.Y + 77 Or DialogAct = 1 Then
DialogAct = 1
'logika vkladani textu do textoveho pole
' If LB = -1 And MX > B.X + 12 And MX < B.X + B.Width - 12 And MY > B.Y And MY < B.Height Then
If Dialog& = 0 Then
Dialog& = _NewImage(B.Width, B.Height, 32)
_PutImage (B.X, B.Y)-(B.Width + B.X, B.Height + B.Y), 0, Dialog&
End If
Do Until K$ = Chr$(13) Or ButtonActive$ <> ""
K$ = InKey$
'urcit grafickou polohu kurzoru pri kliknuti do textu - uz ok
If MX > B.X + 12 And MX < B.X + B.Width - 12 And MY > B.Y + 57 And MY < B.Y + 77 Then
If LB = -1 Then
If ShiftStart > 0 And Len(K$) = 0 Then
ShiftStart = 0
ShiftEnd = 0
ShiftLock = 0
_Continue
End If
If MX - (B.X + 12) < _PrintWidth(t$) + 12 And MX > B.X + 12 Then
UPGI = _FontWidth * ((MX - (B.X + 12)) \ _FontWidth)
GPos = UPGI - _FontWidth
End If
If GPos < 0 Then GPos = 0
If MemG = 0 Then MemG = GPos + _FontWidth
End If
'support for select text with mouse
If LB = -1 And MemG <> GPos + _FontWidth Then
ShiftStart = MemG
ShiftEnd = GPos + _FontWidth
GoTo ppp
End If
If LB = 0 And MemG > 0 Then
MemG = 0
End If
End If 'end condition for locking window when is moved on the screen with mouse
'Shift press support for text select
ShiftLeft& = _KeyDown(100303)
ShiftRight& = _KeyDown(100304)
If ShiftLeft& Or ShiftRight& Then
If Len(K$) = 1 Then ShiftLock = 0: GoTo DoNotShift
If ShiftStart = 0 Then ShiftStart = GPos + _FontWidth
If ShiftStart > 0 Then ShiftEnd = GPos + _FontWidth
ppp: 'whin selecting text with mouse, use block for selecting with keyboard by there
ShiftLock = 1
ITLS = ShiftStart \ _FontWidth
ITLR = ShiftEnd \ _FontWidth - ShiftStart \ _FontWidth
If ITLR < 0 Then
ITLR = ShiftStart \ _FontWidth - ShiftEnd \ _FontWidth
ITLS = ShiftEnd \ _FontWidth
End If
InsertedText$ = Mid$(t$, ITLS, ITLR)
Else
ShiftLock = ShiftStart 'Delete / Shift logic blocking
End If
'Clipboard support
'ShifStart is reseted after sopmething is pressed on the keyboard
If K$ = Chr$(3) Then _Clipboard$ = InsertedText$ 'insert to clipboard
If ShiftLeft& = 0 And ShiftRight& = 0 And K$ <> "" Then
If Len(InsertedText$) And Len(K$) = 1 Then
If Asc(K$) > 31 And Asc(K$) < 127 Then 'limit for text characters
' If part of the text is marked and you press a letter,
'Delete the marked part and write from its original left side
If ShiftStart > ShiftEnd Then Swap ShiftStart, ShiftEnd
kk$ = ""
tA$ = Left$(t$, ShiftStart \ _FontWidth - 1)
tB$ = Right$(t$, Len(t$) - ShiftEnd \ _FontWidth + 1)
If Asc(K$) > 31 And Asc(K$) < 127 Then kk$ = K$
t$ = tA$ + kk$ + tB$
GPos = ShiftStart
'Print "Ta a Tb:"; tA$, tB$, ShiftStart, ShiftEnd: _Display
tA$ = ""
tB$ = ""
ShiftStart = 0
InsertedText$ = ""
_Continue
End If
End If
DoNotShift:
tA$ = ""
tB$ = ""
ShiftStart = 0
InsertedText$ = ""
'Sound 299, .1 'every character can do sound 
End If
'last upgrade: 2024-24-02
If K$ = Chr$(0) + Chr$(75) Then
If GPos > 0 Then GPos = GPos - _FontWidth 'arrow left
End If
If K$ = Chr$(0) + Chr$(77) Then
If GPos < _PrintWidth(t$) Then GPos = GPos + _FontWidth 'arrow right
End If
If K$ = Chr$(22) Then 'clipboard inserting is supported (Ctrl+V)
t$ = Left$(_Clipboard$, 30)
GPos = _FontWidth * Len(t$)
End If
If LB = -1 Then AllowText = 0 Else AllowText = 1 'when textbox is moved on the screen, text inserting is blocked
If AllowText = 1 Then
If Len(t$) < 30 And Len(K$) Then
If Asc(K$) > 31 And Asc(K$) < 177 Then
TextPos = GPos \ _FontWidth
TextA$ = Mid$(t$, 1, TextPos)
TextB$ = Mid$(t$, TextPos + 1, Len(t$) - TextPos)
t$ = TextA$ + K$ + TextB$
GPos = GPos + _FontWidth
K$ = ""
End If
End If
Else
K$ = ""
End If
If K$ = Chr$(8) Then 'Backspace support
If ShiftLock Then GoTo ShiftedLock
If Len(t$) > 0 Then
T1$ = Mid$(t$, 1, (GPos - 1) \ _FontWidth) 'the left part of the string according to GPos shortened by one character
T2$ = Right$(t$, Len(t$) - Len(T1$) - 1) 'right part of the string
If GPos <= 0 Then _Continue 'if GPos (cursor position) is 0
t$ = T1$ + T2$
Default$ = t$
GPos = GPos - _FontWidth
Color _RGB32(255)
_PrintMode _FillBackground
_PrintString (B.X + 24 + GPos, B.Y + 60), Chr$(255)
_PrintMode _KeepBackground
Rem ----------------------------------
End If
'if piece of the text is inserted, delete it
ShiftedLock:
Kpocet = ITLR
Kstart = ITLS
If ShiftLock Then
LeftT$ = Mid$(t$, 1, Kstart - 1)
RightT$ = Mid$(t$, Kstart + Kpocet)
t$ = LeftT$ + RightT$
ShiftLock = 0
GPos = _PrintWidth(t$)
End If
End If
If K$ = Chr$(0) + Chr$(83) Then 'delete support
If ShiftLock Then GoTo ShiftedLockB
If Len(t$) > 0 Then
T1d$ = Left$(t$, GPos \ _FontWidth) 'left part of the string by GPos minus one character
T2d$ = Right$(t$, Len(t$) - Len(T1d$) - 1) 'right part of the string
t$ = T1d$ + T2d$
Default$ = t$
Color _RGB32(255)
_PrintMode _FillBackground
_PrintString (B.X + 24 + GPos, B.Y + 60), Chr$(255)
_PrintMode _KeepBackground
Rem LINE----------------------------------
End If
ShiftedLockB:
Kpocet = ITLR
Kstart = ITLS
If ShiftLock Then
LeftT$ = Mid$(t$, 1, Kstart - 1)
RightT$ = Mid$(t$, Kstart + Kpocet)
t$ = LeftT$ + RightT$
Default$ = t$
GPos = _PrintWidth(t$)
ShiftLock = 0
End If
End If
If K$ = Chr$(0) + Chr$(71) Then GPos = 0 'Home key
If K$ = Chr$(0) + Chr$(79) Then GPos = _PrintWidth(t$) 'Home key
_PrintMode _FillBackground
Line (B.X + 12, B.Y + 57)-(B.X + B.Width - 12, B.Y + 77), _RGB32(255), BF 'clear background
_PrintString (B.X + 24, B.Y + 60), t$
'if part of the text is selected, colorize it
If ShiftStart Then
Line (B.X + 16 + ShiftStart, B.Y + 57)-(B.X + 16 + ShiftEnd, B.Y + 77), _RGBA32(0, 0, 127, 117), BF
End If
If Timer * 10 Mod 10 < 5 Then 'cursor blicking
Line (B.X + 24 + GPos, B.Y + 60)-(B.X + 24 + GPos, B.Y + 72), _RGB32(255)
Else
Line (B.X + 24 + GPos, B.Y + 60)-(B.X + 24 + GPos, B.Y + 72), _RGB32(0)
End If
Color _RGB32(0), _RGB32(255)
While _MouseInput
Wend
MX = _MouseX
MY = _MouseY
LB = _MouseButton(1)
If LB = -1 And MX > LHx1 And MX < PHx1 And MY > LDy And MY < Lhy Then
DefaultVal = 1
ButtonActive$ = "OK"
Default$ = t$
End If
If LB = -1 And MX > LHx And MX < PHx And MY > LDy And MY < Lhy Then
DefaultVal = 0
ButtonActive$ = "Cancel"
End If
If MX > B.X + 12 And MX < B.X + B.Width - 12 And MY > B.Y + 57 And MY < B.Y + 77 Then
_MouseShow "Text"
Else
_MouseShow "default"
Exit Do
End If
_Display
Loop
Else
DialogAct = 0
End If
Default$ = t$
End Select
_PrintMode _KeepBackground
_PrintString (B.X + 24, B.Y + 60), t$
If Len(ButtonActive$) Then
Do Until LB = 0
While _MouseInput: Wend
LB = _MouseButton(1)
Select Case ButtonActive$
Case "OK"
BoxZ LHx1, LDy, PHx1, Lhy 'for OK
Line (LHx1, LDy)-(PHx1, Lhy), _RGB32(240), BF
Color _RGB32(0)
_PrintString (T2, TY), B1$
InputBoxZ$ = "1"
Case "Cancel"
BoxZ LHx, LDy, PHx, Lhy ' for cancel
Line (LHx, LDy)-(PHx, Lhy), _RGB32(240), BF
Color _RGB32(0)
_PrintString (T1, TY), B2$
InputBoxZ$ = "0"
End Select
_Display
_Limit 100
Loop
Done = 1
LB = 0
End If
_Display
_Limit 120
Color _RGB32(255)
If K$ = Chr$(13) Then Exit Do
Loop
_PutImage , Backgr&, _Dest
_FreeImage Backgr&
Color _RGB32(255), _RGB32(0)
_PrintMode _FillBackground
Default$ = t$
End Function
Sub BoxZ (Xs, Ys, Xe, Ye) 'imitation of the appearance of buttons for concrete resolution according to windows buttons
Line (Xs, Ys)-(Xe, Ye), _RGB32(255), BF
'bootm lines:
Line (Xs - 1, Ye + 1)-(Xe + 1, Ye + 1), _RGB32(227)
Line (Xs - 1, Ye + 2)-(Xe + 1, Ye + 2), _RGB32(255)
'right lines
Line (Xe + 1, Ys - 1)-(Xe + 1, Ye + 1), _RGB32(227)
Line (Xe + 2, Ys - 1)-(Xe + 2, Ye + 1), _RGB32(255)
'upper two lines
Line (Xs - 2, Ys - 2)-(Xe + 1, Ys - 2), _RGB32(105)
Line (Xs - 1, Ys - 1)-(Xe + 1, Ys - 1), _RGB32(160)
'left two lines
Line (Xs - 2, Ys - 2)-(Xs - 2, Ye + 2), _RGB32(105)
Line (Xs - 1, Ys - 1)-(Xs - 1, Ye + 1), _RGB32(160)
End Sub
Sub BoxButtonZ (Xs, Ys, Xe, Ye) 'test - ok
Rem compared to BoxZ what's on the right will be on the left, what's up will be down
'One button description BoxButtonZ or ButtonZ is applied to the button in the unclicked state
'and the other description is applied to the button when it is pressed
Line (Xs, Ys)-(Xe, Ye), _RGB32(240), BF
'bottom lines
Line (Xs - 1, Ye + 1)-(Xe + 1, Ye + 1), _RGB32(160)
Line (Xs - 1, Ye + 2)-(Xe + 1, Ye + 2), _RGB32(105)
'right lines
Line (Xe + 1, Ys - 1)-(Xe + 1, Ye + 1), _RGB32(160) 'tyto 2 prohozeny barvy
Line (Xe + 2, Ys - 1)-(Xe + 2, Ye + 1), _RGB32(105)
'upper lines
Line (Xs - 2, Ys - 2)-(Xe + 1, Ys - 2), _RGB32(255)
Line (Xs - 1, Ys - 1)-(Xe + 1, Ys - 1), _RGB32(227)
'left lines
Line (Xs - 2, Ys - 2)-(Xs - 2, Ye + 2), _RGB32(255)
Line (Xs - 1, Ys - 1)-(Xs - 1, Ye + 1), _RGB32(227)
End Sub
