Steve's Oldies

[SMcNeill]

Going through my drive, just cleaning things up, and I'm running across some old BAS programs which seem interesting, and which I thought I'd share.  Rather than post each of these in their own topic, and clutter up the forums with random stuff, I thought I'd just make one topic and share them all in it. 

IF you guys want one of them separated from the pile, into its own topic, for commenting/searching/finding/highlighting/whatnot, just let me know and I'll do so for it.  Otherwise, as I play around and say, "Hey, this old thing was kinda neat", I'll just share it here for comment and consumption.

First entry -- RainbowText:

Code: QB64: [Select]

1. fg& = _NEWIMAGE(1280, 720, 32)
2. white& = _RGB32(255, 255, 255)
3. SCREEN fg&
4. PRINT "This is a demostration of a simple RainbowText routine."
5. PRINT "One Command is being used to generate all the text which follows."
6. PRINT "Press any key to see some quick samples."
7. junk$ = INPUT$(1)
8.  
9. CLS
10. text$ = "This is sample text"
11. RainbowText text$, 0, 0, 380, 220, 0, 0, 0, 0, 0
12. RainbowText text$, 0, 180, 380, 380, 0, 0, 100, 100, 100
13. RainbowText text$, 0, 90, 300, 300, 0, 0, 150, 150, 150
14. RainbowText text$, 0, 270, 460, 300, 0, 0, 50, 100, 150
15. RainbowText text$, 1, 0, 100, 100, 0, 0, 10, 200, 0
16. RainbowText text$, -1, 0, 300, 100, 0, 0, 200, 200, 0
17.  
18. LOCATE 35, 40: PRINT "Press any key to watch what else you can do!"
19.  
20. junk$ = INPUT$(1)
21.  
22. COLOR , _RGB32(0, 0, 255)
23. direction = .25
24.  
25. DO
26.     CLS
27.     i = i + direction
28.     RainbowText text$, 0, i, 500, 500, 0, 0, r, g, b
29.     IF i > 360 OR i < 0 THEN direction = -direction
30. LOOP UNTIL INKEY$ <> ""
31. _AUTODISPLAY
32. LOCATE 10, 10: PRINT "HA!  Rotating text, and all from 1 simple routine."
33.  
34. CLS
35.  
36.  
37. f& = _LOADFONT("times.ttf", 100)
38. DO
39.     RainbowText text$, 0, 0, 500, 200, f&, 0, r, g, b
40. LOOP UNTIL INKEY$ <> ""
41. _AUTODISPLAY
42.  
43.  
44. END
45.  
46.  
47. SUB RainbowText (text$, slant%, angle%, x%, y%, font&, b&, r, g, b)
48.     A = _AUTODISPLAY: F = _FONT: D = _DEST
49.     dc& = _DEFAULTCOLOR: bg& = _BACKGROUNDCOLOR
50.     slant% = slant% + 1 'This keeps slant 0 as neutral
51.     bgi& = _NEWIMAGE(100, 100, 32): _DEST bgi& 'temporary for sizing
52.     IF font& <> 0 THEN _FONT font&
53.     length% = _PRINTWIDTH(text$): height% = _FONTHEIGHT
54.     _FREEIMAGE bgi&
55.     bgi& = _NEWIMAGE(length%, height%, 32) 'screen to draw to, the proper size
56.     _DEST bgi&: IF font& <> 0 THEN _FONT font&
57.     COLOR _RGB32(255, 255, 255), b&
58.     _PRINTSTRING (0, 0), text$
59.     TLC$ = "BL" + STR$(length% \ 2) + "BU" + STR$(height% \ 2)
60.     RET$ = "BD BL" + STR$(length%)
61.     _SOURCE bgi&
62.     _DEST D
63.     DRAW "BM" + STR$(x%) + "," + STR$(y%) + "TA=" + VARPTR$(angle%) + TLC$
64.     FOR y = 0 TO height% - slant%
65.         FOR x = 0 TO length% - slant%
66.             IF POINT(x, y) <> b& THEN
67.                 r = r + 5
68.                 IF r > 255 THEN r = 0: g = g + 5
69.                 IF g > 255 THEN g = 0: b = b + 5
70.                 IF b > 255 THEN b = 0: r = 0
71.                 DRAW "C" + STR$(_RGB32(r, g, b)) + "R1" 'color and DRAW each pixel
72.             ELSE
73.                 DRAW "B R1" 'color and DRAW each pixel
74.             END IF
75.         NEXT
76.         DRAW RET$
77.     NEXT
78.     IF NOT A THEN _DISPLAY: _AUTODISPLAY 'Remark this line out if you want to manually use _DISPLAY to show the text
79.     _FREEIMAGE bgi&
80.     IF font& <> 0 THEN _FONT F
81.     COLOR dc&, bg&
82. END SUB
83.  

Note, the routine itself is only about 35 lines long, but what it does with such a small number of lines is ASTONISHING.  Slant text.  Rotate Text.  Color blend text...  Don't interfere with any local settings... 

Test it out, have fun with it, tell me what you think.  I'll add more junk as I come across it and find it suitable for sharing.  (A lot isn't, unless you have QB64 v 0.954h and StevesPrecompiler, which was an EXTERNAL precompiler to alter programs and automate a lot of repetitive tasks for me, in the past...)

[SMcNeill]

MOVETEXT:

Code: QB64: [Select]

1. fg& = _NEWIMAGE(1280, 720, 32)
2. f& = 16
3. SCREEN fg&
4. _FONT f&
5. COLOR , _RGB(0, 0, 255)
6. CLS
7. text$ = "This is a sample of moving text"
8. MoveText 100, 400, 1280, 400, text$, 0, _RGB(255, 255, 255), _RGB(100, 100, 100)
9. MoveText 1280, 400, 100, 400, text$, 0, _RGB(255, 255, 255), _RGB(200, 200, 200)
10. MoveText 100, 400, 1000, 100, text$, 0, _RGB(255, 255, 255), _RGB(0, 0, 0)
11. END
12.  
13.  
14. SUB MoveText (x1%, y1%, x2%, y2%, text$, font&, tc&, btc&)
15.  
16.     dc& = _DEFAULTCOLOR: bg& = _BACKGROUNDCOLOR
17.     length% = _PRINTWIDTH(text$): height% = _FONTHEIGHT
18.     bgi& = _NEWIMAGE(length%, height%, 32)
19.     obg& = _NEWIMAGE(ABS(x1% - x2%) + length%, ABS(y1% - y2%) + height%, 32)
20.  
21.     _DEST bgi&
22.     COLOR tc&, btc&
23.     IF font& <> 0 THEN _FONT font&
24.     _PRINTSTRING (0, 0), text$
25.     _DEST 0
26.     hm = x1% - x2% 'hortizonal move
27.     vm = y1% - y2% 'vertical move
28.     hs = hm / ABS(hm) 'hortizontal step
29.     IF hm <> 0 THEN vs = vm / ABS(hm) ELSE vs = vm / ABS(vm) 'vertical step
30.     xstart = x1%: ystart = y1%
31.     xend = x2%: yend = y2%
32.  
33.     'Get our original background
34.     IF x1% < x2% THEN left = x1%: right = x2% ELSE left = x2%: right = x1%
35.     IF y1% < y2% THEN top = y1%: bottom = y2% ELSE top = y2%: bottom = y1%
36.     right = right + length%: bottom = bottom + height%
37.     _PUTIMAGE (0, 0), 0, obg&, (left, top)-(right, bottom)
38.     DO
39.         _LIMIT 200
40.         _PUTIMAGE (left, top), obg&, 0 'Put our background in place
41.         _PUTIMAGE (xstart, ystart), bgi&, 0 'Put our text on the screen
42.         xstart = xstart - hs: ystart = ystart - vs
43.         IF hs >= 0 AND xstart <= xend THEN finish1 = 1
44.         IF hs < 0 AND xstart >= xend THEN finish1 = 1
45.         IF vs >= 0 AND vstart <= yend THEN finish2 = 1
46.         IF vs < 0 AND vstart >= yend THEN finish2 = 1
47.         _DISPLAY
48.     LOOP UNTIL finish1 AND finish2
49.     _FREEIMAGE bgi&: _FREEIMAGE obg&
50.     _AUTODISPLAY
51. END SUB

** Doesn't look as Library friendly as it, as it doesn't track usage of _AUTODISPLAY, which is a newer function and wasn't available back when this was written.

[SMcNeill]

DBF2QB64 --  A program to convert DBF files (database files from Dbase/Foxpro days) to be usable for QB64:

Code: QB64: [Select]

1. REM $DYNAMIC
2.  
3. TYPE DBF_Header
4.     FileType AS _UNSIGNED _BYTE
5.     Year AS _UNSIGNED _BYTE
6.     Month AS _UNSIGNED _BYTE
7.     Day AS _UNSIGNED _BYTE
8.     RecordNumber AS _UNSIGNED LONG
9.     FirstRecord AS _UNSIGNED INTEGER
10.     RecordLength AS _UNSIGNED INTEGER
11.     ReservedJunk AS STRING * 16
12.     TableFlag AS _UNSIGNED _BYTE
13.     CodePageMark AS _UNSIGNED _BYTE
14.     ReservedJunk1 AS STRING * 2
15. END TYPE
16.  
17. TYPE Field_Subrecord
18.     FieldName AS STRING * 11
19.     FieldType AS STRING * 1
20.     Displacement AS _UNSIGNED LONG
21.     FieldLength AS _UNSIGNED _BYTE
22.     FieldDecimal AS _UNSIGNED _BYTE
23.     FieldFlags AS _UNSIGNED _BYTE
24.     AutoNext AS _UNSIGNED LONG
25.     AutoStep AS _UNSIGNED _BYTE
26.     ReservedJunk AS STRING * 8
27. END TYPE
28.  
29. 'The next two types really seem unimportant to us.
30. 'I mainly put them in here so that no one would forget that our database has them.
31. 'After the Field_Subrecords, there is a ENTER byte (CHR$(13)), for an End-of-Subrecord code.
32. 'After that, there MAY be 263 bytes of information which FoxPro tosses into the dbd file.
33. 'Honestly, it seems useless to me, but should be remembered just for documention sake if nothing else.
34.  
35.  
36. TYPE DBF_HeaderTerminator
37.     EndCode AS _UNSIGNED _BYTE 'Our End of Field Code is a CHR$(13), or 13 if we read it as a byte
38. END TYPE
39.  
40. TYPE DBF_VFPInfo
41.     Info AS STRING * 263
42. END TYPE
43.  
44. DIM DataH AS DBF_Header
45. DIM DataFS(1) AS Field_Subrecord
46. 'Notice I didn't even bother to define a variable for our other two types?  That's how important they seem to me.  ;)
47.  
48.  
49. file$ = "z:\tempdata.dbf"
50. file2$ = "z:\converted.txt"
51.  
52. Get_Header file$, DataH
53. 'Display_Header DataH 'You can unremark this line, if you want to see what the Header looks like itself.
54. Get_Fields file$, DataFS()
55. 'Display_Fields DataFS() ' Unremark this line to see how many fields we have, what types, and their properties, if you want.
56. Print_Data file$, DataH, DataFS(), file2$
57. PRINT "Your file has been converted."
58. PRINT "The original file was: "; file$
59. PRINT "The converted file is: "; file2$
60.  
61. END
62.  
63.  
64. SUB Display_Header (DataH AS DBF_Header)
65.     PRINT "Data File Type: ";
66.     SELECT CASE DataH.FileType
67.         CASE 2: PRINT "FoxBASE"
68.         CASE 3: PRINT "FoxBASE+/Dbase III plus, no memo"
69.         CASE 48: PRINT "Visual FoxPro"
70.         CASE 49: PRINT "Visual FoxPro, autoincrement enabled"
71.         CASE 50: PRINT "Visual FoxPro with field type Varchar or Varbinary"
72.         CASE 67: PRINT "dBASE IV SQL table files, no memo"
73.         CASE 99: PRINT "dBASE IV SQL system files, no memo"
74.         CASE 131: PRINT "FoxBASE+/dBASE III PLUS, with memo"
75.         CASE 139: PRINT "dBASE IV with memo"
76.         CASE 203: PRINT "dBASE IV SQL table files, with memo"
77.         CASE 229: PRINT "HiPer-Six format with SMT memo file"
78.         CASE 245: PRINT "FoxPro 2.x (or earlier) with memo"
79.         CASE 251: PRINT "FoxBASE"
80.         CASE ELSE: PRINT "Unknown File Type"
81.     END SELECT
82.     PRINT "Date: "; DataH.Month; "/"; DataH.Day; "/"; DataH.Year
83.     PRINT "Number of Records: "; DataH.RecordNumber
84.     PRINT "First Record: "; DataH.FirstRecord
85.     PRINT "Record Length: "; DataH.RecordLength
86.     PRINT "Reserved Junk: "; DataH.ReservedJunk
87.     PRINT "Table Flags: ";
88.     none = 0
89.     IF DataH.TableFlag AND 1 THEN PRINT "file has a structural .cdx ";: none = -1
90.     IF DataH.TableFlag AND 2 THEN PRINT "file has a Memo field ";: none = -1
91.     IF DataH.TableFlag AND 4 THEN PRINT "file is a database (.dbc) ";: none = -1
92.     IF none THEN PRINT ELSE PRINT "None"
93.     PRINT "Code Page Mark: "; DataH.CodePageMark
94.     PRINT "Reserved Junk: "; DataH.ReservedJunk1
95. END SUB
96.  
97. SUB Display_Fields (DataH() AS Field_Subrecord)
98.     FOR r = 1 TO UBOUND(DataH)
99.         PRINT "Field Name :"; DataH(r).FieldName
100.         PRINT "Field Type :"; DataH(r).FieldType
101.         PRINT "Field Displacement :"; DataH(r).Displacement
102.         PRINT "Field Length :"; DataH(r).FieldLength
103.         PRINT "Field Decimal :"; DataH(r).FieldDecimal
104.         PRINT "Field Flags :"; DataH(r).FieldFlags
105.         PRINT "Field AutoNext :"; DataH(r).AutoNext
106.         PRINT "Field SutoStep :"; DataH(r).AutoStep
107.         PRINT "Field Reserved Junk :"; DataH(r).ReservedJunk
108.         SLEEP
109.         PRINT "**************************"
110.     NEXT
111. END SUB
112.  
113. SUB Get_Header (file$, DataH AS DBF_Header)
114.     OPEN file$ FOR BINARY AS #1 LEN = LEN(DataH)
115.     GET #1, 1, DataH
116.     CLOSE
117. END SUB
118.  
119. SUB Get_Fields (file$, DataFS() AS Field_Subrecord)
120.     DIM databyte AS _UNSIGNED _BYTE
121.     DIM temp AS Field_Subrecord
122.     OPEN file$ FOR BINARY AS #1 LEN = 1
123.     counter = -1: s = 33
124.     DO
125.         counter = counter + 1
126.         GET #1, s, databyte
127.         s = s + 32
128.     LOOP UNTIL databyte = 13
129.     REDIM DataFS(counter) AS Field_Subrecord
130.     IF counter < 1 THEN BEEP: BEEP: PRINT "Database has no file records.": END
131.     CLOSE
132.     OPEN file$ FOR BINARY AS #1 LEN = 32
133.     FOR r = 1 TO counter
134.         GET #1, 32 * r + 1, DataFS(r) 'record 1 is our header info, so we need to start our field info at record 2
135.     NEXT
136.  
137.     CLOSE
138. END SUB
139.  
140. SUB Print_Data (file$, DataH AS DBF_Header, DataFS() AS Field_Subrecord, file2$)
141.     DIM databyte AS _UNSIGNED _BYTE
142.     OPEN file$ FOR BINARY AS #1
143.     OPEN file2$ FOR OUTPUT AS #2
144.     SEEK #1, DataH.FirstRecord + 1
145.     FOR z = 1 TO DataH.RecordNumber
146.         GET #1, , databyte 'This is the first byte which tells us if the record is good, or has been deleted.
147.         IF databyte = 32 THEN WRITE #2, "Good Record", ELSE WRITE #2, "Deleted Record",
148.         FOR i = 1 TO UBOUND(DataFS)
149.             SELECT CASE DataFS(i).FieldType
150.                 CASE "C", "0"
151.                     'C is for Characters, or basically STRING characters.
152.                     '0 is for Null Flags, which I have no clue what they're for.  I'm basically reading them here as worthless characters until I learn otherwise.
153.                     temp$ = ""
154.                     FOR j = 1 TO DataFS(i).FieldLength
155.                         GET #1, , databyte
156.                         temp$ = temp$ + CHR$(databyte)
157.                     NEXT
158.                 CASE "Y"
159.                     'Y is for currency, which is an _INTEGER 64, with an implied 4 spaces for decimal built in.
160.                     REDIM temp AS _INTEGER64
161.                     GET #1, , temp
162.                     temp$ = STR$(temp)
163.                     l = LEN(temp$)
164.                     temp$ = LEFT$(temp$, l - 4) + "." + RIGHT$(temp$, 4)
165.                 CASE "N", "F", "M", "G"
166.                     'N is for numberic, F is for Floating numbers, and both seem to work in the same manner.
167.                     'M is for Memo's, which are stored in a different  DBT file.  What we have here is the block number of the memo location in that file, stored as a simple set of characters.
168.                     'G is for OLE files.  We store the info for it just the same as we do for a Memo.
169.                     'we read the whole thing as a string, which is an odd way for dBase to write it, but I don't make the rules.  I just convert them!
170.                     temp$ = ""
171.                     FOR j = 1 TO DataFS(i).FieldLength
172.                         GET #1, , databyte
173.                         temp$ = temp$ + CHR$(databyte)
174.                     NEXT
175.                 CASE "D"
176.                     'D is for Date fields.
177.                     'Dates are stored as a string, in the format YYYYMMDD
178.                     temp$ = ""
179.                     FOR j = 1 TO DataFS(i).FieldLength
180.                         GET #1, , databyte
181.                         temp$ = temp$ + CHR$(databyte)
182.                     NEXT
183.                     year$ = LEFT$(temp$, 4)
184.                     month$ = MID$(temp$, 5, 2)
185.                     day$ = RIGHT$(temp$, 2)
186.                     temp$ = day$ + "/" + month$ + "/" + year$
187.                 CASE "L"
188.                     'L is our logical operator.  Basically, it's simply True or False Boolean logic
189.                     GET #1, , databyte
190.                     IF databyte = 32 THEN temp$ = "True" ELSE temp$ = "false"
191.                 CASE "@", "O"
192.                     '@ are Timestamps, which I'm too lazy to fully support at the moment.
193.                     'They are 8 bytes - two longs, first for date, second for time.
194.                     'The date is the number of days since  01/01/4713 BC.
195.                     'Time is hours * 3600000L + minutes * 60000L + Seconds * 1000L
196.                     'All I'm going to do is read both longs as a single _Integer64 and then write that data to the disk.
197.                     'Be certain to convert it as needed to make use of the Timestamp.
198.                     'I'm just lazy and don't wanna convert anything right now!  :P
199.  
200.                     'O are double long integers -- basically Integer 64s.  Since I'm reading a timestamp as an Int64, this routine works for them as well.
201.                     REDIM temp1 AS _INTEGER64
202.                     GET #1, , temp1
203.                     temp$ = STR$(temp1)
204.                 CASE "I", "+"
205.                     'Long Integers.  Basically 4 byte numbers
206.                     '+ are auto-increments.  Stored the same way as a Long.
207.                     REDIM temp2 AS LONG
208.                     GET #1, , temp2
209.                     temp$ = STR$(temp2)
210.             END SELECT
211.             IF i = UBOUND(datafs) THEN WRITE #2, temp$ ELSE WRITE #2, temp$,
212.         NEXT
213.     NEXT
214.     CLOSE
215. END SUB

Change the 2 lines with the files to point to where you want them to be, and it's all set to go:

file$ = "z:\tempdata.dbf"  <--- file to convert
file2$ = "z:\converted.txt"  <--- file to save the conversion to

[SMcNeill]

SAC -- Steve's Anorexic Code:

Code: QB64: [Select]

1. 'Steve's Anorexic Code
2. 'This code has a very unique value to us.
3. '1) This allows us to append files to the end of our exe's very easily, and then extract them and clean them up afterwards.
4. '2) This works at a command line level, and lets us shell out from inside a program itself.
5.  
6. 'To use this, first try it a few times with some BACKED UP copy of test files!!
7. 'BACK EM UP!! BACK EM UP!! BACK EM UP!!
8.  
9. 'Got that?  Good.
10.  
11. 'Then run this as a standard program.
12. 'Enter the name of the file you'd like to feed stuff to.
13. 'And at first, -SET THE TABLE   Do this only once, as this sets us a counter for number of files "eatten"
14. 'Then feed it something.  -GOBBLE filename$  <-- this is the file we tack to the end of our exe
15. 'Feed it more files if you want.  Watch the exe grow in size as it absorbs the other files...
16.  
17. 'Is it fat?  Did you feed it enough?
18. 'If so, then -PUKE or -BARF   Throw them files back up!
19.  
20. 'Phew!  Didn't that make a mess?
21. 'Then -CLEAN UP
22. 'See all them files go POOF and disappear again?  We clean up our mess afterwards.
23.  
24. 'But this is MAGIC Anorexic Code!   The exe still has all those files in it that it barfed up.
25. 'Tell it to -PUKE again.
26. 'All those files are back once more!!
27.  
28. 'Use this as a quick, easy way to tack needed files onto your exe to make certain that an user will always have them.
29. 'I use this to  tack sound files, fonts, even images to my exe, and I extract them as needed.
30.  
31. 'NOTE however, that this isn't just limited to EXE files.  You can use this to assemble 100 map files into 1 map compendium,
32. '   and then extract them when needed.   At the moment, we don't puke single files up -- we puke every file up -- but
33. '   someone could modify this easily enough to extract single files from a larger collection.
34.  
35. 'To use as a shell command, use it like the following:
36. '   Shell _hide "SAC.exe g.exe -gobble z:\test.txt"    <--- this would add the test.txt file to the end of the g.exe file'
37. '   syntax is:   SAC.exe file1$ -command file2$
38. '      file1$ would be the file we want to write to -- or feed.
39. '      -command is the -command which we want to execute.   -SET THE TABLE, -GOBBLE, -BARF, -CLEAN UP
40.  
41. 'Simple, and useful as heck!   :D
42.  
43.  
44. DIM SHARED SAC_FileName AS STRING
45. parameter$ = LTRIM$(RTRIM$(COMMAND$))
46. IF parameter$ <> "" THEN
47.     dash = INSTR(parameter$, "-")
48.     SAC_FileName = LTRIM$(RTRIM$(LEFT$(parameter$, dash - 1)))
49.     parameter$ = RTRIM$(LTRIM$(RIGHT$(parameter$, LEN(parameter$) - dash + 1)))
50.     PRINT SAC_FileName, parameter$
51.     END
52.     DoSAC parameter$
53.     SYSTEM
54. END IF
55.  
56. PRINT "Give me the name of your file to stuff =>";
57. INPUT SAC_FileName
58. DO
59.     CLS
60.     PRINT SAC_FileName
61.     PRINT
62.     PRINT "1) Initialize"
63.     PRINT "2) Gobble Something"
64.     PRINT "3) Puke"
65.     PRINT "4) Clean Up"
66.     PRINT "5) End"
67.     a$ = INPUT$(1)
68.     a = VAL(a$)
69.     SELECT CASE a
70.         CASE 1: DoSAC "-INIT": PRINT "Initialized"
71.         CASE 2:
72.             PRINT "Name of file to eat:";
73.             INPUT name$
74.             name$ = "-GOBBLE " + name$
75.             DoSAC name$
76.         CASE 3: DoSAC "-BARF"
77.         CASE 4: DoSAC "-CLEAN UP"
78.         CASE 5: SYSTEM
79.     END SELECT
80.     SLEEP
81. LOOP
82.  
83.  
84. SUB DoSAC (t$)
85.     DIM b AS _UNSIGNED _BYTE
86.     DIM text AS STRING * 1
87.     DIM l(10) AS _UNSIGNED _INTEGER64, l AS _UNSIGNED _INTEGER64
88.     DIM SACfile AS STRING * 255
89.     f = FREEFILE
90.     SELECT CASE UCASE$(t$)
91.         CASE "-SET THE TABLE", "-SET", "-INIT"
92.             'initialize
93.             OPEN SAC_FileName FOR BINARY AS #f
94.             SEEK #f, LOF(f) + 1
95.             b = 0
96.             PUT #f, , b
97.         CASE "-BARF", "-PUKE"
98.             'puke it all up
99.             OPEN SAC_FileName FOR BINARY AS #f
100.             SEEK #f, LOF(f)
101.             GET #f, , b
102.             IF b < 1 THEN PRINT "No files have been gorged on by this program.  FEED ME SOME!!": BEEP: BEEP: END
103.             PRINT b; "files to puke up!"
104.             CurrentPos = LOF(f) + 1
105.             AmountAte = b
106.             FOR i&& = 1 TO AmountAte
107.                 CurrentPos = CurrentPos - 256
108.                 GET #f, CurrentPos, SACfile
109.                 file$ = LTRIM$(RTRIM$(SACfile))
110.                 PRINT file$; " barfed up!"
111.                 CurrentPos = CurrentPos - 8
112.                 GET #f, CurrentPos, l
113.                 CurrentPos = CurrentPos - l
114.                 g = FREEFILE
115.                 SEEK #f, CurrentPos
116.                 OPEN file$ FOR BINARY AS #g
117.                 FOR j&& = 1 TO l
118.                     GET #f, , b
119.                     PUT #g, , b
120.                 NEXT
121.                 b = 0
122.                 PUT #g, , b
123.                 CLOSE #g
124.             NEXT
125.         CASE "-CLEAN UP"
126.             'clean up the drive of all the puke
127.             OPEN SAC_FileName FOR BINARY AS #f
128.             SEEK #f, LOF(f)
129.             GET #f, , b
130.             IF b < 1 THEN PRINT "No files have been gorged on by this program.  FEED ME SOME!!": BEEP: BEEP: END
131.             PRINT b; "puked up files to clean up!"
132.             CurrentPos = LOF(f) + 1
133.             AmountAte = b
134.             FOR i&& = 1 TO AmountAte
135.                 CurrentPos = CurrentPos - 256
136.                 GET #f, CurrentPos, SACfile
137.                 file$ = LTRIM$(RTRIM$(SACfile))
138.                 PRINT file$; " cleaned up off the dinner table!"
139.                 CurrentPos = CurrentPos - 8
140.                 GET #f, CurrentPos, l
141.                 CurrentPos = CurrentPos - l
142.                 KILL file$
143.             NEXT
144.         CASE ELSE
145.             IF LEFT$(t$, 8) = "-GOBBLE " THEN
146.                 file$ = RIGHT$(t$, LEN(t$) - 8)
147.                 IF _FILEEXISTS(file$) THEN
148.                     PRINT "Eatting "; file$
149.                     'eat stuff
150.                     OPEN SAC_FileName FOR BINARY AS #f
151.                     l(0) = LOF(f)
152.                     SEEK #f, l(0)
153.                     GET #f, , b
154.                     AmountEat = b
155.                     g = FREEFILE
156.                     OPEN file$ FOR BINARY AS #g
157.                     l(1) = LOF(g)
158.                     FOR i&& = 1 TO l(1)
159.                         GET #g, , b
160.                         PUT #f, , b
161.                     NEXT
162.                     CLOSE #g
163.                     PUT #f, , l(1)
164.                     SACfile = file$
165.                     PUT #f, , SACfile
166.                     b = AmountEat + 1
167.                     PUT #f, , b
168.                     PRINT file$, " was tasty!"
169.                 ELSE
170.                     'Do nothing as the file doesn't exist.
171.                     PRINT "WARNING: "; file$; " does not exist!"
172.                     BEEP: BEEP
173.                 END IF
174.             END IF
175.     END SELECT
176.     CLOSE #f
177. END SUB

One of the weirdest little programs which I have ever written, and yet it was something a lot of folks enjoyed at the time.  What's it do, you ask...

It EATS files that we tell it to, making them disappear from our hard drive, as it gets ever fatter.... Then, when we've "fed" it enough, it sits there and feels miserable for itself until we tell it to BARF them back up for us.

It's basically a file stacking/restoration program at its heart, and useful for sticking dozens of resource files together and packaging them into one file, then extracting them as needed.

[SMcNeill]

SCREENGRAB and SCREENRESTORE -- grab a screen, save it to disk, load and restore it later when you want to in your program:

Code: QB64: [Select]

1. InitializeScreen
2. ScreenGrab "test.bin"
3. _DELAY 2: CLS 'a pause to see the orignal screen, then clear it
4. _DELAY 2 ' so we can see the blanked screen
5. ScreenRestore "test.bin" 'and the restored one
6. END
7.  
8. SUB ScreenGrab (file$)
9.     DIM m AS _MEM: m = _MEMIMAGE(0)
10.     t$ = SPACE$(m.SIZE)
11.     f = FREEFILE
12.     OPEN file$ FOR OUTPUT AS #f: CLOSE #f
13.     OPEN file$ FOR BINARY AS #f
14.     _MEMGET m, m.OFFSET, t$
15.     PUT #f, , t$
16.     CLOSE #f
17.     _MEMFREE m
18. END SUB
19.  
20.  
21. SUB InitializeScreen
22.     SHARED s&
23.     f& = _LOADFONT("OLDENGL.TTF", 76)
24.     s& = _NEWIMAGE(1280, 720, 32)
25.     SCREEN s&: _FONT f&
26.     RANDOMIZE TIMER
27.     FOR i = 1 TO 100
28.         LINE (RND * _WIDTH, RND * _HEIGHT)-(RND * 255, RND * 255), _RGB(RND * 255, RND * 255, RND * 255), BF
29.     NEXT
30.     COLOR _RGB32(255, 0, 0), 0
31.     _PRINTSTRING ((_WIDTH - _PRINTWIDTH("Steve is awesome!")) / 2, 0), "Steve is awesome!"
32.     _FONT 16: _FREEFONT f&
33. END SUB
34.  
35.  
36.  
37. SUB ScreenRestore (file$)
38.     DIM m AS _MEM: m = _MEMIMAGE(0)
39.     t$ = SPACE$(m.SIZE)
40.     f = FREEFILE
41.     OPEN file$ FOR BINARY AS #f
42.     GET #f, , t$
43.     CLOSE #f
44.     _MEMPUT m, m.OFFSET, t$
45.     _MEMFREE m
46. END SUB

[SMcNeill]

Ummm.... A demo of a bunch of different routines from my text library:

Code: QB64: [Select]

1. DIM ColorArray(10) AS _UNSIGNED LONG
2.  
3. SCREEN _NEWIMAGE(1400, 1000, 32)
4. _SCREENMOVE _MIDDLE
5.  
6. CLS
7.  
8. ColorArray(0) = 3
9. ColorArray(1) = _RGB32(255, 0, 0)
10. ColorArray(2) = _RGB32(255, 255, 255)
11. ColorArray(3) = _RGB32(0, 0, 255)
12.  
13. a& = _LOADIMAGE("qb64.png", 32)
14. DisplayImage a&, 300, 500, 0, 0 'Show the original bee
15.  
16. RainbowImage a&, ColorArray(), 1, 0, 1 'Rainbow the Bee's background
17. DisplayImage a&, 700, 500, 0, 0
18. _FREEIMAGE a&
19. a& = _LOADIMAGE("qb64.png", 32) 'reload the image (we altered it before with the last RainbowImage call)
20. RainbowImage a&, ColorArray(), 1, 0, 0 'Rainbow the Bee
21. DisplayImage a&, 500, 500, 0, 0
22.  
23. b& = SaveBackground&
24.  
25. c& = TextToImage("This is moving rainbow text!", 16, _RGB32(255, 0, 0), 0, 0)
26. ScaleImage c&, 3, 3
27. ColorArray(0) = 0
28. RainbowImage c&, ColorArray(), _RGB32(255, 0, 0), 0, 0
29.  
30. FOR i = 100 TO 700
31.     RestoreBackground b&
32.     DisplayImage a&, i, i, i, 0
33.     DisplayImage a&, 800 - i, 800 - i, i, 1
34.     DisplayImage c&, 300, i - 100, i, 0
35.     _DISPLAY
36. NEXT
37. _FREEIMAGE a&
38. _FREEIMAGE b&
39. _FREEIMAGE c&
40.  
41.  
42. END
43.  
44. SUB RainbowImage (Image AS LONG, c() AS _UNSIGNED LONG, fc AS _UNSIGNED LONG, bfc AS _UNSIGNED LONG, mode AS _BYTE)
45.     'Image is our image handle created by TextToImage
46.     'C() is our color array.  c(0) tells us how many colors to use to blend (from 0 - our color array limit)
47.     'If 0, we go with the default rainbow color routine
48.     'If 1, we get a solid color, whatever is c(1)
49.     'If more than 1, we blend our colors from (c1) to c(2) to c(3) to c(4) to c(...up to our limit)
50.     'fc is our foreground color (or font color if you're coloring text)
51.     'bfc is our background color (or background font color, for text)
52.     'mode is how we create our rainbow.  0 is for the foreground to be rainbow, 1 is for background
53.  
54.     w = _WIDTH(Image): h = _HEIGHT(Image)
55.     _SOURCE Image
56.     _DEST Image
57.     IF c(0) < 1 THEN c(0) = 0
58.     SELECT CASE c(0)
59.         CASE 0
60.             'This is the default, where we print a nice balanced rainbow
61.  
62.             r = 255: g = 0: b = 0
63.             s = 1275 / _WIDTH(Image)
64.             FOR i = 0 TO _WIDTH(Image) - 1
65.                 DO
66.                     IF r >= 255 AND g <= 0 AND b <= 0 THEN rc = 0: gc = s: bc = 0: EXIT DO 'Add a new color
67.                     IF r >= 255 AND g >= 255 AND b <= 0 THEN rc = -s: gc = 0: bc = 0: EXIT DO 'subtract the old color
68.                     IF g >= 255 AND b <= 0 AND r <= 0 THEN rc = 0: gc = 0: bc = s: EXIT DO 'Add a new color
69.                     IF g >= 255 AND b >= 255 AND r <= 0 THEN rc = 0: gc = -s: bc = 0: EXIT DO 'subtract the old color
70.                     IF b >= 255 AND r <= 0 AND g <= 0 THEN rc = s: gc = 0: bc = 0: EXIT DO 'Add a new color
71.                     IF b >= 255 AND r >= 255 AND g <= 0 THEN rc = 0: gc = 0: bc = -s: EXIT DO 'subtract the old color
72.                     EXIT DO
73.                 LOOP
74.                 r = r + rc: g = g + gc: b = b + bc
75.                 IF r < 0 THEN r = 0
76.                 IF r > 255 THEN r = 255
77.                 IF g < 0 THEN g = 0
78.                 IF g > 255 THEN g = 255
79.                 IF b < 0 THEN b = 0
80.                 IF b > 255 THEN b = 255
81.                 FOR j = 0 TO _HEIGHT(Image) - 1
82.                     IF mode = 1 THEN
83.                         IF POINT(i, j) = bfc THEN
84.                             PSET (i, j), _RGB32(r, g, b)
85.                         END IF
86.                     ELSE
87.                         IF POINT(i, j) <> bfc THEN
88.                             PSET (i, j), _RGB32(r, g, b)
89.                         END IF
90.                     END IF
91.                 NEXT
92.             NEXT
93.         CASE 1
94.             FOR i = 0 TO _WIDTH(Image) - 1
95.                 FOR j = 0 TO _HEIGHT(Image) - 1
96.                     IF mode = 1 THEN
97.                         IF POINT(i, j) = bfc THEN
98.                             PSET (i, j), c(1)
99.                         END IF
100.                     ELSE
101.                         IF POINT(i, j) <> bfc THEN
102.                             PSET (i, j), c(1)
103.                         END IF
104.                     END IF
105.                 NEXT
106.             NEXT
107.         CASE ELSE
108.             s = ((c(0) - 1) * 255) / _WIDTH(Image)
109.             'our scale is going to depend on how many colors we blend.   It's 255 steps from 1 color to another in this process.
110.             'c(0) is how many colors we blend
111.             BlendOn = 1: counter = 0: counter2 = 1
112.             FOR i = 0 TO _WIDTH(Image)
113.                 counter = counter + s
114.                 _SOURCE Image
115.                 _DEST Image
116.                 Reverse_RGB c(BlendOn), r1%, g1%, b1%
117.                 Reverse_RGB c(BlendOn + 1), r2%, g2%, b2%
118.                 rd = (r1% - r2%) / 255 * s
119.                 gd = (g1% - g2%) / 255 * s
120.                 bd = (b1% - b2%) / 255 * s
121.                 ru = r1% - rd * (i - subtract)
122.                 gu = g1% - gd * (i - subtract)
123.                 bu = b1% - bd * (i - subtract)
124.                 coloruse~& = _RGB32(ru, gu, bu)
125.                 FOR j = 0 TO _HEIGHT(Image) - 1
126.                     IF mode = 1 THEN
127.                         IF POINT(i, j) = bfc THEN
128.                             PSET (i, j), coloruse~&
129.                         END IF
130.                     ELSE
131.                         IF POINT(i, j) <> bfc THEN
132.                             PSET (i, j), coloruse~&
133.                         END IF
134.                     END IF
135.                 NEXT
136.                 IF counter \ 255 >= counter2 THEN
137.                     BlendOn = BlendOn + 1
138.                     counter2 = counter2 + 1
139.                     subtract = i
140.                 END IF
141.  
142.             NEXT
143.  
144.     END SELECT
145.     _DEST 0
146. END SUB
147.  
148. FUNCTION SaveBackground&
149.     SaveBackground& = _COPYIMAGE(0)
150. END FUNCTION
151.  
152. SUB UpdateBackground (Image AS LONG)
153.     _PUTIMAGE , 0, Image
154. END SUB
155.  
156. SUB RestoreBackground (Image AS LONG)
157.     _PUTIMAGE , Image, 0
158. END SUB
159.  
160. SUB Reverse_RGB (c~&, r%, g%, b%)
161.     h$ = HEX$(c~&)
162.     a$ = LEFT$(h$, 2)
163.     r$ = "&H" + MID$(h$, 3, 2)
164.     g$ = "&H" + MID$(h$, 5, 2)
165.     b$ = "&H" + MID$(h$, 7, 2)
166.     r% = VAL(r$)
167.     g% = VAL(g$)
168.     b% = VAL(b$)
169. END SUB
170.  
171.  
172.  
173. FUNCTION TextToImage& (text$, font&, fc&, bfc&, mode AS _BYTE)
174.     'Mode 1 is print forwards
175.     'Mode 2 is print backwards
176.     'Mode 3 is print from top to bottom
177.     'Mode 4 is print from bottom up
178.  
179.  
180.     IF mode < 1 OR mode > 4 THEN mode = 1
181.     dc& = _DEFAULTCOLOR: bgc& = _BACKGROUNDCOLOR
182.     IF font& <> 0 THEN _FONT font&
183.     IF mode < 3 THEN
184.         'print the text lengthwise
185.         w& = _PRINTWIDTH(text$): h& = _FONTHEIGHT
186.     ELSE
187.         'print the text vertically
188.         FOR i = 1 TO LEN(text$)
189.             IF w& < _PRINTWIDTH(MID$(text$, i, 1)) THEN w& = _PRINTWIDTH(MID$(text$, i, 1))
190.         NEXT
191.         h& = _FONTHEIGHT * (LEN(text$))
192.     END IF
193.     TextToImage& = _NEWIMAGE(w&, h&, 32)
194.     _DEST TextToImage&
195.     IF font& <> 0 THEN _FONT font&
196.     COLOR fc&, bfc&
197.  
198.     SELECT CASE mode
199.         CASE 1
200.             'Print text forward
201.             _PRINTSTRING (0, 0), text$
202.         CASE 2
203.             'Print text backwards
204.             temp$ = ""
205.             FOR i = 0 TO LEN(text$) - 1
206.                 temp$ = temp$ + MID$(text$, LEN(text$) - i, 1)
207.             NEXT
208.             _PRINTSTRING (0, 0), temp$
209.         CASE 3
210.             'Print text upwards
211.             'first lets reverse the text, so it's easy to place
212.             temp$ = ""
213.             FOR i = 0 TO LEN(text$) - 1
214.                 temp$ = temp$ + MID$(text$, LEN(text$) - i, 1)
215.             NEXT
216.             'then put it where it belongs
217.             FOR i = 1 TO LEN(text$)
218.                 fx = (w& - _PRINTWIDTH(MID$(temp$, i, 1))) / 2 + .99 'This is to center any non-monospaced letters so they look better
219.                 _PRINTSTRING (fx, _FONTHEIGHT * (i - 1)), MID$(temp$, i, 1)
220.             NEXT
221.         CASE 4
222.             'Print text downwards
223.             FOR i = 1 TO LEN(text$)
224.                 fx = (w& - _PRINTWIDTH(MID$(text$, i, 1))) / 2 + .99 'This is to center any non-monospaced letters so they look better
225.                 _PRINTSTRING (fx, _FONTHEIGHT * (i - 1)), MID$(text$, i, 1)
226.             NEXT
227.             _DISPLAY
228.     END SELECT
229.     _DEST 0
230.     COLOR dc&, bgc&
231.     _AUTODISPLAY
232. END FUNCTION
233.  
234. SUB ScaleImage (Image AS LONG, xscale AS SINGLE, yscale AS SINGLE)
235.     w = _WIDTH(Image): h = _HEIGHT(Image)
236.     w2 = w * xscale: h2 = h * yscale
237.     NewImage& = _NEWIMAGE(w2, h2, 32)
238.     _PUTIMAGE , Image, NewImage&
239.     _FREEIMAGE Image
240.     Image = NewImage&
241. END SUB
242.  
243. SUB DisplayImage (Image AS LONG, x AS INTEGER, y AS INTEGER, angle AS SINGLE, mode AS _BYTE)
244.     DIM px(3) AS INTEGER, py(3) AS INTEGER, w AS INTEGER, h AS INTEGER
245.     DIM sinr AS SINGLE, cosr AS SINGLE, i AS _BYTE
246.     w = _WIDTH(Image): h = _HEIGHT(Image)
247.     SELECT CASE mode
248.         CASE 0 'center
249.             px(0) = -w \ 2: py(0) = -h \ 2: px(3) = w \ 2: py(3) = -h \ 2
250.             px(1) = -w \ 2: py(1) = h \ 2: px(2) = w \ 2: py(2) = h \ 2
251.         CASE 1 'top left
252.             px(0) = 0: py(0) = 0: px(3) = w: py(3) = 0
253.             px(1) = 0: py(1) = h: px(2) = w: py(2) = h
254.         CASE 2 'bottom left
255.             px(0) = 0: py(0) = -h: px(3) = w: py(3) = -h
256.             px(1) = 0: py(1) = 0: px(2) = w: py(2) = 0
257.         CASE 3 'top right
258.             px(0) = -w: py(0) = 0: px(3) = 0: py(3) = 0
259.             px(1) = -w: py(1) = h: px(2) = 0: py(2) = h
260.         CASE 4 'bottom right
261.             px(0) = -w: py(0) = -h: px(3) = 0: py(3) = -h
262.             px(1) = -w: py(1) = 0: px(2) = 0: py(2) = 0
263.     END SELECT
264.     sinr = SIN(angle / 57.2957795131): cosr = COS(angle / 57.2957795131)
265.     FOR i = 0 TO 3
266.         x2 = (px(i) * cosr + sinr * py(i)) + x: y2 = (py(i) * cosr - px(i) * sinr) + y
267.         px(i) = x2: py(i) = y2
268.     NEXT
269.     _MAPTRIANGLE (0, 0)-(0, h - 1)-(w - 1, h - 1), Image TO(px(0), py(0))-(px(1), py(1))-(px(2), py(2))
270.     _MAPTRIANGLE (0, 0)-(w - 1, 0)-(w - 1, h - 1), Image TO(px(0), py(0))-(px(3), py(3))-(px(2), py(2))
271. END SUB
272.  

Requires the image file attached below to work properly.

[SMcNeill]

And, I'm going to call that "it" for this first batch of stuff to share and post.  I'm off to get some food and spend some time with the wife.  Tomorrow, if I'm not busy doing anything else, I'll do some digging into the old folders and see what else is out there that I can share for those who might enjoy browsing a collection of weird and unusual junk.  :P

Feel free to comment, post any questions, or issues below.  A lot of this seems to have came from SDL days (back when I was still using SDL 0.954H), and I don't guarantee that any of it is 100% error free.  Heck, I don't even guarantee that this is the newest, bestest version of any of this stuff.   This is simply old programs which were sitting around in an aptly labeled QB64\SDL\Programs\STUFF folder, which I thought I'd test out and share for those who might be interested in any of it. 

A lot of this probably does have better, more up-to-date versions out there somewhere.  The issue would be finding where those versions might be hiding on my drive at....   ;D

[Pete]

How can RAINBOW TEXT be all that old? I don't have the newest QB64 version, because the line: A = _AUTODISPLAY: F = _FONT: D = _DEST was not accepted. I ran it and kept pressing the space bar, at which point it eventually crashed. I probably need the most updated version of QB64 to run what you call an oldie?

Anyway, I got some of the effects, and you're right, the statements are few for the output generated. That in itself is pretty cool. Now that I'm older I'm beginning to appreciated not having to code every little thing to get a desired result. In the beginning, it was fun, because you had to know your stuff to program but obviously the closer we can get to Star Trek computers the better our productivity, which is what computers were invented for in the first place, well, except for TOSHIBA computers, which were created to anchor small boats while in port.

OK, just saw you made a new pot for a screen image copy function. I have one of those from Fell I think, so I thought I'd try yours. I had to sub in LUCON fonts, I don't have oldenglish or whatever, anyway, I could not get it to pass the "test.bin" parameter to the file$ variable in the subroutine. I use CALL SUB, which is configured a bit differently, so I changed it a bit to this, and got it to work for me, cool!

file$ = "test.bin"
CALL ScreenGrab(file$)
_DELAY 2: CLS 'a pause to see the orignal screen, then clear it
_DELAY 2 ' so we can see the blanked screen
CALL ScreenRestore(file$) 'and the restored one

Anyway, Mr. awesome, you typed "original" wrong in the REM statement! Sorry, still working with my exorcist to stop channeling Clippy. :(

Pete

[SMcNeill]

How can RAINBOW TEXT be all that old?

It's an updated version of the old program, which I found and shared for folks who aren't still in the stone age like us.  :P

The actual SDL version would be this one, which runs MUCH slower (notice the direction variable is only 1 here, so 1/4th as much calculation, and it's STILL slow rotating the text).   I saw the updated version and posted it above, but this was the original, which should work for old dinosaurs like you and Clippy:

Code: QB64: [Select]

1. fg& = _NEWIMAGE(1280, 720, 32)
2. white& = _RGB32(255, 255, 255)
3. SCREEN fg&
4. PRINT "This is a demostration of a simple AlterText routine."
5. PRINT "One Command is being used to generate all the text which follows."
6. PRINT "Press any key to see some quick samples."
7. junk$ = INPUT$(1)
8.  
9. CLS
10. text$ = "This is sample text"
11. RainbowText text$, 0, 0, 380, 220, 0, 0, 0, 0, 0
12. RainbowText text$, 0, 180, 380, 380, 0, 0, 100, 100, 100
13. RainbowText text$, 0, 90, 300, 300, 0, 0, 150, 150, 150
14. RainbowText text$, 0, 270, 460, 300, 0, 0, 50, 100, 150
15. RainbowText text$, 1, 0, 100, 100, 0, 0, 10, 200, 0
16. RainbowText text$, -1, 0, 300, 100, 0, 0, 200, 200, 0
17. _AUTODISPLAY
18. LOCATE 35, 40: PRINT "Press any key to watch what else you can do!"
19.  
20. junk$ = INPUT$(1)
21.  
22. COLOR , _RGB32(0, 0, 255)
23. direction = 1
24. 'direction = 10
25. DO
26.     CLS
27.     i = i + direction
28.     RainbowText text$, 0, i, 500, 500, 0, 0, r, g, b
29.     'RainbowText text$, 0, i, 200, 200, _RGB32(255, 0, 0), _RGB32(255, 255, 0)
30.     IF i > 360 OR i < -360 THEN direction = -direction
31. LOOP UNTIL INKEY$ <> ""
32. _AUTODISPLAY
33. LOCATE 10, 10: PRINT "HA!  Rotating text, and all from 1 simple routine."
34.  
35. CLS
36.  
37.  
38.  
39. DO
40.     f& = _LOADFONT("times.ttf", 100)
41.     _FONT f&
42.     RainbowText text$, 0, 0, 500, 200, f&, 0, r, g, b
43. LOOP UNTIL INKEY$ <> ""
44. _AUTODISPLAY
45.  
46.  
47. END
48.  
49.  
50. SUB RainbowText (text$, slant%, angle%, x%, y%, font&, b&, r, g, b)
51.     dc& = _DEFAULTCOLOR: bg& = _BACKGROUNDCOLOR
52.     slant% = slant% + 1 'This keeps slant 0 as neutral
53.     length% = _PRINTWIDTH(text$): height% = _FONTHEIGHT
54.     bgi& = _NEWIMAGE(length%, height%, 32)
55.     _DEST bgi&
56.     IF font& <> 0 THEN _FONT font&
57.     COLOR _RGB32(255, 255, 255), b&
58.     _PRINTSTRING (0, 0), text$
59.     TLC$ = "BL" + STR$(length% \ 2) + "BU" + STR$(height% \ 2)
60.     RET$ = "BD BL" + STR$(length%)
61.     _SOURCE bgi&
62.     _DEST 0
63.     DRAW "BM" + STR$(x%) + "," + STR$(y%) + "TA=" + VARPTR$(angle%) + TLC$
64.     FOR y = 0 TO height% - slant%
65.         FOR x = 0 TO length% - slant%
66.             IF POINT(x, y) <> b& THEN
67.                 r = r + 5
68.                 IF r > 255 THEN r = 0: g = g + 5
69.                 IF g > 255 THEN g = 0: b = b + 5
70.                 IF b > 255 THEN b = 0: r = 0
71.                 DRAW "C" + STR$(_RGB32(r, g, b)) + "R1" 'color and DRAW each pixel
72.             ELSE
73.                 DRAW "B R1" 'color and DRAW each pixel
74.             END IF
75.         NEXT
76.         DRAW RET$
77.     NEXT
78.     _DISPLAY: _AUTODISPLAY
79.     _FREEIMAGE bgi&: IF font& <> 0 THEN _FONT 16: _FREEFONT font&
80.     COLOR dc&, bg&
81. END SUB

[Pete]

This line crashes my two GL versions:

RainbowText text$, 0, 0, 500, 200, f&, 0, r, g, b

But it does run in my older SDL version, albeit the rotating text is slower, as you indicated. I'm glad the SDL version displays the RainbowText text line. It was my favorite of the demo.

Now if you will excuse me, there's a large meteor shower coming my way, and I wouldn't want to miss it.

Pete

[SMcNeill]

This line crashes my two GL versions:

RainbowText text$, 0, 0, 500, 200, f&, 0, r, g, b

But it does run in my older SDL version, albeit the rotating text is slower, as you indicated. I'm glad the SDL version displays the RainbowText text line. It was my favorite of the demo.

Now if you will excuse me, there's a large meteor shower coming my way, and I wouldn't want to miss it.

Pete

Does it not find the font?  I'm kinda wondering what the crash issue might be with it.  It works here, for me, in SDL up...

[Pete]

I already thought about the font possibility, too; so I searched for the direct path to my lucon.ttf path, and placed the absolute pathway in the code, and it worked in my GL versions.

C:\Windows\winsxs\amd64_microsoft-windows-f..etype-lucidaconsole_31bf3856ad364e35_6.1.7600.16385_none_(AND SO ON AND SO FORTH, GEESH!)

I think I have excluded some of the fonts packed with various QB version, so that's probably the problem I was experiencing.

Pete