PIPES PUZZLE is a maze connect game. Click on the pipes to rotate & connect them all and to make the water flow. The top left pipe is where the water starts, so go from there. When the board is all connected then the level is complete. Complete all levels to win the game.
Down at the bottom right corner of a page, you'll see a little box and a GO button. Those are all the themes available for the forums here, and are all I ever plan to have for the forums here. There's plenty for folks to choose from to choose one that suits them best. The question is: Which one does everyone like best? Let me know in the poll, and I'll set the most popular as the default, while everyone else can set their personal theme to whatever they like the most.
XE is a simple Binary File Editor (also called a HEX editor) that lets you view and edit raw data bytes of a file. With XE you can peek inside EXE/DLL files and see what information they may contain. XE also has the capacity to change bytes by either typing in ASCII characters or entering the HEX value for each byte. XE was first coded in Qbasic - now in QB64. Since the very nature of XE is to alter file data you should always use EXTREME caution when editing any file - AND ALWAYS MAKE A BACKUP FIRST!
This code will work in Windows & Linux.
- Dav
Code: (Select All)
'============
'XE.BAS v1.13
'============
'A simple File editor/viewer.
'Coded by Dav, AUG/2023 with QB64-PE v3.8.0
'
' * ADDED: Now uses _OPENFILEDIALOG to select file.
' * FIXED: Removed now unused FileSelect$ FUNCTION.
' * FIXED: A few non-editing bugs.
'
'==========================================================================
'* * * * USE THIS PROGRAM AT YOUR OWN RISK ONLY!! * * * *
'==========================================================================
'
'
' ABOUT:
' ~~~~~
'
' XE is a simple Binary File Editor (also called a HEX editor) that lets
' you view and edit raw data bytes of a file. With XE you can peek inside
' EXE/DLL files and see what information they may contain. XE also has the
' capacity to change bytes by either typing in ASCII characters or entering
' the HEX value for each byte. XE was first coded in Qbasic - now in QB64.
'
' Since the very nature of XE is to alter file data you should always use
' EXTREME caution when editing any file - AND ALWAYS MAKE A BACKUP FIRST!
'
'==========================================================================
'
' HOW TO USE:
' ~~~~~~~~~~
'
' XE accepts command line arguments. You can drag/drop a file onto XE.
' If you don't specify a filename on startup, XE will ask you for one.
'
' There are TWO ways to View & Edit files - in HEX (default) or ASCII mode.
'
' Files are first opened in HEX mode displaying 2 windows of data. The
' right window shows the charaters while the larger left window shows HEX
' values for them. HEX mode is best for patching and is the only way to
' edit the HEX values of bytes.
'
'
' Pressing ENTER switches to ASCII (non-HEX) mode, showing a larger page
' of raw data bytes - the ASCII chracter data only. This mode is best for
' skimming through files faster. ENTER toggles view modes back and forth.
'
' While viewing a file you can browse through the file using the ARROWS,
' PAGEUP/DOWN, HOME and the END keys.
'
' The currently opened filename is shown with full path in the title bar.
' and just filename is displayed in the FILE: area just below title bar.
'
' While viewing a file, press E to enter into EDIT mode and begin editing
' bytes at the current position. If you're in HEX mode (2 windows), you can
' edit bytes either by typing characters on the right side or entering HEX
' values on the left window. Press TAB to switch windows to edit in.
' Press ESC to save or disgard changes and to exit editing mode.
'
' Press M for a complete MENU listing all of the Key COMMANDS.
'
'==========================================================================
'
' COMMAND:
' ~~~~~~~~
'
' E = Enters EDIT MODE. Only the displayed bytes can be edited.
'
' TAB = Switchs panes (the cursor) while editing in HEX mode.
'
' S = Searches file for a string starting at the current byte.
' A Match-Case option is available. A high beep alerts you
' when match is found. A Low beep sounds when EOF reached.
'
' N = Finds NEXT Match after a do a string search.
'
' F = Toggles FILTERING of all non-standard-text characters.
' A flashing "F" is at the top-left corner when FILTER ON.
'
' G = GOTO a certain byte position (number) in the file.
'
' L = GOTO a specified location (Hex value) of the file.
'
' ENTER = Toggles HEX and ASCII view modes. The ASCII mode lets
' you browse more data per page. You can EDIT in both
' modes but can only enter in HEX vaules in HEX mode.
'
' ESC = EXITS out of editing mode, and also EXITS the program.
'
' ALT+ENTER = Toggle FULLSCREEN/WINDOWED mode of the XE program.
'
'==========================================================================
'==========================================================================
Screen Pete: Width 80, 25 'Use Screen mode 0, aka the Pete (Come back Pete!)
'Font size based on desktop resolution - it expands SCREEN 0 nicely.
'You may have to adjust it a bit to look the best on your screen res
FONT (Int(_DesktopHeight / 25) * .85)
_Delay .25 'Be sure window exists before calling _TITLE
_ControlChr Off 'Printing all 255 characters on screen, so this is needed.
If Command$ = "" Then
Print "Selecting file..."
File$ = _OpenFileDialog$("Select File for XE to Open...", "", "*.*", "Files", 0)
If File$ = "" Then
Print "ERROR: No file selected."
System
End If
Else
File$ = Command$
If _FileExists(File$) = 0 Then
Print File$; " not found!"
End
End If
End If
File$ = LTrim$(RTrim$(File$)) 'trim off any spaces, if any...
FullFileName$ = File$ 'make a copy For TITLE/OPEN to use...
'If filename+path too long for display, strip off path
If Len(File$) > 70 Then
ts$ = ""
For q = Len(File$) To 1 Step -1
t$ = Mid$(File$, q, 1)
If t$ = "/" Or t$ = "\" Then Exit For
ts$ = t$ + ts$
Next
File$ = ts$
'If filename too long, shorten it for display
If Len(File$) > 70 Then
File$ = Mid$(File$, 1, 67) + "..."
End If
End If
ByteLocation& = 1
If DisplayView% = 1 Then
BufferSize% = (16 * 23)
Else
BufferSize% = (79 * 23)
End If
If BufferSize% > LOF(7) Then BufferSize% = LOF(7)
'If dual pane mode....
If DisplayView% = 1 Then
If Len(PageOfData$) < (16 * 23) Then
PageFlag% = 1: PageLimit% = Len(PageOfData$)
PageOfData$ = PageOfData$ + String$(16 * 23 - Len(PageOfData$), Chr$(0))
End If
'show right side
y% = 3: x% = 63
For c% = 1 To Len(PageOfData$)
CurrentByte% = Asc(Mid$(PageOfData$, c%, 1))
'show a . instead of a null (looks better to me)
If CurrentByte% = 0 Then CurrentByte% = 46
If Filter% = 1 Then
Select Case CurrentByte%
Case 0 To 31, 123 To 255: CurrentByte% = 32
End Select
End If
Locate y%, x%: Print Chr$(CurrentByte%);
x% = x% + 1: If x% = 79 Then x% = 63: y% = y% + 1
Next
'show left side
y% = 3: x% = 15
For c% = 1 To Len(PageOfData$)
CurrentByte% = Asc(Mid$(PageOfData$, c%, 1))
CurrentByte$ = Hex$(CurrentByte%): If Len(CurrentByte$) = 1 Then CurrentByte$ = "0" + CurrentByte$
Locate y%, x%: Print CurrentByte$; " ";
x% = x% + 3: If x% >= 62 Then x% = 15: y% = y% + 1
Next
Else
'One page display, Full view
'Adjust data size used
If Len(PageOfData$) < (79 * 23) Then 'Enough to fill screen?
PageFlag% = 1: PageLimit% = Len(PageOfData$) 'No? Mark this and pad
PageOfData$ = PageOfData$ + Space$(79 * 23 - Len(PageOfData$)) 'data with spaces.
End If
y% = 3: x% = 1 'Screen location where data begins displaying
For c% = 1 To Len(PageOfData$) 'Show all the bytes.
CurrentByte% = Asc(Mid$(PageOfData$, c%, 1)) 'Check the ASCII value.
If Filter% = 1 Then 'If Filter is turned on,
Select Case CurrentByte% 'changes these values to spaces
Case 0 To 32, 123 To 255: CurrentByte% = 32
End Select
End If
Locate y%, x%: Print Chr$(CurrentByte%);
'This line calculates when to go to next row.
x% = x% + 1: If x% = 80 Then x% = 1: y% = y% + 1
Next
End If
GoSub DrawTopBar 'update viewing info at top
'Get user input
Do
Do Until L$ <> "": L$ = InKey$: Loop
K$ = L$: L$ = ""
GoSub DrawTopBar
Select Case UCase$(K$)
Case Chr$(27): Exit Do
Case "M": GoSub Menu:
Case "N"
If s$ <> "" Then
GoSub Search
GoSub DrawTopBar
End If
Case "E"
If DisplayView% = 1 Then
GoSub EditRightSide
Else
GoSub EditFullView
End If
GoSub DrawTopBar
Case "F"
If Filter% = 0 Then Filter% = 1 Else Filter% = 0
Case "G"
Locate 1, 1: Print String$(80 * 3, 32);
Locate 1, 3: Print "TOTAL BYTES>"; LOF(7)
Input " GOTO BYTE# > ", GotoByte$
If GotoByte$ <> "" Then
TMP$ = ""
For m% = 1 To Len(GotoByte$)
G$ = Mid$(GotoByte$, m%, 1) 'to numerical vales
Select Case Asc(G$)
Case 48 To 57: TMP$ = TMP$ + G$
End Select
Next: GotoByte$ = TMP$
If Val(GotoByte$) < 1 Then GotoByte$ = "1"
If Val(GotoByte$) > LOF(7) Then GotoByte$ = Str$(LOF(7))
If GotoByte$ <> "" Then ByteLocation& = 0 + Val(GotoByte$)
End If
Case "L"
Locate 1, 1: Print String$(80 * 3, 32);
Locate 1, 3: 'PRINT "TOTAL BYTES>"; LOF(7)
Input " GOTO HEX LOCATION-> ", GotoByte$
If GotoByte$ <> "" Then
GotoByte$ = "&H" + GotoByte$
If Val(GotoByte$) < 1 Then GotoByte$ = "1"
If Val(GotoByte$) > LOF(7) Then GotoByte$ = Str$(LOF(7))
If GotoByte$ <> "" Then ByteLocation& = 0 + Val(GotoByte$)
End If
Case "S": s$ = ""
Locate 1, 1: Print String$(80 * 3, 32);
Locate 1, 3: Input "Search for> ", s$
If s$ <> "" Then
Print " CASE sensitive (Y/N)? ";
I$ = Input$(1): I$ = UCase$(I$)
If I$ = "Y" Then CaseOn% = 1 Else CaseOn% = 0
GoSub Search
End If
GoSub DrawTopBar
Case Chr$(13)
If DisplayView% = 1 Then
DisplayView% = 0
BufferSize% = (79 * 23)
Else
DisplayView% = 1
BufferSize% = (16 * 23)
End If
GoSub DrawTopBar
Case Chr$(0) + Chr$(72)
If DisplayView% = 1 Then
If ByteLocation& > 15 Then ByteLocation& = ByteLocation& - 16
Else
If ByteLocation& > 78 Then ByteLocation& = ByteLocation& - 79
End If
Case Chr$(0) + Chr$(80)
If DisplayView% = 1 Then
If ByteLocation& < LOF(7) - 15 Then ByteLocation& = ByteLocation& + 16
Else
If ByteLocation& < LOF(7) - 78 Then ByteLocation& = ByteLocation& + 79
End If
Case Chr$(0) + Chr$(73): ByteLocation& = ByteLocation& - BufferSize%: If ByteLocation& < 1 Then ByteLocation& = 1
Case Chr$(0) + Chr$(81): If ByteLocation& < LOF(7) - BufferSize% Then ByteLocation& = ByteLocation& + BufferSize%
Case Chr$(0) + Chr$(71): ByteLocation& = 1
Case Chr$(0) + Chr$(79): If Not EOF(7) Then ByteLocation& = LOF(7) - BufferSize%
End Select
Loop Until K$ <> ""
Loop Until K$ = Chr$(27)
If Not EOF(7) Then
Do
B$ = Input$(BufferSize%, 7): ByteLocation& = ByteLocation& + BufferSize%
If CaseOn% = 0 Then B$ = UCase$(B$): s$ = UCase$(s$)
d$ = InKey$: If d$ <> "" Then Exit Do
If InStr(1, B$, s$) Then Sound 4000, .5: Exit Do
Loop Until InStr(1, B$, s$) Or EOF(7)
If EOF(7) Then Sound 2000, 1: Sound 1000, 1
ByteLocation& = ByteLocation& - Len(s$)
End If
Return
'==========================================================================
EditRightSide: 'Editing Right side info in dual pane mode
'============
Pane% = 1
x% = 63: If rightx% Then y% = CsrLin Else y% = 3
leftx% = 15
test% = Pos(0)
If test% = 15 Or test% = 16 Then x% = 63: leftx% = 15
If test% = 18 Or test% = 19 Then x% = 64: leftx% = 18
If test% = 21 Or test% = 22 Then x% = 65: leftx% = 21
If test% = 24 Or test% = 25 Then x% = 66: leftx% = 24
If test% = 27 Or test% = 28 Then x% = 67: leftx% = 27
If test% = 30 Or test% = 31 Then x% = 68: leftx% = 30
If test% = 33 Or test% = 34 Then x% = 69: leftx% = 33
If test% = 36 Or test% = 37 Then x% = 70: leftx% = 36
If test% = 39 Or test% = 40 Then x% = 71: leftx% = 39
If test% = 42 Or test% = 43 Then x% = 72: leftx% = 42
If test% = 45 Or test% = 46 Then x% = 73: leftx% = 45
If test% = 48 Or test% = 49 Then x% = 74: leftx% = 48
If test% = 51 Or test% = 52 Then x% = 75: leftx% = 51
If test% = 54 Or test% = 55 Then x% = 76: leftx% = 54
If test% = 57 Or test% = 58 Then x% = 77: leftx% = 57
If test% = 60 Or test% = 61 Then x% = 78: leftx% = 60
GoSub DrawEditBar:
Locate y%, x%, 1, 1, 30
Do
Do
E$ = InKey$
If E$ <> "" Then
Select Case E$
Case Chr$(9)
If Pane% = 1 Then
Pane% = 2: GoTo EditLeftSide
Else
Pane% = 1: GoTo EditRightSide
End If
Case Chr$(27): Exit Do
Case Chr$(0) + Chr$(72): If y% > 3 Then y% = y% - 1
Case Chr$(0) + Chr$(80): If y% < 25 Then y% = y% + 1
Case Chr$(0) + Chr$(75): If x% > 63 Then x% = x% - 1: leftx% = leftx% - 3
Case Chr$(0) + Chr$(77): If x% < 78 Then x% = x% + 1: leftx% = leftx% + 3
Case Chr$(0) + Chr$(73), Chr$(0) + Chr$(71): y% = 3
Case Chr$(0) + Chr$(81), Chr$(0) + Chr$(79): y% = 25
Case Else
If (ByteLocation& + ((y% - 3) * 16 + x% - 1) - 62) <= LOF(7) And E$ <> Chr$(8) Then
changes% = 1
'new color for changed bytes...
Color 1, 15: Locate y%, x%: Print " ";
Locate y%, leftx%
CurrentByte$ = Hex$(Asc(E$)): If Len(CurrentByte$) = 1 Then CurrentByte$ = "0" + CurrentByte$
Print CurrentByte$;
Locate y%, x%: Print E$;
Mid$(PageOfData$, ((y% - 3) * 16 + x% * 1) - 62) = E$
If x% < 78 Then x% = x% + 1: leftx% = leftx% + 3 'skip space
End If
End Select
End If
Loop Until E$ <> ""
Locate y%, x%
Loop Until E$ = Chr$(27)
If changes% = 1 Then
Sound 4500, .2: Color 15, 4: Locate , , 0
Locate 10, 29: Print Chr$(201); String$(21, 205); Chr$(187);
Locate 11, 29: Print Chr$(186); " Save Changes (Y/N)? "; Chr$(186);
Locate 12, 29: Print Chr$(200); String$(21, 205); Chr$(188);
N$ = Input$(1): Color 15, 1
If UCase$(N$) = "Y" Then
If PageFlag% = 1 Then PageOfData$ = Left$(PageOfData$, PageLimit%)
Put #7, ByteLocation&, PageOfData$:
End If
End If
Color 15, 1: Cls: Locate 1, 1, 0
Return
'==========================================================================
EditLeftSide: 'Editing Left side info in dual pane mode
'===========
Color 1, 7
x% = 15: 'y% = 3
rightx% = 63
test% = Pos(0)
If test% = 63 Then x% = 15: rightx% = 63
If test% = 64 Then x% = 18: rightx% = 64
If test% = 65 Then x% = 21: rightx% = 65
If test% = 66 Then x% = 24: rightx% = 66
If test% = 67 Then x% = 27: rightx% = 67
If test% = 68 Then x% = 30: rightx% = 68
If test% = 69 Then x% = 33: rightx% = 69
If test% = 70 Then x% = 36: rightx% = 70
If test% = 71 Then x% = 39: rightx% = 71
If test% = 72 Then x% = 42: rightx% = 72
If test% = 73 Then x% = 45: rightx% = 73
If test% = 74 Then x% = 48: rightx% = 74
If test% = 75 Then x% = 51: rightx% = 75
If test% = 76 Then x% = 54: rightx% = 76
If test% = 77 Then x% = 57: rightx% = 77
If test% = 78 Then x% = 60: rightx% = 78
GoSub DrawEditBar:
Locate y%, x%, 1, 1, 30
Do
Do
E$ = InKey$
If E$ <> "" Then
Select Case E$
Case Chr$(9)
If Pane% = 1 Then
Pane% = 2: GoTo EditLeftSide
Else
Pane% = 1: GoTo EditRightSide
End If
Case Chr$(27): Exit Do
Case Chr$(0) + Chr$(72): If y% > 3 Then y% = y% - 1
Case Chr$(0) + Chr$(80): If y% < 25 Then y% = y% + 1
Case Chr$(0) + Chr$(75) 'right arrow....
If x% > 15 Then
Select Case x%
Case 17, 18, 20, 21, 23, 24, 26, 27, 29, 30, 32, 33, 35, 36, 38, 39, 41, 42, 44, 45, 47, 48, 50, 51, 53, 54, 56, 57, 59, 60, 62, 63
x% = x% - 2
rightx% = rightx% - 1
Case Else: x% = x% - 1
End Select
End If
Case Chr$(0) + Chr$(77)
If x% < 61 Then
Select Case x%
Case 16, 17, 19, 20, 22, 23, 25, 26, 28, 29, 31, 32, 34, 35, 37, 38, 40, 41, 43, 44, 46, 47, 49, 50, 52, 53, 55, 56, 58, 59, 61, 62
x% = x% + 2
rightx% = rightx% + 1
Case Else: x% = x% + 1
End Select
End If
Case Chr$(0) + Chr$(73), Chr$(0) + Chr$(71): y% = 3
Case Chr$(0) + Chr$(81), Chr$(0) + Chr$(79): y% = 25
Case Else
If (ByteLocation& + ((y% - 3) * 16 + rightx% - 1) - 62) <= LOF(7) And E$ <> Chr$(8) Then
Select Case UCase$(E$)
Case "A", "B", "C", "D", "E", "F", "1", "2", "3", "4", "5", "6", "7", "8", "9", "0"
E$ = UCase$(E$)
changes% = 1
Color 1, 15: Locate y%, x%: Print " ";
Locate y%, x%: Print E$;
If x% < 62 Then
Select Case x%
Case 16, 17, 19, 20, 22, 23, 25, 26, 28, 29, 31, 32, 34, 35, 37, 38, 40, 41, 43, 44, 46, 47, 49, 50, 52, 53, 55, 56, 58, 59, 61, 62
e2$ = Chr$(Val("&H" + Chr$(Screen(y%, x% - 1)) + Chr$(Screen(y%, x%))))
'reflect changes on right panel
Color 1, 15: Locate y%, rightx%: Print " ";
Locate y%, rightx%: Print e2$;
Mid$(PageOfData$, ((y% - 3) * 16 + rightx% * 1) - 62) = e2$
'dont advance cursor if at last place
If x% < 61 Then
rightx% = rightx% + 1
x% = x% + 2
End If
Case Else: x% = x% + 1
End Select
End If
End Select
End If
End Select
End If
Loop Until E$ <> ""
Locate y%, x%
Loop Until E$ = Chr$(27)
GoTo SaveChanges:
'==========================================================================
EditFullView: 'Editing file in full display mode (one pane)
'===========
Color 1, 7
x% = 1: y% = 3
changes% = 0
GoSub DrawEditBar
Locate 3, 1, 1, 1, 30
Do
Do
E$ = InKey$
If E$ <> "" Then
Select Case E$
Case Chr$(27): Exit Do
Case Chr$(0) + Chr$(72): If y% > 3 Then y% = y% - 1
Case Chr$(0) + Chr$(80): If y% < 25 Then y% = y% + 1
Case Chr$(0) + Chr$(75): If x% > 1 Then x% = x% - 1
Case Chr$(0) + Chr$(77): If x% < 79 Then x% = x% + 1
Case Chr$(0) + Chr$(73), Chr$(0) + Chr$(71): y% = 3
Case Chr$(0) + Chr$(81), Chr$(0) + Chr$(79): y% = 25
Case Else
If (ByteLocation& + (y% - 3) * 79 + x% - 1) <= LOF(7) And E$ <> Chr$(8) Then
changes% = 1
'new color for changed bytes
Color 1, 15: Locate y%, x%: Print " ";
Locate y%, x%: Print E$;
Mid$(PageOfData$, (y% - 3) * 79 + x% * 1) = E$
If x% < 79 Then x% = x% + 1
End If
End Select
End If
Loop Until E$ <> ""
GoSub DrawEditBar
Locate y%, x%
Loop Until E$ = Chr$(27)
Locate 1, 1
If Filter% = 1 Then
Color 30, 4: Print "F";: Color 1, 15
Else
Print " ";
End If
Print "FILE: "; File$;
Locate 2, 2:
Print "Total Bytes:"; LOF(7);
EC& = ByteLocation& + BufferSize%: If EC& > LOF(7) Then EC& = LOF(7)
Print Chr$(179); " Viewing Bytes:"; RTrim$(Str$(ByteLocation&)); "-"; LTrim$(Str$(EC&));
Locate 1, 71: Print " M = Menu";
Color 15, 1
'Draw bar on right side of screen
For d% = 3 To 25
Locate d%, 80: Print Chr$(176);
Next
If DisplayView% = 1 Then
'Draw lines down screen
For d% = 3 To 25
Locate d%, 79: Print Chr$(179);
Locate d%, 62: Print Chr$(179);
'add space around numbers...
'(full screen messes it...)
Locate d%, 13: Print " " + Chr$(179);
Locate d%, 1: Print Chr$(179) + " ";
Next
'Draw location
For d% = 3 To 25
Locate d%, 3
nm$ = Hex$(ByteLocation& - 32 + (d% * 16))
If Len(nm$) = 9 Then nm$ = "0" + nm$
If Len(nm$) = 8 Then nm$ = "00" + nm$
If Len(nm$) = 7 Then nm$ = "000" + nm$
If Len(nm$) = 6 Then nm$ = "0000" + nm$
If Len(nm$) = 5 Then nm$ = "00000" + nm$
If Len(nm$) = 4 Then nm$ = "000000" + nm$
If Len(nm$) = 3 Then nm$ = "0000000" + nm$
If Len(nm$) = 2 Then nm$ = "00000000" + nm$
If Len(nm$) = 1 Then nm$ = "000000000" + nm$
Print nm$;
Next
End If
'=== Generate a unique font name to use based on date + timer
fontname$ = "_cp437_" + Date$ + "_" + LTrim$(Str$(Int(Timer))) + ".ttf"
If InStr(_OS$, "LINUX") Then tmp$ = "/tmp/" + tmp$
'=== Make font file
FFF = FreeFile: Open fontname$ For Output As #FFF
Print #FFF, BASFILE$;: Close #FFF
'=== Load then kill it after loading it into memory
fnt& = _LoadFont(fontname$, size, "monospace"): _Font fnt&
Kill fontname$
A small little demo to help highlight how one would work with the joystick in QB64:
Code: (Select All)
D = _DEVICES 'Find the number of devices on someone's system
'1 is the keyboard
'2 is the mouse
'3 is the joystick
'unless someone has a strange setup with multiple mice/keyboards/ect...
'In that case, you can use _DEVICE$(i) to look for "KEYBOARD", "MOUSE", "JOYSTICK", if necessary.
'I've never actually found it necessary, but I figure it's worth mentioning, just in case...
DIM Button(_LASTBUTTON(3)) ' number of buttons on the joystick
DIM Axis(_LASTAXIS(3)) 'number of axis on the joystick
DO
DO
'This following little segment of code gets the joystick status for us
'The reason this is inside a DO...LOOP structure as I've created it,
'is so that my joystick's axis won't generate any form of lag for
'my program as I scroll them around to generate positive/negative values.
IF _DEVICEINPUT = 3 THEN 'this says we only care about joystick input values
FOR i = 1 TO _LASTBUTTON(3) 'this is a loop to check all the buttons
IF _BUTTONCHANGE(i) THEN Button(i) = NOT Button(i) 'and this changes my button array to indicate if a button is up or down currently.
NEXT
FOR i = 1 TO _LASTAXIS(3) 'this loop checks all my axis
'I like to give a little "jiggle" resistance to my controls, as I have an old joystick
'which is prone to always give minute values and never really center on true 0.
'A value of 1 means my axis is pushed fully in one direction.
'A value greater than 0.1 means it's been partially pushed in a direction (such as at a 45 degree diagional angle).
'A value of less than 0.1 means we count it as being centered. (As if it was 0.)
IF ABS(_AXIS(i)) <= 1 AND ABS(_AXIS(i)) >= .1 THEN Axis(i) = _AXIS(i) ELSE Axis(i) = 0
NEXT
ELSE EXIT DO
END IF
LOOP
'And below here is just the simple display routine which displays our values.
'If this was for a game, I'd choose something like Axis(1) = -1 for a left arrow style input,
'Axis(1) = 1 for a right arrow style input, rather than just using _KEYHIT or INKEY$.
CLS
FOR i = 1 TO _LASTBUTTON(3) 'A loop for each button
PRINT "BUTTON "; i; ": "; Button(i) 'display their status to the screen
NEXT
FOR i = 1 TO _LASTAXIS(3) 'A loop for each axis
PRINT "Axis "; i; ": "; Axis(i) 'display their status to the screen
NEXT
Not to be confused with CircleFill, this is CircleFiller -- this fills an area with circles!
Code: (Select All)
Screen _NewImage(640, 480, 32)
Const Red = &HFFFF0000
Line (200, 200)-(400, 400), Red, B
CircleFiller 300, 300, 10, Red
Sleep
Cls , 0
Circle (320, 240), 100, Red
CircleFiller 320, 240, 10, Red
Sub CircleFiller (x, y, r, k As _Unsigned Long)
If CircleFillValid(x, y, r, k) Then
CircleFill x, y, r, k
CircleFiller x - r - r - 1, y, r, k
CircleFiller x + r + r + 1, y, r, k
CircleFiller x, y - r - r - 1, r, k
CircleFiller x, y + r + r + 1, r, k
End If
End Sub
Sub CircleFill (cx As Integer, cy As Integer, r As Integer, c As _Unsigned Long)
Dim a As Long, b As Long
Dim x As Long, y As Long
Dim xx As Long, yy As Long
Dim sx As Long, sy As Long
Dim e As Long
Dim rx As Integer, ry As Integer
rx = r: ry = r
a = 2 * rx * rx
b = 2 * ry * ry
x = rx
xx = ry * ry * (1 - rx - rx)
yy = rx * rx
sx = b * rx
Do While sx >= sy
Line (cx - x, cy - y)-(cx + x, cy - y), c, BF
If y <> 0 Then Line (cx - x, cy + y)-(cx + x, cy + y), c, BF
y = y + 1
sy = sy + a
e = e + yy
yy = yy + a
If (e + e + xx) > 0 Then
x = x - 1
sx = sx - b
e = e + xx
xx = xx + b
End If
Loop
x = 0
y = ry
xx = rx * ry
yy = rx * rx * (1 - ry - ry)
e = 0
sx = 0
sy = a * ry
Do While sx <= sy
Line (cx - x, cy - y)-(cx + x, cy - y), c, BF
Line (cx - x, cy + y)-(cx + x, cy + y), c, BF
Do
x = x + 1
sx = sx + b
e = e + xx
xx = xx + b
Loop Until (e + e + yy) > 0
y = y - 1
sy = sy - a
e = e + yy
yy = yy + a
Loop
End Sub
Function CircleFillValid (cx As Integer, cy As Integer, r As Integer, c As _Unsigned Long)
Dim a As Long, b As Long
Dim x As Long, y As Long
Dim xx As Long, yy As Long
Dim sx As Long, sy As Long
Dim e As Long
Dim rx As Integer, ry As Integer
rx = r: ry = r
a = 2 * rx * rx
b = 2 * ry * ry
x = rx
xx = ry * ry * (1 - rx - rx)
yy = rx * rx
sx = b * rx
Do While sx >= sy
For i = cx - x To cx + x
If Point(i, cy - y) = c Then Exit Function
Next
'LINE (cx - x, cy - y)-(cx + x, cy - y), c, BF
If y <> 0 Then
'LINE (cx - x, cy + y)-(cx + x, cy + y), c, BF
For i = cx - x To cx + x
If Point(i, cy + y) = c Then Exit Function
Next
End If
y = y + 1
sy = sy + a
e = e + yy
yy = yy + a
If (e + e + xx) > 0 Then
x = x - 1
sx = sx - b
e = e + xx
xx = xx + b
End If
Loop
x = 0
y = ry
xx = rx * ry
yy = rx * rx * (1 - ry - ry)
e = 0
sx = 0
sy = a * ry
Do While sx <= sy
'LINE (cx - x, cy - y)-(cx + x, cy - y), c, BF
'LINE (cx - x, cy + y)-(cx + x, cy + y), c, BF
For i = cx - x To cx + x
If Point(i, cy - y) = c Then Exit Function
If Point(i, cy + y) = c Then Exit Function
Next
Do
x = x + 1
sx = sx + b
e = e + xx
xx = xx + b
Loop Until (e + e + yy) > 0
y = y - 1
sy = sy - a
e = e + yy
yy = yy + a
Loop
CircleFillValid = -1
End Function
This can also be easily modified to become an EllipseFiller (as I'm actually using the EllipseFill routines for this and modified them so rx/ry are both passed by r instead...), if case anyone wants a nice EllipseFiller utility.
And what's the purpose of this, you ask?
I was thinking of plugging it into my little hourglass program so it'd drop balls instead of sand, but then I figured, "Nah... I'm too lazy. This is good enough. Somebody else can go back and insert the routines into the program if they want to now. I'm going to dinner and a movie with the wife..."
Everybody else makes clocks... I made an hourglass!
Code: (Select All)
Screen _NewImage(1024, 720, 32)
_ScreenMove _Middle
_Define A-Z As LONG
Dim Shared SandCounter
Dim FillColor As _Unsigned Long
ReDim Shared Sand(100000) As Coord
ReDim Shared RemoveSand(100000) As Coord
Dim Pause As _Float
Const Seconds = 10
f = _LoadFont("OLDENGL.ttf", 32)
_Font f
DrawHourGlass CenterX, CenterY, 200, 50, 3, 3, -1
FillWithSand CenterX, CenterY, FillColor
PCopy 0, 1
_DontBlend
Do
PCopy 1, 0
For i = 1 To SandCounter: Sand(i).x = CenterX: Sand(i).y = CenterY + 1: Next
If Pause = 0 Then Pause = SandCounter / Seconds
CountDown = Seconds
o$ = Str$(CountDown): _PrintString (512 - _PrintWidth(o$) \ 2, 570), o$ + " "
min = 1: max = 0
t# = Timer(0.001)
Do
If max < SandCounter Then
max = max + 1
PSet (RemoveSand(max).x, RemoveSand(max).y), 0
End If
For i = min To max
If Point(Sand(i).x, Sand(i).y + 1) = 0 Then 'fall down
PSet (Sand(i).x, Sand(i).y), 0
Sand(i).y = Sand(i).y + 1
ElseIf Point(Sand(i).x - 1, Sand(i).y + 1) = 0 Then 'fall down and left
PSet (Sand(i).x, Sand(i).y), 0
Sand(i).x = Sand(i).x - 1: Sand(i).y = Sand(i).y + 1
ElseIf Point(Sand(i).x + 1, Sand(i).y + 1) = 0 Then 'fall down and right
PSet (Sand(i).x, Sand(i).y), 0
Sand(i).x = Sand(i).x + 1: Sand(i).y = Sand(i).y + 1
Else 'sit and don't move any more
min = min + 1
End If
PSet (Sand(i).x, Sand(i).y), FillColor
Next
If Timer - t# >= 1 Then t# = Timer(0.001): CountDown = CountDown - 1: o$ = Str$(CountDown): _PrintString (512 - _PrintWidth(o$) \ 2, 570), o$ + " "
_Limit Pause 'to set the timing properly (IF possible. Slow computers may not run this unoptimized code at speed for an hourglass with a low flip time.)
_Display
If _KeyHit Then System
Loop Until max = SandCounter
Loop
Sub FillWithSand (x, y, kolor As _Unsigned Long)
If Point(x - 1, y) = 0 Then
PSet (x - 1, y), kolor
SandCounter = SandCounter + 1
If SandCounter > UBound(Sand) Then
ReDim _Preserve Sand(UBound(Sand) + 100000) As Coord
ReDim _Preserve RemoveSand(UBound(Sand) + 100000) As Coord
End If
RemoveSand(SandCounter).x = x - 1: RemoveSand(SandCounter).y = y
FillWithSand x - 1, y, kolor
End If
If Point(x, y - 1) = 0 Then
PSet (x, y - 1), kolor
SandCounter = SandCounter + 1
If SandCounter > UBound(Sand) Then
ReDim _Preserve Sand(UBound(Sand) + 100000) As Coord
ReDim _Preserve RemoveSand(UBound(Sand) + 100000) As Coord
End If
RemoveSand(SandCounter).x = x: RemoveSand(SandCounter).y = y - 1
FillWithSand x, y - 1, kolor
End If
If Point(x + 1, y) = 0 Then
PSet (x + 1, y), kolor
SandCounter = SandCounter + 1
If SandCounter > UBound(Sand) Then
ReDim _Preserve Sand(UBound(Sand) + 100000) As Coord
ReDim _Preserve RemoveSand(UBound(Sand) + 100000) As Coord
End If
RemoveSand(SandCounter).x = x + 1: RemoveSand(SandCounter).y = y
FillWithSand x + 1, y, kolor
End If
End Sub
Sub DrawHourGlass (x, y, high, wide, gap, thick, kolor As _Unsigned Long) 'x/y center
Line (x - gap, y)-Step(-wide, -high), kolor
Line -Step(2 * (wide + gap), -thick), kolor, BF
Line (x + gap, y)-Step(wide, -high), kolor
Line (x + gap, y)-Step(wide, high), kolor
Line (x - gap, y)-Step(-wide, high), kolor
Line -Step(2 * (wide + gap), thick), kolor, BF
For thickness = 1 To thick
For Yborder = 0 To y + high + thick
For Xborder = 0 To x
If Point(Xborder + 1, Yborder) Then PSet (Xborder, Yborder), kolor 'thicken left
Next
For Xborder = x + wide + 2 * gap + thickness To x + 1 Step -1
If Point(Xborder - 1, Yborder) Then PSet (Xborder, Yborder), kolor 'thicken right
Next
Next
Next
End Sub
DECLARE DYNAMIC LIBRARY "kernel32"
FUNCTION GlobalFree~%& (BYVAL hMem~%&)
FUNCTION GetLastError~& ()
END DECLARE
DECLARE DYNAMIC LIBRARY "gdi32"
FUNCTION DeleteDC& (BYVAL hdc~%&)
FUNCTION SetTextAlign~& (BYVAL hdc~%&, BYVAL fMode~&)
FUNCTION GetTextAlign~& (BYVAL hdc~%&)
FUNCTION TextOutA& (BYVAL hdc~%&, BYVAL nXStart&, BYVAL nYStart&, BYVAL lpString~%&, BYVAL cchString&)
FUNCTION StartDocA& (BYVAL hdc~%&, BYVAL lpdi~%&)
FUNCTION AbortDoc& (BYVAL hdc~%&)
FUNCTION StartPage& (BYVAL hDC~%&)
FUNCTION EndPage& (BYVAL hdc~%&)
FUNCTION EndDoc& (BYVAL hdc~%&)
FUNCTION ResetDCA~%& (BYVAL hdc~%&, BYVAL lpInitData~%&)
END DECLARE
DECLARE DYNAMIC LIBRARY "user32"
FUNCTION FindWindowA%& (BYVAL lpClassName%&, BYVAL lpWindowName%&)
END DECLARE
DECLARE DYNAMIC LIBRARY "comdlg32"
FUNCTION PrintDlgExA~& (BYVAL lppd~%&) ' returns an HRESULT
END DECLARE
DECLARE CUSTOMTYPE LIBRARY
' http://www.[abandoned, outdated and now likely malicious qb64 dot net website - don’t go there]/forum/index.php?topic=10886.msg91583#msg91583
SUB SUB_READDEVMODE (BYVAL p~%&)
SUB SUB_READDEVNAMES (BYVAL p~%&)
END DECLARE
TYPE DOCINFOA
cbSize AS LONG
lpszDocName AS _UNSIGNED _OFFSET ' LPCSTR
lpszOutput AS _UNSIGNED _OFFSET ' LPCSTR
lpszDatatype AS _UNSIGNED _OFFSET ' LPCSTR
fwType AS _UNSIGNED LONG
END TYPE
TYPE POINTL
x AS LONG
y AS LONG
END TYPE
CONST len_DEVMODEA = 156
TYPE DEVMODEA
dmDeviceName AS STRING * CCHDEVICENAME
dmSpecVersion AS _UNSIGNED INTEGER
dmDriverVersion AS _UNSIGNED INTEGER
dmSize AS _UNSIGNED INTEGER
dmDriverExtra AS _UNSIGNED INTEGER
dmFields AS _UNSIGNED LONG
' union {
' struct { comment either the following 8 lines
dmOrientation AS INTEGER
dmPaperSize AS INTEGER
dmPaperLength AS INTEGER
dmPaperWidth AS INTEGER
dmScale AS INTEGER
dmCopies AS INTEGER
dmDefaultSource AS INTEGER
dmPrintQuality AS INTEGER
' };
' struct { or the following 3 lines
' dmPosition AS POINTL
' dmDisplayOrientation AS _UNSIGNED LONG
' dmDisplayFixedOutput AS _UNSIGNED LONG
' };
' };
dmColor AS INTEGER
dmDuplex AS INTEGER
dmYResolution AS INTEGER
dmTTOption AS INTEGER
dmCollate AS INTEGER
dmFormName AS STRING * CCHFORMNAME
dmLogPixels AS _UNSIGNED INTEGER
dmBitsPerPel AS _UNSIGNED LONG
dmPelsWidth AS _UNSIGNED LONG
dmPelsHeight AS _UNSIGNED LONG
' union { comment exactly 1 of the following 2 lines
' dmDisplayFlags AS _UNSIGNED LONG
dmNup AS _UNSIGNED LONG
' };
dmDisplayFrequency AS _UNSIGNED LONG
dmICMMethod AS _UNSIGNED LONG
dmICMIntent AS _UNSIGNED LONG
dmMediaType AS _UNSIGNED LONG
dmDitherType AS _UNSIGNED LONG
dmReserved1 AS _UNSIGNED LONG
dmReserved2 AS _UNSIGNED LONG
dmPanningWidth AS _UNSIGNED LONG
dmPanningHeight AS _UNSIGNED LONG
END TYPE
TYPE DEVNAMES
wDriverOffset AS _UNSIGNED INTEGER
wDeviceOffset AS _UNSIGNED INTEGER
wOutputOffset AS _UNSIGNED INTEGER
wDefault AS _UNSIGNED INTEGER
END TYPE
TYPE PRINTPAGERANGE
nFromPage AS _UNSIGNED LONG
nToPage AS _UNSIGNED LONG
END TYPE
$IF 32BIT THEN
TYPE PRINTDLGEX
lStructSize AS _UNSIGNED LONG
hwndOwner AS _UNSIGNED _OFFSET ' HWND
hDevMode AS _UNSIGNED _OFFSET ' HGLOBAL
hDevNames AS _UNSIGNED _OFFSET ' HGLOBAL
hDC AS _UNSIGNED _OFFSET ' HDC
Flags AS _UNSIGNED LONG
Flags2 AS _UNSIGNED LONG
ExclusionFlags AS _UNSIGNED LONG
nPageRanges AS _UNSIGNED LONG
nMaxPageRanges AS _UNSIGNED LONG
lpPageRanges AS _UNSIGNED _OFFSET ' LPPRINTPAGERANGE
nMinPage AS _UNSIGNED LONG
nMaxPage AS _UNSIGNED LONG
nCopies AS _UNSIGNED LONG
hInstance AS _UNSIGNED _OFFSET ' HINSTANCE
lpPrintTemplateName AS _UNSIGNED _OFFSET ' LPCSTR
lpCallback AS _UNSIGNED _OFFSET ' LPUNKNOWN
nPropertyPages AS _UNSIGNED LONG
lphPropertyPages AS _UNSIGNED _OFFSET ' HPROPSHEETPAGE *
nStartPage AS _UNSIGNED LONG
dwResultAction AS _UNSIGNED LONG
END TYPE
$ELSE
TYPE PRINTDLGEX
lStructSize AS _UNSIGNED _INTEGER64
hwndOwner AS _UNSIGNED _OFFSET ' HWND
hDevMode AS _UNSIGNED _OFFSET ' HGLOBAL
hDevNames AS _UNSIGNED _OFFSET ' HGLOBAL
hDC AS _UNSIGNED _OFFSET ' HDC
Flags AS _UNSIGNED LONG
Flags2 AS _UNSIGNED LONG
ExclusionFlags AS _UNSIGNED LONG
nPageRanges AS _UNSIGNED LONG
nMaxPageRanges AS _UNSIGNED _INTEGER64
lpPageRanges AS _UNSIGNED _OFFSET ' LPPRINTPAGERANGE
nMinPage AS _UNSIGNED LONG
nMaxPage AS _UNSIGNED LONG
nCopies AS _UNSIGNED _INTEGER64 'LONG
hInstance AS _UNSIGNED _OFFSET ' HINSTANCE
lpPrintTemplateName AS _UNSIGNED _OFFSET ' LPCSTR
lpCallback AS _UNSIGNED _OFFSET ' LPUNKNOWN
nPropertyPages AS _UNSIGNED _INTEGER64 'LONG
lphPropertyPages AS _UNSIGNED _OFFSET ' HPROPSHEETPAGE *
nStartPage AS _UNSIGNED LONG
dwResultAction AS _UNSIGNED LONG
END TYPE
$END IF
DIM pageranges(0 TO 7) AS PRINTPAGERANGE
DIM pde AS PRINTDLGEX
DIM hWnd AS _UNSIGNED _OFFSET
DIM hr AS _UNSIGNED LONG
DIM t AS STRING
DIM t1 AS STRING * 16
DIM doc AS DOCINFOA
hr = PrintDlgExA(_OFFSET(pde))
IF S_OK <> hr THEN PRINT "ZZError. HRESULT: 0x" + LCASE$(HEX$(hr))
PRINT pde.dwResultAction
IF pde.hDevMode THEN SUB_READDEVMODE _OFFSET(pde.hDevMode)
IF pde.hDevNames THEN SUB_READDEVNAMES _OFFSET(pde.hDevNames)
IF PD_RESULT_PRINT = pde.dwResultAction THEN
IF pde.hDC THEN
t1 = "qb64 prn test" + CHR$(0) ' fixed len str so it won't move
doc.cbSize = LEN(doc)
doc.lpszDocName = _OFFSET(t1)
doc.lpszOutput = 0
doc.lpszDatatype = 0
doc.fwType = 0
IF 0 >= StartDocA(pde.hDC, _OFFSET(doc)) THEN PRINT "doc error"
IF 0 >= StartPage(pde.hDC) THEN PRINT "doc error"
IF GDI_ERROR = SetTextAlign(pde.hDC, GetTextAlign(pde.hDC) OR TA_UPDATECP) THEN PRINT "GDI error"
t = "Hello, world!"
IF 0 = TextOutA(pde.hDC, 0, 0, _OFFSET(t), LEN(t)) THEN PRINT "error"
IF 0 >= EndPage(pde.hDC) THEN PRINT "doc error"
IF 0 >= EndDoc(pde.hDC) THEN PRINT "doc error"
END IF
END IF
IF pde.hDevMode THEN
IF 0 <> GlobalFree(pde.hDevMode) THEN PRINT "Error: 0x" + LCASE$(HEX$(GetLastError))
END IF
IF pde.hDevNames THEN
IF 0 <> GlobalFree(pde.hDevNames) THEN PRINT "Error: 0x" + LCASE$(HEX$(GetLastError))
END IF
IF pde.hDC THEN
IF 0 = DeleteDC(pde.hDC) THEN PRINT "Error: 0x" + LCASE$(HEX$(GetLastError))
END IF
END
SUB readDevMode (t AS DEVMODEA)
PRINT t.dmDeviceName
' etc...
END SUB
SUB readDevNames (t AS DEVNAMES)
DIM m AS _MEM
t$ = SPACE$(255)
m = _MEM(_OFFSET(t) + t.wDriverOffset, 255)
_MEMGET m, m.OFFSET, t$
PRINT t$
m = _MEM(_OFFSET(t) + t.wDeviceOffset, 255)
_MEMGET m, m.OFFSET, t$
PRINT t$
m = _MEM(_OFFSET(t) + t.wOutputOffset, 255)
_MEMGET m, m.OFFSET, t$
PRINT t$
'PRINT peekstr(_OFFSET(t) + t.wDriverOffset)
'PRINT peekstr(_OFFSET(t) + t.wDeviceOffset)
'PRINT peekstr(_OFFSET(t) + t.wOutputOffset)
END SUB
DIM SHARED WorkScreen AS LONG, DisplayScreen AS LONG
$RESIZE:ON
WorkScreen = _NEWIMAGE(3600, 2400, 32) ' a nice large screen so we can scroll like crazy
DisplayScreen = _NEWIMAGE(640, 480, 32) 'a nice small display screen
SCREEN DisplayScreen
_DEST WorkScreen
PRINT "Let's print all sorts of stuff on our workscreen, and make certain that it's more than long enough so that it'll scroll quite a ways across from the normal screen."
PRINT
PRINT
LINE (400, 400)-(3000, 1200), &HFFFFFF00, BF
FOR i = 1 TO 145
COLOR _RGB32(RND * 256, RND * 256, RND * 256), 0 'various colors for each line
PRINT "LINE #"; i; ". This is just a bunch of junk for testing purposes only. As you can see, if you want to read all the text from this line, you're going to have to scroll to see it all."
NEXT
StartX = 0: StartY = 0: W = _WIDTH(DisplayScreen): H = _HEIGHT(DisplayScreen)
_DEST DisplayScreen
DO
IF _RESIZE THEN
temp = _NEWIMAGE(_RESIZEWIDTH, _RESIZEHEIGHT, 32)
SCREEN temp
_FREEIMAGE DisplayScreen
DisplayScreen = temp
W = _WIDTH(DisplayScreen): H = _HEIGHT(DisplayScreen)
_DELAY .25
junk = _RESIZE 'clear the resize flag after manually setting the screen to the size we specified.
END IF
_LIMIT 30
CLS
ScrollBar StartX, 2
ScrollBar StartY, 1
k = _KEYHIT
SELECT CASE k
CASE ASC("A"), ASC("a"), 19200: StartX = StartX - 10: IF StartX < 0 THEN StartX = 0
CASE ASC("S"), ASC("s"), 20480: StartY = StartY + 10: IF StartY > _HEIGHT(WorkScreen) - H THEN StartY = _HEIGHT(WorkScreen) - H
CASE ASC("D"), ASC("d"), 19712: StartX = StartX + 10: IF StartX > _WIDTH(WorkScreen) - W THEN StartX = _WIDTH(WorkScreen) - W
CASE ASC("W"), ASC("w"), 18432: StartY = StartY - 10: IF StartY < 0 THEN StartY = 0
END SELECT
WHILE _MOUSEINPUT: WEND
IF _MOUSEBUTTON(1) THEN
IF _MOUSEX > W - 21 AND _MOUSEY < H - 20 THEN 'We're on a up/down scroll bar
StartY = _MOUSEY / _HEIGHT(DisplayScreen) * _HEIGHT(WorkScreen)
IF StartY > _HEIGHT(WorkScreen) - H THEN StartY = _HEIGHT(WorkScreen) - H
END IF
IF _MOUSEY > H - 21 AND _MOUSEX < W - 20 THEN 'we're on the left/right scroll bar
StartX = _MOUSEX / _WIDTH(DisplayScreen) * _WIDTH(WorkScreen)
IF StartX > _WIDTH(WorkScreen) - W THEN StartX = _WIDTH(WorkScreen) - W
END IF
END IF
SUB ScrollBar (Start, Direction)
D = _DEST: _DEST DisplayScreen 'our scrollbars show on the display
Min = 0
MaxH = _HEIGHT(DisplayScreen)
MaxW = _WIDTH(DisplayScreen)
H = _HEIGHT(WorkScreen)
W = _WIDTH(WorkScreen)
IF Direction = 1 THEN 'up/down bar
Box MaxW - 20, 0, 20, MaxH - 20, &HFF777777, &HFFFFFFFF
Box MaxW - 19, Start / H * MaxH, 18, MaxH / H * MaxH - 20, &HFFFF0000, 0 'Red with transparent
ELSE 'left/right bar
Box Min, MaxH - 20, MaxW - 20, 20, &HFF777777, &HFFFFFFFF 'Gray with white border
Box Start / W * MaxW, MaxH - 19, MaxW / W * MaxW - 20, 18, &HFFFF0000, 0 'Red with transparent
END IF
_DEST D
END SUB
SUB Box (x, y, wide, high, kolor AS _UNSIGNED LONG, border AS _UNSIGNED LONG)
LINE (x, y)-STEP(wide, high), kolor, BF
LINE (x, y)-STEP(wide, high), border, B
END SUB
Use arrows (or WASD) to scroll the screen, or press the mousebutton down over the scroll bar and see it in action. Then grab the corner of the screen and resize it, and watch how the scroll bars automatically resize to fit the new dimensions and continue to work as you'd expect them to.
Resizeable program -- Check! Scroll bars for it -- Check!
As the title says, "Scroll bars and resizable programs". We do both things in this little demo. (And now we also do arrow keys and mouse support!)
'Random length string database creation.
'This demo will utilize two different files to manage our database.
'the first one will be the data, and the second will be our index to the data
TYPE RecordType
Name AS STRING
Age AS _BYTE
Sex AS STRING
Phone AS STRING
END TYPE
TYPE IndexType
StartPosition AS LONG
LengthName AS LONG 'track how long the name is
LengthSex AS LONG 'track how long the sex is
LengthPhone AS LONG 'track how long the phone is
END TYPE
DEFLNG A-Z
DIM SHARED Record AS RecordType, Index AS IndexType
DIM SHARED RecordNumber, RecordCount
OPEN "Demo.dba" FOR BINARY AS #1 'the demo database
OPEN "Demo.ndx" FOR BINARY AS #2 'the demo index
RecordCount = LOF(2) \ LEN(Index)
DO
choice = ShowOptions
SELECT CASE choice
CASE 1: AddRecord
CASE 2:
CASE 3:
CASE 4: RecordNumber = RecordNumber - 1: IF RecordNumber < 1 THEN RecordNumber = RecordCount
CASE 5: RecordNumber = RecordNumber + 1: IF RecordNumber > RecordCount THEN RecordNumber = 1
CASE 6: SYSTEM
END SELECT
LOOP
SUB ShowMainInfo
CLS
IF RecordNumber > 0 THEN 'Get the current record and display it
GET #2, (RecordNumber - 1) * LEN(Index) + 1, Index
Record.Name = SPACE$(Index.LengthName)
Record.Sex = SPACE$(Index.LengthSex)
Record.Phone = SPACE$(Index.LengthPhone)
GET #1, Index.StartPosition, Record.Name
GET #1, , Record.Age
GET #1, , Record.Sex
GET #1, , Record.Phone
ELSE
Record.Name = ""
Record.Age = 0
Record.Sex = ""
Record.Phone = ""
END IF
SUB AddRecord
RecordNumber = 0 'Display a blank record
ShowMainInfo
RecordCount = RecordCount + 1 'increase our total count of records
RecordNumber = RecordCount 'And set our current record to the new record count value
PRINT "ENTER Name : "
PRINT "ENTER Age : "
PRINT "ENTER Sex : "
PRINT "ENTER Phone: "
LOCATE 10, 14: INPUT ; ""; Record.Name
LOCATE 11, 14: INPUT ; ""; Record.Age
LOCATE 12, 14: INPUT ; ""; Record.Sex
LOCATE 13, 14: INPUT ; ""; Record.Phone
filesize = LEN(Record.Name) + LEN(Record.Age) + LEN(Record.Sex) + LEN(Record.Phone)
Index.StartPosition = LOF(1) + 1
Index.LengthName = LEN(Record.Name)
Index.LengthSex = LEN(Record.Sex)
Index.LengthPhone = LEN(Record.Phone)
PUT #2, (RecordCount - 1) * LEN(Index) + 1, Index
t$ = Record.Name: PUT #1, LOF(1) + 1, t$ 'We must use a temp string, as we can't put a variable length string type to a file
PUT #1, , Record.Age
t$ = Record.Sex: PUT #1, , t$
t$ = Record.Phone: PUT #1, , t$
END SUB
FUNCTION ShowOptions
ShowMainInfo
PRINT "1) Add Record"
PRINT "2) Delete Record Record (Not Implemented Yet)"
PRINT "3) Edit Record Record (Not Implemented Yet)"
PRINT "4) Previous Record"
PRINT "5) Next Record"
PRINT "6) Quit"
PRINT
PRINT
DO
i$ = INPUT$(1)
SELECT CASE i$
CASE "1" TO "6": ShowOptions = VAL(i$): EXIT FUNCTION
END SELECT
LOOP
END FUNCTION
Folks have recently been talking about how to make databases with BINARY vs RANDOM access, and somebody brought up how they'd manage variable length strings with a database, using line terminations and parsing... (I think it might have been bplus who mentioned that method.)
Here's how I generally work with handling variable length strings with a database.
For each variable length database, I usually use two databases -- one for the data, and one for an index to the data, which is what I'm doing with the above. (Though sometimes, I'll pack both files into one database, with the index being a set positional header, and the data coming after that header -- but I thought I'd show the simplest form of the process first.)
Now, before I let the demo get too complicated that it might turn folks off from looking at it, I'm just going to post the bare bones of the process first. The code above basically doesn't do anything except allow us to ADD RECORDS, and browse those records sequentially -- but it does show how we'd GET/PUT our information, and track where all that information is while on a disk for us.
RecordNumber is the current record that we're looking at RecordCount is the total number of records which our database contains.
"Demo.dba" is the demo database "Demo.ndx" is the demo index
In AddRecord, you can see where we get the information from the user and how we put the proper information onto the drive for us, so we can access it later, and in ShowMainInfo, you can see the process by which we get that information back for us.
Honestly, I don't think there's anything very complicated about what we're doing here, so I really don't know what I need to comment on, or what questions someone might have about the process. If anyone has any specific questions, feel free to ask, and I'll happily answer them, but the process is really very simple:
One file is the user's data, the other file tracks each record's position and lengths inside that file, so we only retrieve and work with what we want, when we want it.
A simple database is included below, but you can freely ignore it if you want. Just run the code above and add your own records and browse them all you want.
