Okay, just for fun, here is my lib cut down to a single button type, with no built in demo. Much fewer lines, of course...
I removed the tab feature, as it also added quite a few extra lines. This one has the input box as well.
Pete
Code: (Select All)
_Title "Roll The Dice by SierraKen"
Dim As Single lb, mb, rb, mw, my, mx
ReDim Shared fld$(0), button$(0), mRow$(0)
ReDim Shared x(0), y(0), y1(0), y2(0), x1(0), x2(0), fnx(0), btnmap(0), FType(0)
Type fields_and_buttons
a As String
initiate As Integer
fld As Integer
nof As Integer
nob As Integer
style As Integer
BSelect As Integer
Bg As Integer ' Begin button colors.
BBdr As Integer
BBdrHover As Integer
BBdrFlash As Integer
BFg As Integer
BBg As Integer
BBg1 As Integer
BHvrFg As Integer
BHvrBk As Integer
End Type
Dim fb As fields_and_buttons
fb.BBdr = 8: fb.BBdrHover = 1: fb.BBdrFlash = 9: fb.BFg = 15: fb.BBg = 3: fb.BBg1 = 1: fb.BHvrFg = 3: fb.BHvrBk = 1: fb.Bg = 5
Palette 5, 63
Palette 7, 63
Color 0, 7: Cls
Randomize Timer
Do
Do
defaultInput$ = " "
msg$ = "How many sides is your dice (3-100)?": GoSub myinput
If _Trim$(result$) = "" Then End
num = Val(result$)
If num < 3 Or num > 100 Or num <> Int(num) Then
msg$ = "Pick only between 3 and 100.": GoSub pete
Exit Do
End If
dice = Int(Rnd * num) + 1
dice$ = Str$(dice)
msg$ = "Your roll: " + dice$: GoSub pete
Loop
Loop
myinput:
result$ = ""
popup 3, 3, 8, 62 ' Top, Left, Height, Width
Locate 4, 5: Print msg$;
Color 15, 0
Locate 6, 5: Print Chr$(221) + Space$(34) + Chr$(222);
Locate 6, 6, 1, 7, 7
fb.a = " OK ": fb_text_buttons fb, 4, 51
fb.a = " Cancel ": fb_text_buttons fb, 7, 51
Do
MyMouse_and_Keyboard lb, mb, rb, my, mx, mw, shift%, AltStatus%, AltToggle%, alt%, ctrl%, clkcnt, drag, k&, b$, autokey$
fb_main fb, button$(), mx, my, lb
If b$ >= "0" And b$ <= "9" Or b$ = Chr$(8) Then
If Left$(result$, 1) = "0" And b$ <> Chr$(8) Or Len(result$) = 3 And b$ <> Chr$(8) Then b$ = ""
If b$ = Chr$(8) Then
If Len(result$) > 0 Then
result$ = Mid$(result$, 1, Len(result$) - 1)
Locate , Pos(0) - 1: Print " ";: Locate , Pos(0) - 1
End If
Else
Print b$;
result$ = result$ + b$
End If
End If
If fb.BSelect Or b$ = Chr$(13) And Len(result$) Then Exit Do
Loop
If fb.BSelect = 2 Then System
GoSub renew
Return
pete:
popup 6, 19, 9, 32 ' Top, Left, Height, Width.
Locate 7, 19 - 1 + (32 - Len(msg$)) \ 2, 0: Print msg$;
fb.a = " OK ": fb_text_buttons fb, 10, 30
Do
MyMouse_and_Keyboard lb, mb, rb, my, mx, mw, shift%, AltStatus%, AltToggle%, alt%, ctrl%, clkcnt, drag, k&, b$, autokey$
fb_main fb, button$(), mx, my, lb
If fb.BSelect Or b$ = Chr$(13) Then Exit Do
Loop
GoSub renew
renew:
_AutoDisplay
PCopy 1, 0
Palette 7, 63
fb.initiate = 0: fb.nof = 0
ReDim fld$(0), button$(0), mRow$(0)
ReDim x(0), y(0), y1(0), y2(0), x1(0), x2(0), fnx(0), btnmap(0), FType(0)
Return
Sub MyMouse_and_Keyboard (lb, mb, rb, my, mx, mw, shift%, AltStatus%, AltToggle%, alt%, ctrl%, clkcnt, drag, k&, b$, autokey$)
Dim As Integer oldmw
Static As Integer oldmy, oldmx, mwy, oldmwy
Static z1 As Single
_Limit 60
If AltStatus% Then AltStatus% = 0
If Len(autokey$) Then
b$ = Mid$(autokey$, 1, InStr(autokey$ + ",", ",") - 1)
autokey$ = Mid$(autokey$, InStr(autokey$ + ",", ",") + 1)
Exit Sub
Else
k& = _KeyHit
If k& = 100307 Or k& = 100308 Then
AltStatus% = -1
AltToggle% = 1 - AltToggle%
Exit Sub
End If
If k& > 0 Then
b$ = MKI$(k&)
If Mid$(b$, 2, 1) = Chr$(135) Then b$ = "" ' Keys like like Shift, Ctrl, and Alt.
If Right$(b$, 1) = Chr$(0) Then b$ = Left$(b$, 1)
Else
b$ = ""
End If
End If
If z1 Then If Abs(Timer - z1) > .25 Then z1 = 0: clkcnt = 0
If lb > 0 Then
If lb = 1 Then
lb = -1
Else
lb = 0
End If
End If
If rb > 0 Then If rb = 1 Then rb = -1 Else rb = 0
If mb > 0 Then If mb = 1 Then mb = -1 Else mb = 0
While _MouseInput
mwy = mwy + _MouseWheel
Wend
my = _MouseY
mx = _MouseX
If lb = -1 Then
If oldmy And oldmx <> mx Or oldmy And oldmy <> my Then
If mx <> oldmx Then drag = Sgn(mx - oldmx) ' Prevent zero which can occur if mouse moves off row when being dragged horizontally.
End If
End If
If drag = 0 Then
If mwy <> oldmw Then
mw = Sgn(mwy - oldmwy): mwy = 0
Else
mw = 0
End If
oldmwy = mwy
If _KeyDown(100303) Or _KeyDown(100304) Then shift% = -1 Else If shift% Then shift% = 0
If _KeyDown(100305) Or _KeyDown(100306) Then ctrl% = -1 Else If ctrl% Then ctrl% = 0
If _KeyDown(100307) Or _KeyDown(100308) Then alt% = -1 Else If alt% Then alt% = 0
End If
If lb = -1 And _MouseButton(1) = 0 Then
lb = 2: drag = 0: hover = 0
ElseIf rb = -1 And _MouseButton(2) = 0 Then
rb = 2
ElseIf mb = -1 And _MouseButton(3) = 0 Then
mb = 2
End If
If _MouseButton(1) Then
If lb = 0 Then
lb = 1: z1 = Timer
clkcnt = clkcnt + 1
End If
ElseIf _MouseButton(2) And rb = 0 Then
rb = 1
ElseIf _MouseButton(3) And mb = 0 Then
mb = 1
End If
oldmy = my: oldmx = mx
End Sub
Sub fb_main (fb As fields_and_buttons, button$(), mx, my, lb)
Static prev_fld
s1 = CsrLin: s2 = Pos(0)
b_hover = 0: fb.fld = 0: fb.BSelect = 0
For i = 1 To fb.nof ' number of fields.
If my >= y1(i) And my <= y2(i) And mx >= x1(i) And mx <= x2(i) Then
fb.fld = i
b_hover = btnmap(fb.fld)
Exit For
End If
Next
If prev_fld And prev_fld <> fb.fld Then ' Remove button hover effect when present.
s1 = CsrLin: s2 = Pos(0)
c1 = _DefaultColor: c2 = _BackgroundColor
i = prev_fld
j = Len(button$(btnmap(i)))
Color fb.BBdr, fb.Bg
Locate y1(i), x1(i): Print Chr$(218) + String$(j, 196) + Chr$(191)
Locate , x1(i): Print Chr$(179);: Locate , Pos(0) + j: Print Chr$(179)
Locate , x1(i): Print Chr$(192) + String$(j, 196) + Chr$(217);
prev_fld = 0
force = -1 ' Local variable to force any tab button field to remain highlighted.
Color c1, c2
Locate s1, s2
End If
If b_hover Then ' Add hover effect.
prev_fld = fb.fld
h = lb
q = fb.fld
l = b_hover
Select Case h
Case 0, -1, 1 ' Static or color change if button clicked.
s1 = CsrLin: s2 = Pos(0)
c1 = _DefaultColor: c2 = _BackgroundColor
j = Len(button$(l))
If Abs(h) = 1 Then Color fb.BBdrFlash, fb.Bg Else Color fb.BBdrHover, fb.Bg
Locate y1(q), x1(q): Print Chr$(218) + String$(j, 196) + Chr$(191)
Locate , x1(q): Print Chr$(179);: Locate , Pos(0) + j: Print Chr$(179)
Locate , x1(q): Print Chr$(192) + String$(j, 196) + Chr$(217);
Color c1, c2
Locate s1, s2
Case 2 ' Button selection completed.
fb.BSelect = l
End Select
End If
Locate s1, s2
_Display
End Sub
Sub fb_text_buttons (fb As fields_and_buttons, y, x)
Static btnnbr
If fb.initiate = 0 Then
fb.initiate = 1
btnnbr = 0
End If
s1 = CsrLin: s2 = Pos(0)
c1 = _DefaultColor: c2 = _BackgroundColor
j = Len(fb.a)
fb.nof = fb.nof + 1: fb.nob = fb.nob + 1
ReDim _Preserve fld$(fb.nof), FType(fb.nof), btnmap(fb.nof)
FType(fb.nof) = 5
btnnbr = btnnbr + 1
btnmap(fb.nof) = btnnbr
fld$(fb.nof) = Space$(25)
ReDim _Preserve y1(fb.nof), x1(fb.nof), y2(fb.nof), x2(fb.nof), button$(fb.nof)
button$(btnnbr) = String$(j, 0) ' Fill any spaces with the null character.
Mid$(button$(btnnbr), 1 + (j - Len(_Trim$(fb.a))) \ 2) = _Trim$(fb.a)
Color fb.BBdr, fb.Bg
Locate y - 1, x - 1: fb.a = Chr$(218) + String$(j, 196) + Chr$(191): fb_map fb, 6
Locate y, x - 1: fb.a = Chr$(179): fb_map fb, 0
Locate , Pos(0) + j: fb.a = Chr$(179): fb_map fb, 0
Locate y + 1, x - 1: fb.a = Chr$(192) + String$(j, 196) + Chr$(217): fb_map fb, 7
Locate y, x: fb.a = button$(btnnbr): fb_map fb, 0
Color c1, c2
Locate s1, s2
End Sub
Sub fb_map (fb As fields_and_buttons, mapid)
Static mapfld As Integer
If UBound(mRow$) = 0 Then
ReDim mRow$(_Height)
mapfld = 96
End If
Select Case mapid
Case 6 ' Text or hybrid button top.
mapfld = mapfld + 1 ' Advance.
y1(mapfld - 96) = CsrLin: x1(mapfld - 96) = Pos(0)
Case 7 ' Text or hybrid button bottom.
y2(mapfld - 96) = CsrLin: x2(mapfld - 96) = Pos(0) + Len(fb.a)
End Select
Print fb.a;
End Sub
Sub popup (m.top, m.left, m.height, m.width)
pop = 1
c.MenuBdrFg = 0
c.MenubrdBg = 5
c.MenuSdwFg = 6
c.MenuSdwBg = 0
c.MenuFg = 0
c.MenuBg = 5
spacing = 1
PCopy 0, 1
Palette 7, 7
Palette 6, 58
Locate m.top - pop, m.left - pop
For h = 1 To m.height
If h = 1 Then
Color c.MenuBdrFg, c.MenubrdBg
Print Chr$(218) + String$(m.width - 2, 196) + Chr$(191)
j = CsrLin
For i = 1 To m.height - 2
If CsrLin < _Height Then Locate j, m.left - pop Else Locate , m.left - pop
Color c.MenuBdrFg, c.MenubrdBg: Print Chr$(179);
Color c.MenuBdrFg, c.MenubrdBg: Print Space$(m.width - 2);
Color c.MenuBdrFg, c.MenubrdBg: Print Chr$(179);
j = j + 1
Next
Locate j, m.left - pop
Color c.MenuBdrFg, c.MenubrdBg: Print Chr$(192) + String$(m.width - 2, 196) + Chr$(217);
If pop Then ' Shadow effect.
Color c.MenuSdwFg, c.MenuSdwBg ' Shadow below.
Locate CsrLin + 1, m.left - pop + 2
For i = 1 To m.width
j = Screen(CsrLin, Pos(0))
Print Chr$(j);
Next
Locate m.top - pop + 1 ' Shadow to the right.
For i = 1 To m.height - 1
Locate , m.left - pop + m.width
j = Screen(CsrLin, Pos(0))
Print Chr$(j);
j = Screen(CsrLin, Pos(0))
Print Chr$(j)
Next
End If
End If
Color c.MenuFg, c.MenuBg
Locate m.top - pop + h + (h - 1) * spacing, m.left - pop + 2 - 1
Next h
End SubI removed the tab feature, as it also added quite a few extra lines. This one has the input box as well.
Pete