Posts: 559
Threads: 97
Joined: Apr 2022
Reputation:
45
Recently QB64pe added the InputBox$ and MessageBox popups, so today I decided to have some fun with it and make a dice roller. The first popup asks how many sides your dice is, from 3 to 100. Then it rolls and another popup says the outcome. I know this is very primary random stuff, but I thought it would be a good example for the popups.
This is also the first time I've used both the input and the message boxes in one QB64pe app.  Years ago, when I tried out someone's GUI framework for QB64, I made a very similar dice roller with forms and buttons. I wonder if that GUI from back then still works?
Anyway, here you go, enjoy.
Code: (Select All)
_Title "Roll The Dice by SierraKen"
Randomize Timer
Do
Do
title$ = "Roll The Dice"
defaultInput$ = " "
message$ = "How many sides is your dice (3-100)?"
result$ = _InputBox$(title$, message$, defaultInput$)
If _Trim$(result$) = "" Then End
num = Val(result$)
If num < 3 Or num > 100 Or num <> Int(num) Then
_MessageBox "Roll The Dice", "Pick only between 3 and 100."
Exit Do
End If
dice = Int(Rnd * num) + 1
dice$ = Str$(dice)
_MessageBox "Roll The Dice", "Your roll: " + dice$
Loop
Loop
Posts: 4,129
Threads: 185
Joined: Apr 2022
Reputation:
242
It was probably InForm that you tried.
b = b + ...
Posts: 559
Threads: 97
Joined: Apr 2022
Reputation:
45
Yes, that's what it was, thanks.
Posts: 559
Threads: 97
Joined: Apr 2022
Reputation:
45
Does anyone know any possible way to have the messagebox and inputbox$ come up without the windows sound, without turning your windows sounds or speakers off?
Posts: 657
Threads: 101
Joined: Apr 2022
Reputation:
22
02-16-2025, 11:20 PM
(This post was last modified: 02-16-2025, 11:21 PM by PhilOfPerth.)
(02-16-2025, 10:29 PM)SierraKen Wrote: Does anyone know any possible way to have the messagebox and inputbox$ come up without the windows sound, without turning your windows sounds or speakers off?
For Windows, Open ControlPanel, got to Hardware and Sound/Sound/Change System Sounds/Asterisk, then below, select None
Posts: 559
Threads: 97
Joined: Apr 2022
Reputation:
45
Thanks Phil, but I said without turning your windows sounds off. It's just hard to tell all the users to do that.
Posts: 2,847
Threads: 340
Joined: Apr 2022
Reputation:
250
These boxes are so simple, just make your own. 
Posts: 657
Threads: 101
Joined: Apr 2022
Reputation:
22
(02-17-2025, 08:15 PM)SierraKen Wrote: Thanks Phil, but I said without turning your windows sounds off. It's just hard to tell all the users to do that.
Yeah, I guess so. Sorry, wrong again! 
Posts: 2,458
Threads: 248
Joined: Apr 2022
Reputation:
125
02-18-2025, 12:25 AM
(This post was last modified: 02-18-2025, 04:21 AM by Pete.)
Since I was going in this direction, next. Here is an early continued WIP of the mouse with fileds and buttons project, with a popup added...
Code: (Select All)
_Title "Roll The Dice by SierraKen"
Dim Shared overlay, demo As Integer
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
tabmax As Integer
tb As Integer
SimClick As Integer
fld As Integer
nof As Integer
nob As Integer
mapping 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
BFgFlash As Integer
BBgFlash As Integer
BHybFg As Integer
BHybBg1 As Integer
BHybBg2 As Integer
BHybBdr1 As Integer
BHybBdr2 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.BFgFlash = 1: fb.BBgFlash = 3
fb.Bg = 5: fb.BHybBg1 = 6: fb.BHybFg = 6: fb.BHybBg2 = 7: fb.BHybBdr1 = 0: fb.BHybBdr2 = 255
If fb.style = 0 Then fb.style = 2
Palette 5, 63
Palette 6, 56
Palette 7, 63
Color 0, 7: Cls
Randomize Timer
Do
Do
defaultInput$ = " "
message$ = "How many sides is your dice (3-100)?"
result$ = _InputBox$(title$, message$, defaultInput$)
If _Trim$(result$) = "" Then End
num = Val(result$)
If num < 3 Or num > 100 Or num <> Int(num) Then
Rem _MessageBox "Roll The Dice", "Pick only between 3 and 100."
msg$ = "Pick only between 3 and 100.": GoSub pete
Exit Do
End If
dice = Int(Rnd * num) + 1
dice$ = Str$(dice)
Rem _MessageBox "Roll The Dice", "Your roll: " + dice$
msg$ = "Your roll: " + dice$: GoSub pete
Loop
Loop
End
pete:
popup 6, 19, 9, 32 ' Top, Left, Height, Width.
Locate 7, 19 - 1 + (32 - Len(msg$)) \ 2: print_array msg$
If fb.style = 5 Then
fb.a = "Activate": fb_text_buttons fb, 11, 30
Else
fb.a = " OK ": fb_text_buttons fb, 10, 30
End If
Do
MyMouse_and_Keyboard lb, mb, rb, my, mx, mw, shift%, AltStatus%, AltToggle%, alt%, ctrl%, clkcnt, drag, k&, b$, autokey$
fb_main fb, b$, button$(), mx, my, lb
If fb.BSelect Then Exit Do
Loop
_AutoDisplay
PCopy 1, 0
Palette 7, 63
fb.initiate = 0
fb.tb = 0: fb.tabmax = 0: fb.nof = 0: fb.nob = 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 print_array (a$)
s1 = CsrLin: s2 = Pos(0)
Print a$;
Locate s1, s2
End Sub
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, b$, button$(), mx, my, lb)
Static prev_fld, HtmlBtn
s1 = CsrLin: s2 = Pos(0)
b_hover = 0: fb.fld = 0: fb.BSelect = 0
If fb.mapping Then
If Len(mRow$(my)) Then
i = Asc(Mid$(mRow$(my), mx, 1))
If i > 96 Then
fb.fld = i - 96
If FType(fb.fld) = 5 Then b_hover = btnmap(fb.fld)
End If
End If
Else
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
Select Case FType(i)
Case 1
fb.fld = i
Case 5
fb.fld = i
b_hover = btnmap(fb.fld)
Exit For
End Select
End If
Next
End If
If lb = 2 And FType(fb.fld) = 1 Then
If FType(fb.tb) = 5 Then h = 1: fb_button_tab fb, h, HtmlBtn ' Unhighlight a tab highighted button.
If FType(fb.tb) = 1 Then
If demo Then Locate , Pos(0) + 2, 1, 7, 1: s1 = CsrLin: s2 = Pos(0)
End If
fb.tb = fb.fld - 1
b$ = Chr$(9)
End If
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)))
Select Case fb.style
Case 1 'Single line button with blank border.
Color fb.BBg1, fb.Bg
Locate y1(i) - 1, x1(i): Print String$(j, 220);
Locate y1(i) + 1, x1(i): Print String$(j, 223);
Color fb.BFg, fb.BBg1
Locate y1(i), x1(i): Print button$(btnmap(i));
Case 2 ' Text button with line border.
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);
Case 3 ' Text hybrid button with graphics line border.
j = Len(button$(btnmap(i)))
k = btnmap(i)
_Dest overlay
Line (8 * (x(k) - 1) + 2, 16 * (y(k) - 1) + 7 + 2)-((j + 2) * 8 + 8 * (x(k) - 1) - 2, 16 * 2 + 16 * (y(k) - 1) + 7 - 2), _RGB32(155, 155, 155), B
Line (8 * (x(k) - 1), 16 * (y(k) - 1) + 7)-((j + 2) * 8 + 8 * (x(k) - 1), 16 * 2 + 16 * (y(k) - 1) + 7), _RGB32(fb.BHybBdr1, fb.BHybBdr1, fb.BHybBdr1), B
Line (8 * (x(k) - 1) + 8, 16 * (y(k) - 1) + 15)-((j + 1) * 8 + 8 * (x(k) - 1), y(k) * 16 + 15), _RGB32(fb.BHybBdr2, fb.BHybBdr2, fb.BHybBdr2), B
Overlay_Hardware = _CopyImage(overlay, 33)
_PutImage (0, 0), Overlay_Hardware
_FreeImage Overlay_Hardware
_Dest 0
Color fb.BHybFg, fb.BHybBg2
Locate y1(i) + 1, x1(i) + 1: Print button$(btnmap(i));
End Select
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 fb.tabmax And b$ = Chr$(9) Then
If fb.tb = fb.tabmax Then ' Redo cycle.
If FType(fb.tb) = 5 Then
h = 1: fb_button_tab fb, h, HtmlBtn ' Remove tab highlighted button in last field.
End If
fb.tb = 0: HtmlBtn = 0
Else
If FType(fb.tb + 1) = 5 Then
If FType(fb.tb) = 5 Then
h = 1: fb_button_tab fb, h, HtmlBtn
End If
fb.tb = fb.tb + 1 ' Note: Button will be highlighted at end of subroutine.
HtmlBtn = 0
force = 1: ' Local variable to force any tab button field to remain highlighted.
Else
fb.tb = fb.tb + 1 ' Increase tab field for text / non-button fields.
i = Val(Mid$(fld$(fb.tb), 6, 5))
j = Val(Mid$(fld$(fb.tb), 16, 5)) + 1
Locate y1(fb.tb), fnx(fb.tb)
If demo Then Locate , Pos(0) + 2, 1, 7, 1
s1 = CsrLin: s2 = Pos(0)
End If
End If
End If
If fb.tb Then
If b$ = Chr$(13) Then
If FType(fb.tb) = 5 Then
fb.SimClick = 1 ' Simulate a left button click.
End If
End If
If FType(fb.tb) = 1 Then
Locate , , 1
Else
Locate , , 0
End If
End If
If b_hover Or fb.SimClick Then ' Add hover effect.
If fb.SimClick Then
h = fb.SimClick
If h = -1 Then h = 0
l = btnmap(fb.tb)
q = fb.tb
Else
prev_fld = fb.fld
h = lb
q = fb.fld
l = b_hover
End If
If demo Then
Select Case l
Case 1, 2: fb.style = 1
Case 3, 4: fb.style = 2
Case 5, 6: fb.style = 3
Case 7, 8: fb.style = 4
Case 9, 10: fb.style = 5
End Select
End If
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))
Select Case fb.style
Case 1 'Single line button with blank border remover hover.
If Abs(h) = 1 Then Color fb.BBgFlash, fb.Bg Else Color fb.BHvrFg, fb.Bg
Locate y1(q) - 1, x1(q): Print String$(j, 220);
Locate y1(q) + 1, x1(q): Print String$(j, 223);
If Abs(h) = 1 Then Color fb.BFgFlash, fb.BBgFlash Else Color fb.BFg, fb.BBg
Locate y1(q), x1(q): Print button$(l);
Case 2 ' Text button with line border remove hover.
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);
Rem Locate y1(q) + 1, x1(q) + 1: Print button$(l);
Case 3 ' Text hybrid button with graphics line border remove hover.
j = Len(button$(l))
k = btnmap(q)
If Abs(h) = 1 Then Color fb.Bg, fb.BHybFg Else Color fb.BHybFg, fb.BHybBg2
Locate y1(q) + 1, x1(q) + 1: Print button$(l);
_Dest overlay
Line (8 * (x(k) - 1) + 2, 16 * (y(k) - 1) + 7 + 2)-((j + 2) * 8 + 8 * (x(k) - 1) - 2, 16 * 2 + 16 * (y(k) - 1) + 7 - 2), _RGB32(0, 155, 155), B
Overlay_Hardware = _CopyImage(overlay, 33)
_PutImage (0, 0), Overlay_Hardware
_FreeImage Overlay_Hardware
_Dest 0
End Select
Color c1, c2
Locate s1, s2
Case 2 ' Button selection completed.
fb.BSelect = l
fb.SimClick = 0
End Select
If fb.SimClick = -1 Then fb.SimClick = 2
If fb.SimClick = 1 Then fb.SimClick = -1
End If
If demo Or fb.style = 4 Then
If demo Then i2 = 7: i3 = 8 Else i2 = 1: i3 = fb.nob
For k = i2 To i3
j = Len(button$(k)): a$ = " " + button$(k) + " "
HTMLBStatic = fb_gfx_hyb_hw(j * 8, 2 * 16, 170, 170, 170, -9, -9, -1, Mid$(a$, 1, j))
HTMLBHover = fb_gfx_hyb_hw(j * 8, 2 * 16, 200, 200, 200, -8, -7, -1, Mid$(a$, 1, j))
HTMLBPress = fb_gfx_hyb_hw(j * 8, 2 * 16, 200, 200, 200, -1, -1, -1, Mid$(a$, 1, j))
Overlay_Hardware = _CopyImage(overlay, 33)
_PutImage (0, 0), Overlay_Hardware
If HtmlBtn = k And lb = 0 Then
_PutImage ((x(k) - 1) * 8, (y(k) - 1) * 16 + 8), HTMLBHover
Else
If lb = 0 And b_hover = k Then
_PutImage ((x(k) - 1) * 8, (y(k) - 1) * 16 + 8), HTMLBHover
ElseIf Abs(lb) = 1 And b_hover = k Then
_PutImage ((x(k) - 1) * 8, (y(k) - 1) * 16 + 8), HTMLBPress
Else
_PutImage ((x(k) - 1) * 8, (y(k) - 1) * 16 + 8), HTMLBStatic
End If
End If
_FreeImage HTMLBHover
_FreeImage HTMLBPress
_FreeImage HTMLBStatic
_FreeImage Overlay_Hardware
Next
_Dest 0
End If
If demo Or fb.style = 5 Then
If demo Then i2 = 9: i3 = 10 Else i2 = 1: i3 = fb.nob
For k = i2 To i3
_Dest overlay
Overlay_Hardware = _CopyImage(overlay, 33)
_PutImage (0, 0), Overlay_Hardware
If HtmlBtn = k And lb = 0 Then
img& = _LoadImage(button$(k) + "-hover.png", 32)
_PutImage ((x(k) - 1) * 8 + 4, (y(k) - 1) * 16), img&
Else
If lb = 0 And b_hover = k Then
img& = _LoadImage(button$(k) + "-hover.png", 32)
_PutImage ((x(k) - 1) * 8 + 4, (y(k) - 1) * 16), img&
ElseIf Abs(lb) = 1 And b_hover = k Then
img& = _LoadImage(button$(k) + "-active.png", 32)
_PutImage ((x(k) - 1) * 8 + 4, (y(k) - 1) * 16), img&
Else
img& = _LoadImage(button$(k) + "-static.png", 32)
_PutImage ((x(k) - 1) * 8 + 4, (y(k) - 1) * 16), img&
End If
End If
_FreeImage img&
_FreeImage Overlay_Hardware
Next
_Dest 0
End If
If prev_fld <> b_hover And prev_fld = fb.fld Or force Then
If FType(fb.tb) = 5 Then
If b_hover = 0 Or force Then h = 2: fb_button_tab fb, h, HtmlBtn
End If
End If
If demo Then
q1 = CsrLin: q2 = Pos(0)
Color 15, 0
Locate 2, 66 - 7: Print b_hover;: Locate 4, 71 - 5
If b_hover Then Print fb.style; Else j = 0: Print j;
Locate 6, 63 - 6: Print fb.tb;
Color 0, 5
Locate q1, q2
End If
Locate s1, s2
_Display
End Sub
Sub fb_button_tab (fb As fields_and_buttons, h, HtmlBtn)
Dim As Integer i, j, k
s1 = CsrLin: s2 = Pos(0)
temp = fb.style
If demo Then
Select Case btnmap(fb.tb)
Case 1, 2: fb.style = 1
Case 3, 4: fb.style = 2
Case 5, 6: fb.style = 3
Case 7, 8: fb.style = 4
Case 9, 10: fb.style = 5
End Select
End If
i = fb.tb
j = Len(button$(btnmap(i)))
k = btnmap(i)
Select Case h
Case 1: ' Remove tab button highlighting.
Select Case fb.style
Case 1 ' Single line button with blank border.
Color fb.BBg1, fb.Bg
Locate y1(i) - 1, x1(i): Print String$(j, 220);
Locate y1(i) + 1, x1(i): Print String$(j, 223);
Color fb.BFg, fb.BBg1
Locate y1(i), x1(i): Print button$(btnmap(fb.tb));
Case 2 ' Text button with line border.
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);
Case 3 ' Text hybrid button with graphics line border.
_Dest overlay
Line (8 * (x(k) - 1) + 2, 16 * (y(k) - 1) + 7 + 2)-((j + 2) * 8 + 8 * (x(k) - 1) - 2, 16 * 2 + 16 * (y(k) - 1) + 7 - 2), _RGB32(155, 155, 155), B
Line (8 * (x(k) - 1), 16 * (y(k) - 1) + 7)-((j + 2) * 8 + 8 * (x(k) - 1), 16 * 2 + 16 * (y(k) - 1) + 7), _RGB32(fb.BHybBdr1, fb.BHybBdr1, fb.BHybBdr1), B
Line (8 * (x(k) - 1) + 8, 16 * (y(k) - 1) + 15)-((j + 1) * 8 + 8 * (x(k) - 1), y(k) * 16 + 15), _RGB32(fb.BHybBdr2, fb.BHybBdr2, fb.BHybBdr2), B
Overlay_Hardware = _CopyImage(overlay, 33)
_PutImage (0, 0), Overlay_Hardware
_FreeImage Overlay_Hardware
_Dest 0
Color fb.BHybFg, fb.BHybBg2
Locate y1(i) + 1, x1(i) + 1: Print button$(btnmap(fb.tb));
Case 4 ' Graphics hybrid button.
HTMLBStatic = fb_gfx_hyb_hw(j * 8, 2 * 16, 170, 170, 170, -9, -9, -1, Mid$(a$, 1, j))
Overlay_Hardware = _CopyImage(overlay, 33)
_PutImage (0, 0), Overlay_Hardware
_PutImage ((x(k) - 1) * 8, (y(k) - 1) * 16 + 8), HTMLBStatic
_FreeImage HTMLBStatic
_FreeImage Overlay_Hardware
Case 5 ' HTML button.
_Dest overlay
Overlay_Hardware = _CopyImage(overlay, 33)
_PutImage (0, 0), Overlay_Hardware
img& = _LoadImage(button$(btnmap(i)) + "-static.png", 32)
_PutImage ((x(k) - 1) * 8 + 4, (y(k) - 1) * 16), img&
_FreeImage img&
_FreeImage Overlay_Hardware
_Dest 0
End Select
Case 2 ' Tab button highlighting.
Select Case fb.style
Case 1 ' Tab highlight single line button with blank border.
Color fb.BHvrFg, fb.Bg
Locate y1(i) - 1, x1(i): Print String$(j, 220);
Locate y1(i) + 1, x1(i): Print String$(j, 223);
Color fb.BFg, fb.BBg
Locate y1(i), x1(i): Print button$(btnmap(fb.tb));
Case 2 ' Tab highlight text button with line border.
Color fb.BBdrHover, 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);
Case 3 ' Text hybrid button with graphics line border.
Color fb.BHybFg, fb.BHybBg2
Locate y1(i) + 1, x1(i) + 1: Print button$(btnmap(fb.tb));
_Dest overlay
Line (8 * (x(k) - 1) + 2, 16 * (y(k) - 1) + 7 + 2)-((j + 2) * 8 + 8 * (x(k) - 1) - 2, 16 * 2 + 16 * (y(k) - 1) + 7 - 2), _RGB32(0, 155, 155), B
Overlay_Hardware = _CopyImage(overlay, 33)
_PutImage (0, 0), Overlay_Hardware
_FreeImage Overlay_Hardware
_Dest 0
Case 4, 5
HtmlBtn = btnmap(fb.tb)
End Select
End Select
Locate s1, s2
fb.style = temp
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
If demo Or fb.style >= 3 Then
overlay = _NewImage(_Width * _FontWidth, _Height * _FontHeight, 32)
End If
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: fb.tabmax = fb.tabmax + 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)
Select Case fb.style
Case 1 ' Single line button with blank border.
y = Abs(y)
Color fb.BFg, fb.BBg1: Locate y, x: fb.a = button$(btnnbr): fb_map fb, 5
Color fb.BBg1, fb.Bg: Locate y - 1, x: fb.a = String$(j, Chr$(220)): fb_map fb, 0
Locate y + 1, x: fb.a = String$(j, Chr$(223)): fb_map fb, 0
Case 2 ' Text button with line border.
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
Case 3 ' Text hybrid button with graphics line border.
i = btnnbr
j = Len(fb.a)
k = btnnbr
ReDim _Preserve x(btnnbr), y(btnnbr), button$(btnnbr)
y(k) = y - 1: x(k) = x - 1
button$(i) = String$(j, 0)
Mid$(button$(i), 1 + (j - Len(_Trim$(fb.a))) / 2) = _Trim$(fb.a)
Locate y - 1, x - 1: Color fb.BHybBg1, fb.Bg: fb.a = String$(j + 2, "Ü"): fb_map fb, 6
Locate y, x - 1: Color fb.Bg, fb.BHybBg1: fb.a = String$(j + 2, 0): fb_map fb, 0
Locate y + 1, x - 1: Color fb.BHybBg1, fb.Bg: fb.a = String$(j + 2, "ß"): fb_map fb, 7
Locate y, x: Color fb.BHybFg, fb.BHybBg2: fb.a = button$(i): fb_map fb, 0
_Dest overlay
Line (8 * (x(k) - 1) + 2, 16 * (y(k) - 1) + 7 + 2)-((j + 2) * 8 + 8 * (x(k) - 1) - 2, 16 * 2 + 16 * (y(k) - 1) + 7 - 2), _RGB32(155, 155, 155), B
Line (8 * (x(k) - 1), 16 * (y(k) - 1) + 7)-((j + 2) * 8 + 8 * (x(k) - 1), 16 * 2 + 16 * (y(k) - 1) + 7), _RGB32(fb.BHybBdr1, fb.BHybBdr1, fb.BHybBdr1), B
Line (8 * (x(k) - 1) + 8, 16 * (y(k) - 1) + 15)-((j + 1) * 8 + 8 * (x(k) - 1), y(k) * 16 + 15), _RGB32(fb.BHybBdr2, fb.BHybBdr2, fb.BHybBdr2), B
Overlay_Hardware = _CopyImage(overlay, 33)
_PutImage (0, 0), Overlay_Hardware
_FreeImage Overlay_Hardware
_Dest 0
Case 4 ' Graphics hybrid button.
j = Len(fb.a)
ReDim _Preserve x(btnnbr), y(btnnbr), button$(btnnbr)
y(btnnbr) = y - 1: x(btnnbr) = x - 1
button$(btnnbr) = String$(j + 2, 0)
Mid$(button$(btnnbr), 1 + (j - Len(_Trim$(fb.a))) / 2) = _Trim$(fb.a)
fb.a = button$(btnnbr)
Locate y - 1, x - 1: fb_map fb, 8
Locate y, x - 1: fb_map fb, -1
Locate y + 1, x - 1: fb_map fb, 9
Case 5 ' HTML button.
img& = _LoadImage("activate-static.png", 32)
i = _Height(img&)
j = _Width(img&)
If j Mod 8 Then j = j \ 8 + 1 Else j = j \ 8
If i Mod 16 Then i = i \ 16 + 1 Else i = i \ 16
If i / 2 <> i \ 2 Then i = i + 1
If j / 2 <> j \ 2 Then j = j + 1
_FreeImage img&
button$(btnnbr) = _Trim$(fb.a)
fb.a = String$(j, i)
ReDim _Preserve x(btnnbr), y(btnnbr), button$(btnnbr)
y(btnnbr) = y - 1: x(btnnbr) = x - 1
Locate y - 1, x - 1: fb_map fb, 10
For k = 0 To i - 2
Locate y + k, x - 1: fb_map fb, -1
Next
End Select
Color c1, c2
Locate s1, s2
End Sub
Function fb_gfx_hyb_hw (wide, tall, r, g, b, rc, gc, bc, caption$)
' Button function courtesy of the Amazing Steve.
Dim k As _Unsigned Long
Dest = _Dest
t = _NewImage(wide, tall, 32)
_Dest t
For i = 0 To 10
rm = rm + rc
gm = gm + gc
bm = bm + bc
k = _RGB32(r + rm, g + gm, b + bm)
Line (x + i, y + i)-(x + wide - i, y + tall - i), k, B
Next
Paint (x + i, y + i), k
Color _RGB32(r, g, b), 0
_PrintString (x + (wide - _PrintWidth(caption$)) / 2, y + (tall - _FontHeight) / 2), caption$
fb_gfx_hyb_hw = _CopyImage(t, 33)
_FreeImage t
_Dest Dest
End Function
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
If fb.mapping And mRow$(CsrLin) = "" Then mRow$(CsrLin) = Space$(_Width)
Select Case mapid
Case 1 ' Simple text field.
mapfld = mapfld + 1 ' Advance.
y1(mapfld - 96) = CsrLin
x1(mapfld - 96) = Pos(0)
y2(mapfld - 96) = CsrLin
x2(mapfld - 96) = Pos(0) + Len(fb.a)
Case 5 ' Single line button with blank padding.
mapfld = mapfld + 1 ' Advance.
y1(mapfld - 96) = CsrLin
x1(mapfld - 96) = Pos(0)
y2(mapfld - 96) = CsrLin
x2(mapfld - 96) = Pos(0) + Len(fb.a)
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)
Case 8 ' Graphics hybrid button top.
mapfld = mapfld + 1 ' Advance.
y1(mapfld - 96) = CsrLin
x1(mapfld - 96) = Pos(0)
Case 9 ' Graphics hybrid button bottom.
y2(mapfld - 96) = CsrLin
x2(mapfld - 96) = Pos(0) + Len(fb.a)
Case 10 ' HTML button.
mapfld = mapfld + 1 ' Advance.
y1(mapfld - 96) = CsrLin
x1(mapfld - 96) = Pos(0)
y2(mapfld - 96) = CsrLin + Asc(Mid$(fb.a, 1, 1))
x2(mapfld - 96) = Pos(0) + Len(fb.a)
End Select
If fb.mapping Then Mid$(mRow$(CsrLin), Pos(0)) = String$(Len(fb.a), Chr$(mapfld))
If mapid < 8 And mapid > -1 Then 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
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 Sub
You can change the fb.style 1 - 5, but if you use 5 the OK button will be displayed as Activate and you will need to download the buttons from my other WIP post.
Pete
Posts: 4,129
Threads: 185
Joined: Apr 2022
Reputation:
242
02-18-2025, 12:34 AM
(This post was last modified: 02-18-2025, 12:49 AM by bplus.)
(02-17-2025, 08:18 PM)SMcNeill Wrote: These boxes are so simple, just make your own.
Yeah piece of cake
Code: (Select All) _Title "Roll The Dice by SierraKen mod by b+"
Screen _NewImage(800, 600, 32): _ScreenMove 250, 60 ' sorry Ken this needs graphics screen
Randomize Timer
Do
Do
title$ = "Roll The Dice"
message$ = "(Nothing quits) How many sides is your dice (3-100)?"
result$ = inputBox$(message$, title$, 60) ' sorry I should have put title$ first!
If _Trim$(result$) = "" Then End
num = Val(result$)
If num < 3 Or num > 100 Or num <> Int(num) Then
mBox "Roll The Dice", "Pick only between 3 and 100."
Exit Do
End If
dice = Int(Rnd * num) + 1
dice$ = Str$(dice)
mBox "Shake, rattle and...", "Your roll: " + dice$
Loop
Loop
' 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, it needs to be longer than title$ and prompt$ also
' Utilities > Input Box > Input Box 1 tester v 2019-07-31
Function inputBox$ (prompt$, title$, boxWidth As _Byte)
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 bxW As Long, bxH As Long
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
Dim inp$, kh&
'draw message box
bxW = boxWidth * 8: bxH = 7 * 16
ibx = _NewImage(bxW, bxH, 32)
_Dest ibx
Color &HFF880000, &HFFFFFFFF
Locate 1, 1: Print Left$(Space$(Int((boxWidth - Len(title$) - 3)) / 2) + title$ + Space$(boxWidth), boxWidth)
Color &HFFFFFFFF, &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
If mx >= tlx And mx <= tlx + bxW And my >= tly And my <= tly + 16 Then 'mouse down on title bar
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 And my - graby >= 0 And my - graby <= sh - bxH Then
'attempt to speed up with less updates
If ((lastx - (mx - grabx)) ^ 2 + (lasty - (my - graby)) ^ 2) ^ .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
_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
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
' needs to run in a graphics screen
'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
bg = &HFF404040
fg = &HFF33AAFF
'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 until find a space, save the tail end for next line
d = Mid$(b, j, 1)
If d = " " Then
t(ti) = Mid$(b, 1, j - 1): b = tail + c: 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
If mx >= tlx And mx <= tlx + bxW And my >= tly And my <= tly + 16 Then 'mouse down on title bar
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 And my - graby >= 0 And my - graby <= sh - bxH Then
'attempt to speed up with less updates
If ((lastx - (mx - grabx)) ^ 2 + (lasty - (my - graby)) ^ 2) ^ .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
_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
' ============================================================= This is old version dev for mBox or InputBox new version dev with new GetArrayItem$
' for saving and restoring screen settins
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
Ha, ha @Pete mine is only 294 lines PLUS I can drag both boxes by their title bar.
b = b + ...
|
