Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
TUI für Konsole oder Grafikfenster - Bugfix Version
| Uploader: |  Lothar Schirm |
| Datum/Zeit: | 09.04.2015 18:18:02 |
'===============================================================================
' TUI.bas
' TUI für Konsole oder Grafik (8x16 Zeichensatz, 32 Bit Farbtiefe)
' mit Mausunterstützung
' Erstellt am 06.03.2015
' Letzte Bearbeitung am 07.04.15
'===============================================================================
'Wichtige Tastaturabfragecodes, die von Inkey zurueckgegeben werden:
Const SC_BKSP = Chr(8), SC_TAB = Chr(9), SC_SHIFT_TAB = Chr(255, 15), _
SC_ENTER = Chr(13), SC_ESC = Chr(27), _
SC_LEFT = Chr(255, 75), SC_RIGHT = Chr(255, 77), _
SC_UP = Chr(255, 72), SC_DOWN = Chr(255, 80), _
SC_INS = Chr(255, 82), SC_DEL = Chr(255, 83), _
SC_END = Chr(255, 79), SC_HOME = Chr(255, 71), _
SC_PGUP = Chr(255, 73), SC_PGDOWN = Chr(255, 81), _
SC_F1 = Chr(255, 59), SC_F2 = Chr(255, 60), SC_F3 = Chr(255, 61), _
SC_F4 = Chr(255, 62), SC_F5 = Chr(255, 63), SC_F6 = Chr(255, 64), _
SC_F7 = Chr(255, 65), SC_F8 = Chr(255, 66), SC_F9 = Chr(255, 67), _
SC_F10 = Chr(255, 68), _
SC_X = Chr(255, 107) 'Button zum Schliessen des Fensters
'RGB-Farbkonstanten der Farbindizes 0 bis 15:
Const black = &H000000, blue = &H0000AA, green = &H00AA00, cyan = &H00AAAA, _
red = &HAA0000, magenta = &HAA00AA, brown = &HAA5500, grey = &HAAAAAA, _
darkgrey = &H555555, lightblue = &H5555FF, lightgreen = &H55FF55, _
lightcyan = &H55FFFF, lightred = &HFF5555, lightmagenta = &HFF55FF, _
yellow = &HFFFF55, white = &HFFFFFF
Dim Shared As Integer TUI_Mode, TUI_TextColor, TUI_BackColor
'Siehe Function Window_New
Type Button
x As Integer 'Linke Spalte
y As Integer 'Oberste Zeile
w As Integer 'Breite (Anzahl Spalten) (Höhe ist eine Zeile)
TextColor As Integer 'Textfarbe
BackColor As Integer 'Hintergrundfarbe
Caption As String 'Beschriftung
End Type
Type CheckBox
x As Integer
y As Integer
w As Integer
TextColor As Integer
BackColor As Integer
Caption As String
State As Integer 'Check-Status (1 oder 0)
End Type
Type RadioButton
x As Integer
y As Integer
w As Integer
TextColor As Integer
BackColor As Integer
Caption As String
State As Integer 'Check-Status (1 oder 0)
End Type
Type Label
x As Integer
y As Integer
w As Integer
Text As String
End Type
Type TextBox
x As Integer
y As Integer
w As Integer
TextColor As Integer
BackColor As Integer
CursorColor As Integer
Text As String
CPos As Integer 'Cursorposition, siehe Sub TextBox_Edit
End Type
Type ListBox
x As Integer
y As Integer
w As Integer
h As Integer
TextColor As Integer
BackColor As Integer
HighlightTextColor As Integer
HighlightBackColor As Integer
buffer(100) As String 'Buffer für Einträge
imax As Integer 'Höchster Index der Einträge
index As Integer 'Gewählter Index
End Type
Type TrackBar
x As Integer
y As Integer
w As Integer
BackColor As Integer
SliderColor As Integer
minvalue As Integer 'Minimaler und maximaler Wert
maxvalue As Integer
value As Integer 'Aktueller Wert
End Type
Type ProgressBar
x As Integer
y As Integer
w As Integer
BackColor As Integer
BarColor As Integer
minvalue As Integer
maxvalue As Integer
value As Integer
End Type
Sub OpenWindow(w As Integer, h As Integer, title As String, Mode As Integer = 0)
'TUI initialisieren (zeichnen und definieren).
'Textfarbe weiß, Hintergrundfarbe grau.
'Mode = 0: Screen 0 (Konsole)
'Mode = 1: Grafik
TUI_Mode = Mode
Select Case TUI_Mode
Case 0
Screen 0
TUI_TextColor = 0
TUI_BackColor = 7
Shell "Title" + Space(1) + title
Width w, h
Color TUI_TextColor, TUI_BackColor
Cls
Case 1
ScreenRes w * 8, h * 16, 32, 2
TUI_TextColor = black
TUI_BackColor = grey
WindowTitle title
Width w, h
Color TUI_TextColor, TUI_BackColor
Cls
End Select
Locate,,0 'Cursor für die Konsole aus
End Sub
Function Window_Event_Close() As Integer
'Gibt 1 zurück, wenn der "Close" button ("x") des Fensters gedrückt wurde
If Inkey = SC_X Then Return 1 Else Return 0
End Function
Function MouseInRect(mx As Integer, my As Integer, x As Integer, y As Integer, _
w As Integer) As Integer
'Gib 1 zurück, wenn sich der Mauszeiger mit den Koordinaten mx und my innerhalb
'des betreffenden Rechtecks befindet, sonst 0.
'Hilfsprozedur
Select Case TUI_Mode
Case 0
'Konsole: mx und my fangen mit 0 an zu zählen
If (mx + 1) >= x And (mx + 1) <= (x + w) And my + 1 = y Then Return 1 Else Return 0
Case 1
'Grafik:
If mx > 8 * (x - 1) And mx < 8* (x - 1 + w) And my > 16 * (y - 1) And my < 16 * y _
Then Return 1 Else Return 0
End Select
End Function
Function Button_New(x As Integer, y As Integer, w As Integer, Text As String) As Button
'Neuen Button definieren und zeichnen (Textfabe weiß, Hintergrundfarbe dunkelgrau):
Dim As Button btn
btn.x = x
btn.y = y
btn.w = w
If TUI_Mode = 0 Then
btn.TextColor = 15
btn.BackColor = 8
Else
btn.TextColor = white
btn.BackColor = darkgrey
End If
btn.Caption = Text
Color btn.TextColor, btn.BackColor
Locate y, x
Print Space(w)
Locate y, x + (w - Len(btn.Caption)) \ 2 'zentriert
Print btn.Caption
Return btn
End Function
Function Button_Event(btn As Button) As Integer
'Gibt 1 zurück, wenn der Button gedrückt wurde, sonst 0
Dim As Integer mx, my, mb
Getmouse(mx, my,, mb)
Sleep 1
If MouseInRect(mx, my, btn.x, btn.y, btn.w) And mb = 1 Then
'Warten, bis Maustaste losgelassen wird - so lange wird die Beschriftung schwarz
'gezeichnet:
If TUI_Mode = 0 Then Color 0, btn.BackColor Else Color black, btn.BackColor
Locate btn.y, btn.x + (btn.w - Len(btn.Caption)) \ 2, 0 'Konsole Cursor aus
Print btn.Caption
Do
Getmouse(mx, my,, mb)
Sleep 1
Loop Until mb = 0
Color btn.TextColor, btn.BackColor
Locate btn.y, btn.x + (btn.w - Len(btn.Caption)) \ 2
Print btn.Caption
Return 1
Else
Return 0
End If
End Function
Function CheckBox_New(x As Integer, y As Integer, w As Integer, Text As String) As CheckBox
'Neue Checkbox definieren und zeichnen (Textfabe weiß, Hintergrundfarbe dunkelgrau):
Dim As CheckBox cb
cb.x = x
cb.y = y
cb.w = w
If TUI_Mode = 0 Then
cb.TextColor = 15
cb.BackColor = 8
Else
cb.TextColor = 15
cb.BackColor = darkgrey
End If
cb.Caption = Text
cb.State = 0
Color cb.TextColor, cb.BackColor
Locate y, x
Print Space(w)
Locate y, x 'zentriert
Print "[ ] " + cb.Caption
Return cb
End Function
Sub CheckBox_SetCheck(ByRef cb As CheckBox, State As Integer)
'Check-Status einer Checkbox setzen (0 oder 1)
cb.State = State
Color cb.TextColor, cb.BackColor
Locate cb.y, cb.x + 1
Select Case cb.State
Case 0
Print Space(1)
Case 1
Print "X"
End Select
End Sub
Function CheckBox_Event(ByRef cb As CheckBox) As Integer
'Gibt 1 zurück, wenn die Checkbox gedrückt wurde und schaltet den Check-Status um
Dim As Integer mx, my, mb, State
Getmouse(mx, my,, mb)
Sleep 1
If MouseInRect(mx, my, cb.x, cb.y, cb.w) And mb = 1 Then
State = cb.State XOR 1
CheckBox_SetCheck(cb, State)
'Warten, bis Maustaste losgelassen wird:
Do
Getmouse(mx, my,, mb)
Sleep 1
Loop Until mb = 0
Return 1
Else
Return 0
End If
End Function
Function CheckBox_GetCheck(cb As CheckBox) As Integer
'Gibt den Check-Status einer Checkbox zurück
Return cb.State
End Function
Function RadioButton_New(x As Integer, y As Integer, w As Integer, Text As String) As RadioButton
'Neuen Radiobutton definieren und zeichnen (Textfabe weiß, Hintergrundfarbe dunkelgrau):
Dim As RadioButton rb
rb.x = x
rb.y = y
rb.w = w
If TUI_Mode = 0 Then
rb.TextColor = 15
rb.BackColor = 8
Else
rb.TextColor = white
rb.BackColor = darkgrey
End If
rb.Caption = Text
rb.State = 0
Color rb.TextColor, rb.BackColor
Locate y, x
Print Space(w)
Locate y, x 'zentriert
Print "( ) " + rb.Caption
Return rb
End Function
Sub RadioButton_SetCheck(ByRef rb As RadioButton, State As Integer)
'Check-Status eines Radiobuttons setzen (0 oder 1). Innerhalb eines Arrays von
'Radiobuttons (siehe Function RadioButton_Event) darf maximal einer auf 1 gesetzt
'sein!
rb.State = State
Color rb.TextColor, rb.BackColor
Locate rb.y, rb.x + 1
Select Case rb.State
Case 0
Print Space(1)
Case 1
Print Chr(254)
End Select
End Sub
Function RadioButton_Event(rb() As RadioButton, Byref k As Integer) As Integer
'Gibt 1 zurück, wenn ein Radiobutton innerhalb eines Arrays von Radiobuttons
'angeklickt wurde, sonst 0. k ist der Index desjenigen Radiobuttons, dessen
'Zustand auf "checked" gesetzt ist, nachdem ein Radiobutton angeklickt wurde.
Dim As Integer n = UBound(rb), i, mx, my, mb, State, result
k = -1
Getmouse(mx, my,, mb)
Sleep 1
For i = 0 To n
If MouseInRect(mx, my, rb(i).x, rb(i).y, rb(i).w) And mb = 1 Then
'Zustand des gedrückten Radiobuttons auf 1 schalten:
If rb(i).State = 0 Then RadioButton_SetCheck(rb(i), 1)
'Warten, bis Maustaste losgelassen wird:
Do
Getmouse(mx, my,, mb)
Sleep 1
Loop Until mb = 0
k = i
result = 1
Exit For
End If
Next
'Zustand aller anderen Radiobuttons auf 0 schalten:
If k >= 0 Then
For i = 0 To n
If i <> k And rb(i).State = 1 Then RadioButton_SetCheck(rb(i), 0)
Next
End If
Return result
End Function
Function Label_New(x As Integer, y As Integer, w As Integer, text As String) As Label
'Neuen Label definieren und zeichnen
Dim As Label lbl
lbl.x = x
lbl.y = y
lbl.w = w
lbl.Text = text
Color TUI_TextColor, TUI_BackColor
Locate y, x
Print Space(lbl.w)
Locate y, x
Print lbl.Text
Return lbl
End Function
Function TextBox_New(x As Integer, y As Integer, w As Integer, text As String = "") _
As TextBox
'Neue Textbox definieren und zeichnen (Textfarbe schwarz, Hintergrund weiß,
'Cusorfarbe für Grafik rot):
Dim As TextBox tb
tb.x = x
tb.y = y
tb.w = w
If TUI_Mode = 0 Then
tb.TextColor = 0
tb.BackColor = 15
Else
tb.TextColor = black
tb.BackColor = white
tb.CursorColor = cyan
End If
tb.Text = text
Color tb.TextColor, tb.BackColor
Locate y, x
Print Space(w)
Locate y, x
Print Left(tb.Text, Len(tb.Text))
Return tb
End Function
Sub TextBox_SetText(ByRef tb As TextBox, text As String)
'Text einer Textbox neu setzen
tb.Text = text
Color tb.TextColor, tb.BackColor
Locate tb.y, tb.x
Print Space(tb.w)
Locate tb.y, tb.x
Print Left(tb.Text, tb.w)
End Sub
Function TextBox_GetText(tb As Textbox) As String
'Text von der
Return tb.text
End Function
Sub TextBox_Edit(ByRef tb As TextBox, ReadOnly As Integer = 0)
'Text der Textbox editieren. ReadOnly = 1: Text kann nicht editiert werden,
'nur gescrollt
Dim As String strKey
Dim As Integer ascKey, Offset, mx, my, mb
Color Tb.TextColor, tb.BackColor
Do
'Text mit Cursor anzeigen:
If TUI_Mode = 1 Then ScreenLock
Locate tb.y, tb.x, 1 'Konsole Cursor ein
Print Space(tb.w);
Locate tb.y, tb.x
Print Mid(tb.text, Offset + 1, tb.w);
Locate tb.y, tb.x + tb.CPos - Offset
If TUI_Mode = 1 Then
Draw String (8 * (tb.x - 1 + tb.CPos - Offset), 16 * (tb.y - 1)), _
"_", tb.CursorColor
ScreenUnlock
End If
'Maus abfragen und Cursorposition setzen:
GetMouse mx,my,,mb
'Längere Wartezeit setzt das Flimmern im Konsolenmode herab:
If TUI_Mode = 0 Then Sleep 100 Else Sleep 1
If MouseInRect(mx, my, tb.x, tb.y, tb.w) And mb = 1 Then
If TUI_Mode = 0 Then tb.CPos = mx + 1 - tb.x + Offset _
Else tb.CPos = (mx - 8 * (tb.x - 1)) \ 8 + Offset
If tb.CPos > Len(tb.Text) Then tb.CPos = Len(tb.Text)
End If
'Tasten abfragen:
strKey = Inkey
Select Case strKey
Case SC_LEFT
'Cursor nach links:
If tb.CPos > 0 Then
tb.CPos = tb.CPos - 1
If tb.CPos < Offset Then Offset = Offset - 1
End If
Case SC_RIGHT
'Cursor nach rechts:
If tb.CPos < Len(tb.Text) Then
tb.CPos = tb.CPos + 1
If tb.CPos > tb.w - 1 + Offset Then Offset = Offset + 1
End If
Case SC_HOME
'Cursor an den Anfang:
tb.CPos = 0
Offset = 0
Case SC_END
'Cursor ans Ende:
tb.CPos = Len(tb.Text)
If Len(tb.Text) > tb.w Then Offset = Len(tb.Text) - tb.w
Case SC_DEL
'Entf
If ReadOnly = 0 Then
If (Len(tb.Text) > 0) And (tb.CPos < Len(tb.Text)) Then _
tb.Text = Left(tb.Text, tb.CPos) + Right(tb.Text, Len(tb.Text) - tb.CPos - 1)
End If
Case SC_BKSP
'Backspace:
If ReadOnly = 0 Then
If (Len(tb.Text) > 0) And (tb.CPos > 0) Then
tb.Text = Left(tb.Text, tb.CPos - 1) + Right(tb.Text, (Len(tb.Text) - tb.CPos))
tb.CPos = tb.CPos - 1
If Offset > 0 Then Offset = Offset - 1
End If
End If
Case Else
If ReadOnly = 0 And Len(strKey) = 1 And Asc(strKey) > 30 Then
'Druckbare Zeichen:
tb.Text = Left(tb.Text, tb.CPos) + strKey + Right(tb.Text, Len(tb.Text) - tb.CPos)
tb.CPos = tb.CPos + 1
If tb.CPos > tb.w - 1 + Offset Then Offset = Offset + 1
End If
End Select
Loop Until strKey = SC_ENTER Or (mb = 1 And MouseInRect(mx, my, tb.x, tb.y, tb.w) = 0)
'Ende:
Locate tb.y, tb.x
Print Space(tb.w);
Locate tb.y, tb.x, 0 'Cursor wieder aus
Print Left(tb.Text, tb.w);
End Sub
Function TextBox_Event(ByRef tb As TextBox) As Integer
'Gibt 1 zurück, wenn die Textbox angeklickt wurde und speichert die durch den
'Mausklick definierte Cursorposition
Dim As Integer mx, my, mbtn
Getmouse(mx, my,, mbtn)
Sleep 1
If MouseInRect(mx, my, tb.x, tb.y, tb.w) And mbtn = 1 Then
If TUI_Mode = 0 Then tb.CPos = mx + 1 - tb.x Else tb.CPos = (mx - 8 * tb.x) \ 8
If tb.Cpos > Len(tb.text) Then tb.CPos = Len(tb.text)
Return 1
Else
Return 0
End If
End Function
Function ListBox_New(x As Integer, y As Integer, w As Integer, h As Integer) As ListBox
'Neue Listbox definieren und zeichnen (Textfarbe schwarz, Hintergrundfarbe weiß)
Dim As ListBox lb
Dim As Integer i
lb.x = x
lb.y = y
lb.w = w
lb.h = h
Select Case TUI_Mode
Case 0
lb.TextColor = 0
lb.BackColor = 15
lb.HighlightTextColor = 15
lb.HighlightBackColor = 3
Case 1
lb.TextColor = black
lb.BackColor = white
lb.HighlightTextColor = white
lb.HighlightBackColor = cyan
End Select
For i = 0 To 100
lb.buffer(i) = ""
Next
lb.imax = - 1
lb.index = - 1
Color lb.TextColor, lb.BackColor
For i = 0 To h - 1
Locate y + i, x
Print Space(w)
Next
Return lb
End Function
Sub ListBox_Add(ByRef lb As ListBox, item As String)
'Einen Eintrag hizufügen - maximal sind lb.h Einträge möglich (Index 0 bis h - 1)
Color lb.TextColor, lb.BackColor
If lb.imax < lb.h - 1 Then
lb.imax = lb.imax + 1
lb.buffer(lb.imax) = item
Locate lb.y + lb.imax, lb.x
Print Left(item, lb.w);
End If
End Sub
Sub ListBox_Clear(ByRef lb As ListBox)
'Alle Einträge in der Listbox löschen
Dim As Integer i
For i = 0 To lb.imax
lb.buffer(i) = ""
Next
lb.index = -1
lb.imax = -1
Color lb.TextColor, lb.BackColor
For i = 0 To lb.h
Locate lb.y + i, lb.x
Print Space(lb.w);
Next
End Sub
Function ListBox_Event(ByRef lb As ListBox) As Integer
'Gibt 1 zurück, wenn ein Eintrag angeklickt wurde und speichert den zugehörigen
'Index als lb.index
Dim As Integer i, index, mx, my, mb, result
Getmouse(mx, my,, mb)
Sleep 1
For i = 0 To lb.imax
If MouseInRect(mx, my, lb.x, lb.y + i, lb.w) And mb = 1 Then
'Vorher markierten Index zurücksetzen:
If lb.index >= 0 Then
Color lb.TextColor, lb.BackColor
Locate lb.y + lb.index, lb.x
Print Space(lb.w)
Locate lb.y + lb.index, lb.x
Print Left(lb.buffer(lb.index), lb.w)
End If
'Neuen Index speichern, Eintrag hervorheben:
lb.index = i
Color lb.HighlightTextColor, lb.HighlightBackColor
Locate lb.y + i, lb.x
Print Space(lb.w)
Locate lb.y + i, lb.x
Print Left(lb.buffer(i), lb.w)
result = 1
Exit For
Else
result = 0
End If
Next
Return result
End Function
Function ListBox_GetIndex(lb As ListBox) As Integer
'Gibt den gewählten Index zurück
Return lb.index
End Function
Sub ListBox_SetIndex(ByRef lb As ListBox, index As Integer)
'Index der Listbox setzen
If index <= lb.imax And index >= 0 Then
'Vorher markierten Index zurücksetzen:
If lb.index >= 0 Then
Color lb.TextColor, lb.BackColor
Locate lb.y + lb.index, lb.x
Print Space(lb.w)
Locate lb.y + lb.index + 1, lb.x
Print Left(lb.buffer(lb.index), lb.w)
End If
'Neuen Index speichern, Eintrag hervorheben:
lb.index = index
Color lb.HighlightTextColor, lb.HighlightBackColor
Locate lb.y + index, lb.x
Print Space(lb.w)
Locate lb.y + index, lb.x
Print Left(lb.buffer(index), lb.w)
End If
End Sub
Function ListBox_GetItem(lb As ListBox, index As Integer) As String
'Gibt den zum Index zugehörigen Text zurück
If index >= 0 Then Return lb.buffer(index) Else Return ""
End Function
Function InputBox(x As Integer, y As Integer, w As Integer, Prompt As String, _
ByRef Text As String = "") As String
'Zweizeilige Inputbox gelb, gibt einen eingegebenen Text zurück.
'Prompt = Frage o.ä, Text = vorbelegter Text
Dim As TextBox tb
Dim As Button btn
Dim As Integer i
'Bildschirm speichern und Box zeichnen:
PCopy 0, 1
If TUI_Mode = 0 Then Color 0, 14 Else Color black, yellow
For i = 0 To 2
Locate y + i, x
Print Space(w)
Next
Locate y, x + 1
Print Left(Prompt, w - 2)
tb = TextBox_New(x + 1, y + 1, w - 8, text)
btn = Button_New(x + w - 6, y + 1, 4, "Ok")
'Event-Loop:
Do
If TextBox_Event(tb) Then TextBox_Edit(tb)
Loop Until Button_Event(btn)
'Bildschirm restaurieren und Ende
PCopy 1, 0
Return TextBox_GetText(tb)
End Function
Function MsgBox(x As Integer, y As Integer, w As Integer, Text As String, _
ButtonText0 As String = "Ok", ButtonText1 As String = "", _
ButtonText2 As String = "") As Integer
'Dreizeilige Messagebox gelb mit bis zu drei Buttons Nr. 0 bis 2 (von links nach
'rechts angeordnet). Rückgabewert ist die Nummer des gedrückten Buttons
Dim As Button btn0, btn1, btn2
Dim As Integer i, w0, w1, w2, result
'Bildschirm speichern und Box zeichnen:
PCopy 0, 1
If TUI_Mode = 0 Then Color 0, 14 Else Color black, yellow
For i = 0 To 2
Locate y + i, x
Print Space(w)
Next
Locate y, x + 1
Print Left(Text, w - 2)
'Buttons rechtsbündig plazieren:
If Len(ButtonText2) > 0 And Len(ButtonText1) > 0 And Len(ButtonText0) > 0 Then
'Alle drei Buttons:
w2 = Len(ButtonText2) + 2
w1 = Len(ButtonText1) + 2
w0 = Len(ButtonText0) + 2
btn2 = Button_New(x + w - (w2 + 1), y + 1, w2, ButtonText2)
btn1 = Button_New(btn2.x - (w1 + 1), y + 1, w1, ButtonText1)
btn0 = Button_New(btn1.x - (w0 + 1), y + 1, w0, ButtonText0)
ElseIF Len(ButtonText2) = 0 And Len(ButtonText1) > 0 And Len(ButtonText0) > 0 Then
'Button Nr. 0 und 1:
w1 = Len(ButtonText1) + 2
w0 = Len(ButtonText0) + 2
btn1 = Button_New(x + w - (w1 + 1), y + 1, w1, ButtonText1)
btn0 = Button_New(btn1.x - (w0 + 1), y + 1, w0, ButtonText0)
Else
w0 = Len(ButtonText0) + 2
btn0 = Button_New(x + w - (w0 + 1), y + 1, w0, ButtonText0)
End If
'Event-Loop:
result = -1
Do
If Button_Event(btn0) Then result = 0
If Button_Event(btn1) Then result = 1
If Button_Event(btn2) Then result = 2
Loop Until result >= 0
'Bildschirm restaurieren und Ende
PCopy 1, 0
Return result
End Function
Sub DrawSlider(tb As TrackBar, value As Integer)
'Zeichnet die Markierung (Slider) in einem Trackbar an die dem Wert "value"
'entsprechenden Position (Hilfsprozedur).
'Minimale Slider-Position = tb.x
'Maximale Slider-Position: tb.x + tb.w - 1
Dim As Integer xpos
xpos = tb.x + (tb.value - tb.minvalue) * (tb.w - 1) / (tb.maxvalue - tb.minvalue)
Color tb.SliderColor, tb.BackColor
Locate tb.y, tb.x
Print Space(tb.w)
Locate tb.y, xpos
Print Chr(219)
End Sub
Function TrackBar_New(x As Integer, y As Integer, w As Integer) As Trackbar
'Neuen horizontalen Trackbar definieren und zeichnen.
Dim As TrackBar tb
tb.x = x
tb.y = y
tb.w = w
Select Case TUI_Mode
Case 0
tb.SliderColor = 8
tb.BackColor = 15
Case 1
tb.SliderColor = darkgrey
tb.BackColor = white
End Select
tb.minvalue = 0
tb.maxvalue = 100
tb.value = tb.minvalue
DrawSlider(tb, tb.value)
Return tb
End Function
Sub TrackBar_SetRange(ByRef tb As TrackBar, minvalue As Integer, maxvalue As Integer)
'Wertebereich eines Trackbar setzen
tb.minvalue = minvalue
tb.maxvalue = maxvalue
End Sub
Sub TrackBar_SetValue(ByRef tb As TrackBar, value As Integer)
'Den Wert eines Trackbars setzen und den Slider entsprechend zeichnen
tb.value = value
DrawSlider(tb, value)
End Sub
Function TrackBar_Event(ByRef tb As TrackBar) As Integer
'Gibt 1 zurück, wenn der Trackbar angeklickt wurde, setzt den Slider an die
'betreffende Position und aktualisiert den Wert des Trackbar.
Dim As Integer mx, my, mb, value
Getmouse(mx, my,, mb)
Sleep 1
If MouseInRect(mx, my, tb.x, tb.y, tb.w) And mb = 1 Then
Select Case TUI_Mode
Case 0
value = tb.minvalue + (mx + 1 - tb.x) * (tb.maxvalue - tb.minvalue) / (tb.w - 1)
TrackBar_SetValue(tb, value)
Case 1
Screenlock
value = tb.minvalue + (mx \ 8 - tb.x + 1) * (tb.maxvalue - tb.minvalue) / (tb.w - 1)
TrackBar_SetValue(tb, value)
Screenunlock
End Select
Return 1
Else
Return 0
End if
End Function
Function TrackBar_GetValue(tb As Trackbar) As Integer
'Gibt den aktuellen Wert eines Trackbar zurück
Return tb.value
End Function
Sub DrawBar(pb As ProgressBar, value As Integer)
'Zeichnet den Balken in einem Progressbar entsprechend dem Wert. Hilfsprozedur.
'Minimaler Wert: pb.x
'maximalert Wert: pb.x - 1
Dim As Integer xpos
xpos = pb.x + (pb.value - pb.minvalue) * (pb.w - 1) / (pb.maxvalue - pb.minvalue)
Color pb.BarColor, pb.BackColor
Locate pb.y, pb.x
Print Space(pb.w)
Locate pb.y, pb.x
Print String(xpos - 1, Chr(219));
End Sub
Function ProgressBar_New(x As Integer, y As Integer, w As Integer) As ProgressBar
'Neuen horizontalen Progressbar definieren und zeichnen.
Dim As ProgressBar pb
pb.x = x
pb.y = y
pb.w = w
Select Case TUI_Mode
Case 0
pb.BarColor = 8
pb.BackColor = 15
Case 1
pb.BarColor = darkgrey
pb.BackColor = white
End Select
pb.minvalue = 0
pb.maxvalue = 100
pb.value = pb.minvalue
DrawBar(pb, 0)
Return pb
End Function
Sub ProgressBar_SetRange(ByRef pb As ProgressBar, minvalue As Integer, maxvalue As Integer)
'Wertebereich eines Progressbar setzen
pb.minvalue = minvalue
pb.maxvalue = maxvalue
End Sub
Sub ProgressBar_SetValue(ByRef pb As ProgressBar, value As Integer)
'Wert eines Progressbar setzen und den Balken zeichnen
If value >= pb.minvalue And value <= pb.maxvalue Then
pb.value = value
DrawBar(pb, value)
End If
End Sub