It looks like SCREEN() function was broken in one of the updates, either that or it's not designed anymore to work in graphic modes. Particularly in 32-bit color.
Below the message it returns 219 and the solid block.
The thing is that I want to read characters from "PRINT USING" output without setting up another hidden screen for it and without creating a temporary file which causes wear and tear on the system due to the thousand calls that my program could potentially generate from it.
After being run my program kept returning an illegal function call because QB64PE doesn't seem to like neither the text coordinates given to it for SCREEN() function. It looks like one cannot set a _FONT and then call SCREEN().
Run this example:
Code: (Select All)
screen _newimage(800, 600, 32)
dim i as integer, amf as long
amf = _loadfont("/usr/share/fonts/liberation/LiberationSans-Regular.ttf", 12)
_font amf
for i = 1 to 120
locate 4, i
print chr$(i + 32);
locate 5, 1
print i; screen(4, i);
next
end
Tested on Linux; replace the _LOADFONT() line with the appropriate for MacOS or Windows. I have tried this with a monospace font, and with optional "MONOSPACE" parameter to _LOADFONT(). This doesn't even go beyond the first position.
So I guess I will have to do without "PRINT USING" formatting toward using _PRINTSTRING or _UPRINTSTRING.
I hope to post fun little bits of code and then try to comment them as fully as I can in attempts to get people new to QB64 up and running faster. Feel free to ask questions to get clarification, I may have screwed up.
_Title "Playing for Charity: 100 dice" ' b+ 2023-05-20
' A game that no one loses!
Randomize Timer
Dim As Long roll, Charity, me, r
For roll = 1 To 100
r = Int(Rnd * 6) + 1
Print " Roll number:"; roll; "is"; r
If r < 5 Then Charity = Charity + r Else me = me + r
Print: Print " I get 5's and 6's:"; me
Print " Charity gets 1, 2, 3, 4's:"; Charity
Print: Print " zzz... press any to continue"
Print
Sleep
Next
Print: Print " Treat ";
If me > Charity Then Print "yourself"; Else Print "Others";
Print " specially well today."
Then I decided if I really wanted to do something Friendly I should comment more fully for Beginners.
So here is same resulting output with lots of comments:
Code: (Select All)
' The following not in original code but a very good habit to get into, it will save you
' from your typos. 3P = Proper Programming Practice :)
Option _Explicit ' This forces you to Dim (or ReDim) your variables before you use them.
' !!! EXCEPTION !!! should you do something like DEFINT A-Z or DEFLNG A-Z then everything
' is automatically. :O
' If the following is in the first lines of your program and you go to save it, QB64 IDE
' will suggest your _Title string for your .bas file name when starting from File > New.
_Title "Playing for Charity: 100 dice" ' b+ 2023-05-20 < 3P author and date with _Title.
' A game that no one loses! < 3P a quick summary or comments. I usually list versions here.
Randomize Timer ' this is here so I don't play the same game over on each run.
' Dim As Long roll, Charity, me, r < 3P originally I had this, but really strong 3P is
' declaring all your variables first 2nd part of Option _Explicit team.
Dim As Long roll ' this tracks the For loop index eg roll number
Dim As Long r ' this is for random to be used to store the dice roll value.
Dim As Long Charity ' variable to store running total points for Charity
Dim As Long me ' variable to store running total points for me.
' I am using Long because I want Integers and Long is easier to type and doesn't take more
' time than Integer Type. So I get a range of over 32,000 with 0 cost.
For roll = 1 To 100 ' the main loop does 100 rolls
r = Int(Rnd * 6) + 1 ' Rnd = 0 to .9999 Multiply by 6 and have 0 to 5.9999
' Take Int(0 to 5.99999) get 0,1,2,3,4,5
' Add 1 for 1 to 6
'
' Print something; < with semi colon ending keeps the print head right where it stops.
' Print something, < with comma tabs the print head right to set column widths
' Print something < nothing after literals or variables moves print head to next line.
' Print will automatically start on next line if can't finish print job on current one.
' Print: < finishes last print line or starts new one by inserting blank line.
Print " Roll number:"; roll; "is"; r ' this first line reporting roll number and roll.
If r < 5 Then Charity = Charity + r Else me = me + r ' this decides if me or Charity
' gets the rolled points
' This reports the running scores and tells Sleep is activated so we have to press a key
' to continue game.
Print: Print " I get 5's and 6's:"; me
Print " Charity gets 1, 2, 3, 4's:"; Charity
Print: Print " zzz... press any to continue"
Print
Sleep
Next ' end of 100 rolls loop onto summary result.
Print: Print " Treat ";
If me > Charity Then Print "yourself"; Else Print "Others";
Print " specially well today."
' the End < 3P if you had GoSubs after this End put an End statement here.
I decided to post the 2nd one here first because A) this is my favorite forum and B) it is likely to be seen more here.
C) I thought it an excellent first post for this thread.
Trying to implement version string per library.
I don't want to have for each library a separate CONST or SUB/FUNCTION with different name just to get it's version string.
I also don't want to hardcode the library names and versions in a single place.
DATA / READ / RESTORE doesn't work, because RESTORE doesn't accept a variable.
Any ideas how I could implement this?
I have been playing around with various ideas but it seems the fonts are loaded differently or displayed differently from 3.6.0 and 3.7.0. Not sure if I have to adjust what I am doing to make it look good again but, personally, I can't accept how they look. Here is a comparision side by side of the two different versions.
You can see the new hotness on the left and the old and busted on the right. Look at the '2's and 'o's. They are cut-off. The problem seems to show itself on lower font sizes where letters are being cut off. (the 3rd line is using a large font and being scaled down as a temp work around but still doesn't look as good as it should if you ask me...)
Here is a quick program ran in 3.7.0
Same code on 3.6.0
You can see in 3.7.0 that 'J' and '2' is being cut (oddly the 'o' isn't) and gets worse the smaller the font size loaded.
has information that no longer applies, checking this out in QB64PE v3.4, as well as v3.7 just now.
This is what it currently has to say about where the $COLOR declarations are located:
Quote:$COLOR:0 adds constants for colors 0-15. The actual constant names can be found in the file source/utilities/color0.bi.
$COLOR:32 adds constants for 32-bit colors, similar to HTML color names. The actual constant names can be found in the file source/utilities/color32.bi.
At this moment:
Code: (Select All)
(qb64pepath)/source
only has BAS files and a couple of folders. There is no "utilities" folder.
The correct path is:
Code: (Select All)
(qb64pepath)/internal/support/color
where "qb64pepath" is the directory were QB64PE was installed.
This is in case somebody is interested in knowing what the color constants are.
Has anyone else noticed this using FireFox or even another browser:
Often times I'll leave Firefox run for weeks at a time. Every now and then I'll get up in the morning to notice Task Manager showing FireFox using over 4GB of RAM and climbing.
I've narrowed this down to this site. To verify this I let FireFox run with this site as its only tab (I used another browser to do other things, yuck). For the past few months I have been tracking the issue using this method. With only this site loaded I'll get a run away memory issue in FireFox within a few days. I can let FireFox run for weeks with many tabs open and no memory issue. As soon as I open this site I'm guaranteed to have a run away memory issue within a day or two.
I came up with something rather silly and visual to enjoy. I used pretty much these computations to come up with the "jaggies personalities" earlier. Press the arrow keys to pan around in the view. Press escape to quit this program.
Originally this program was in SCREEN 0 but I desired higher resolution and 32-bit color.
Code: (Select All)
'by mnrvovrfc 15-May-2023
OPTION _EXPLICIT
TYPE being
AS SINGLE x, y, a1, c1, f1, s1, m1, n1, a2, c2, f2, s2, m2, n2, a3, c3, m3
AS INTEGER xn, yn
END TYPE
'a1 = angle (to convert to radians); c1 = coefficient; f1 = equation variety; s2 = added angle always sin
'm1 = increase a1; n1 = increase s1
'this is for first "wing" only, second "wing" doesn't have "f2"
'xn, yn = nudge; c = color; a3, m3 = outer "wing" angle
CONST NUMB = 100, VSLIM = 300
DIM SHARED vs(-VSLIM TO VSLIM, -VSLIM TO VSLIM)
DIM SHARED b(1 TO NUMB) AS being
DIM SHARED AS INTEGER xpan, ypan, rr, gg, bb
DIM AS INTEGER i, j
DIM upd AS _BYTE
DIM SHARED colr(1 TO NUMB) AS LONG
SCREEN _NEWIMAGE(960, 488, 32)
_DELAY 0.5
_TITLE "Press [ESC] to quit. Arrow keys to pan the view."
_FONT 8
xpan = 0
ypan = 0
RANDOMIZE TIMER
FOR i = 1 TO NUMB
rr = (Rand(48, 191) \ 8) * 8
gg = (Rand(80, 223) \ 8) * 8
bb = (Rand(112, 255) \ 8) * 8
IF Random1(2) = 1 THEN SWAP rr, gg
IF Random1(2) = 1 THEN SWAP bb, gg
IF Random1(2) = 1 THEN SWAP rr, bb
colr(i) = _RGB(rr, gg, bb)
NEXT
upd = 1
DO
_LIMIT 60
FOR i = 1 TO NUMB
changebeing i
NEXT
IF _KEYDOWN(18432) THEN
ypan = ypan + 1
upd = 1
ELSEIF _KEYDOWN(20480) THEN
ypan = ypan - 1
upd = 1
END IF
IF _KEYDOWN(19200) THEN
xpan = xpan + 1
upd = 1
ELSEIF _KEYDOWN(19712) THEN
xpan = xpan - 1
upd = 1
END IF
update upd
IF upd = 1 THEN upd = 0
LOOP UNTIL _KEYDOWN(27)
SYSTEM
SUB update (uf AS _BYTE)
STATIC AS INTEGER xrig, ybot, i, j, xx, yy
STATIC ufo AS _BYTE
ufo = 1
IF xpan < -VSLIM THEN xpan = -VSLIM: ufo = 0
xrig = xpan + 239
IF xrig > VSLIM THEN
xpan = xpan - 1
xrig = xpan + 239
ufo = 0
END IF
IF ypan < -VSLIM THEN ypan = -VSLIM: ufo = 0
ybot = ypan + 119
IF ybot > VSLIM THEN
ypan = ypan - 1
ybot = ypan + 119
ufo = 0
END IF
IF uf AND ufo THEN CLS
_PRINTSTRING (0, 480), "|" + STR$(xpan) + "|" + STR$(ypan)
yy = 0
FOR j = ypan TO ybot
xx = 0
FOR i = xpan TO xrig
IF vs(j, i) THEN
LINE (xx, yy)-STEP(3, 3), colr(vs(j, i)), BF
END IF
xx = xx + 4
NEXT
yy = yy + 4
NEXT
END SUB
SUB changebeing (w AS INTEGER)
STATIC AS LONG x, y
b(w).a1 = b(w).a1 + b(w).m1
b(w).s1 = b(w).s1 + b(w).n1
IF b(w).a1 > 360 THEN b(w).a1 = b(w).a1 - 360
IF b(w).s1 > 360 THEN b(w).s1 = b(w).s1 - 360
b(w).a2 = b(w).a2 + b(w).m2
b(w).s2 = b(w).s2 + b(w).n2
IF b(w).a2 > 360 THEN b(w).a2 = b(w).a2 - 360
IF b(w).s2 > 360 THEN b(w).s2 = b(w).s2 - 360
b(w).a3 = b(w).a3 + b(w).m3
IF b(w).a3 > 360 THEN b(w).a3 = b(w).a3 - 360
SELECT CASE b(w).f1
CASE 1
b(w).x = b(w).c1 * (SIN(_D2R(b(w).a1)) + SIN(_D2R(b(w).s1))) + b(w).c3 * SIN(_D2R(b(w).a3))
b(w).y = b(w).c2 * (SIN(_D2R(b(w).a2)) + SIN(_D2R(b(w).s2)))
CASE 2
b(w).x = b(w).c1 * (COS(_D2R(b(w).a1)) + SIN(_D2R(b(w).s1))) + b(w).c3 * SIN(_D2R(b(w).a3))
b(w).y = b(w).c2 * (SIN(_D2R(b(w).a2)) + SIN(_D2R(b(w).s2)))
CASE 3
b(w).x = b(w).c1 * (SIN(_D2R(b(w).a1)) + SIN(_D2R(b(w).s1))) * b(w).c3 * SIN(_D2R(b(w).a3))
b(w).y = b(w).c2 * (SIN(_D2R(b(w).a2)) + SIN(_D2R(b(w).s2)))
CASE 4
b(w).x = b(w).c1 * (COS(_D2R(b(w).a1)) + SIN(_D2R(b(w).s1))) * b(w).c3 * SIN(_D2R(b(w).a3))
b(w).y = b(w).c2 * (SIN(_D2R(b(w).a2)) + SIN(_D2R(b(w).s2)))
CASE 5
b(w).x = b(w).c1 * (SIN(_D2R(b(w).a1)) + SIN(_D2R(b(w).s1))) + b(w).c3 * COS(_D2R(b(w).a3))
b(w).y = b(w).c2 * (SIN(_D2R(b(w).a2)) + SIN(_D2R(b(w).s2)))
CASE 6
b(w).x = b(w).c1 * (COS(_D2R(b(w).a1)) + SIN(_D2R(b(w).s1))) + b(w).c3 * COS(_D2R(b(w).a3))
b(w).y = b(w).c2 * (SIN(_D2R(b(w).a2)) + SIN(_D2R(b(w).s2)))
CASE 7
b(w).x = b(w).c1 * (SIN(_D2R(b(w).a1)) + SIN(_D2R(b(w).s1))) * b(w).c3 * COS(_D2R(b(w).a3))
b(w).y = b(w).c2 * (SIN(_D2R(b(w).a2)) + SIN(_D2R(b(w).s2)))
CASE 8
b(w).x = b(w).c1 * (COS(_D2R(b(w).a1)) + SIN(_D2R(b(w).s1))) * b(w).c3 * COS(_D2R(b(w).a3))
b(w).y = b(w).c2 * (SIN(_D2R(b(w).a2)) + SIN(_D2R(b(w).s2)))
END SELECT
x = INT(b(w).x + b(w).xn)
y = INT(b(w).y + b(w).yn)
IF x >= -VSLIM AND y >= -VSLIM AND x <= VSLIM AND y <= VSLIM THEN
IF vs(y, x) = 0 THEN vs(y, x) = w
END IF
END SUB
FUNCTION Rand& (fromval&, toval&)
DIM sg%, f&, t&
IF fromval& = toval& THEN
Rand& = fromval&
EXIT FUNCTION
END IF
f& = fromval&
t& = toval&
IF (f& < 0) AND (t& < 0) THEN
sg% = -1
f& = f& * -1
t& = t& * -1
ELSE
sg% = 1
END IF
IF f& > t& THEN SWAP f&, t&
Rand& = INT(RND * (t& - f& + 1) + f&) * sg%
END FUNCTION
FUNCTION Random1& (maxvaluu&)
DIM sg%
sg% = SGN(maxvaluu&)
IF sg% = 0 THEN
Random1& = 0
ELSE
IF sg% = -1 THEN maxvaluu& = maxvaluu& * -1
Random1& = INT(RND * maxvaluu& + 1) * sg%
END IF
END FUNCTION
How to attach data (sound, image, etc.) to EXE files has been shown here several times.
My only question is, can the actual program also write itself, or is that only possible with a separate program?
If a program is running, you can still open it for reading, but writing is denied.
So the system, with me Windows denied the write access when a program is running.
Here's the question, is there a way to bypass the system lock?
Example program, even started as an administrator does not work. ( Regtest.bas )
Code: (Select All)
'====================Declarirung fr die Registrirung==========================================================================================
Declare Dynamic Library "kernel32"
FUNCTION GetVolumeInformationA& (lpRootPathName$, lpVolumeNameBuffer$, BYVAL nVolumeNameSize~&, _
lpVolumeSerialNumber~&, lpMaximumComponentLength~&, lpFileSystemFlags~&, lpFileSystemNameBuffer$, BYVAL nFileSystemNameSize&)
End Declare
Declare Library: Function GetDriveType& (d$): End Declare
Dim Shared DriveType As String, SERIALFOUND As String
Dim As _Float Regist
Dim As _Float FileSize
'========================Ende der Registrirung=================================================================================================
MyAppName$ = Mid$(Command$(0), _InStrRev(Command$(0), "\") + 1)
'If MyAppName$ <> "Register-3.exe" Then System
'Open ".\Register-3.exe" For Input As #1
'FileSize = LOF(1)
'Close #1
'If FileSize = 592187 Then Else System
'===========================Code fr die Registrirung==========================================================================================
Test% = 0
SERIALSSHOW:
For q = 1 To 26: X = GetFileInfo(q): 'If SERIALFOUND <> "!!!-!!!" Then Print " "; Chr$(64 + q) + ": "; SERIALFOUND
If SERIALFOUND <> "!!!-!!!" And Test% = 0 Then
Temp$ = SERIALFOUND
Test% = 1
End If
Next q
'Print Temp$
'file$ = _OpenFileDialog$("Datei Öffnen", "", "*.EXE", "Programdatei", 0)
file$ = ".\Regtest.exe"
Open file$ For Binary As #1
FileSize = LOF(1)
t$ = "NR"
check$ = " "
Color 3, 5
'Print FileSize
Select Case UCase$(check$)
Case "VC" 'verified copy. All is good
Get #1, FileSize - 10, Regist
String1$ = _MK$(_Float, Regist)
String1$ = Left$(String1$, 9)
'Print String1$
'Print Temp$
If UCase$(String1$) = UCase$(Temp$) Then
Print "You have a paid copy of this software. All is good."
Else
Print " Illegaler Programm Aufruf !!!!!!!"
_Delay 5
Close #1
System
End If
Case "NR" 'already has a timestamp, is a limited time test version. Toss NAG Screen.
Print "This is a trial version of the program."
Registrierung$ = _InputBox$("Regtest Registrierung", "Geben sie bitte den Registrierungs Code ein:", "Demo")
If Registrierung$ = Chr$(36) + Chr$(82) + Chr$(101) + Chr$(103) + Chr$(105) + Chr$(115) + Chr$(116) + Chr$(101) + Chr$(114) + Chr$(64) Then '$Register@
Get #1, FileSize - 10, Regist
String1$ = _MK$(_Float, Regist)
Color 3, 6
String1$ = Left$(String1$, 9)
If UCase$(String1$) = UCase$(Temp$) Then
Print "Programm wurde manipuliert"
Else
Print "Schreibe VC in Datei"
Sleep 5
Temp$ = Temp$ + "VC"
Put #1, FileSize - 1, Temp$
Print "Programm wurde Registriert "
_NotifyPopup "Regtest", "Ihre Registrierung war Erfolgreich", "info" ' "info" , "warning" oder "error"
Close #1
_Delay .5
'Open file$ For Binary As #1
'FileSize = LOF(1)
'Get #1, FileSize - 10, Regist
'String1$ = _MK$(_Float, Regist)
'Color 3, 6
'String1$ = Left$(String1$, 9)
'Print "RegTest " + String1$
Sleep
Close #1
End If
Else
Print " Ihr Code ist Falsch "
_NotifyPopup "Regtest", "Ihre Registrierung ist Fehlgeschlagen", "warning"
End If
Case Else 'first run.
Print "Illegal copy of software! Terminating Now!"
Print " Schreibe NR in Datei"
Sleep 5
'Print check$
Put #1, FileSize + 1, t$
'Print t$
Sleep
Close #1
End
End Select
Close #1
'=======================================Code ende Registrirung ====================================================================
'==================================Funtionen fr die Registrirung =================================================
Function GetFileInfo (D)
SERIALFOUND = "!!!-!!!":
If DRIVEEXISTS(D) <> 1 Then GetFileInfo = 0: Exit Function
Dname$ = Chr$(D + 64) + ":\": Sname$ = Space$(260)
R = GetVolumeInformationA(Dname$ + Chr$(0), Vname$, 260, serial~&, empty1~&, empty2~&, Sname$, 260)
If R = 0 Then Exit Function
Sname$ = Left$(Hex$(serial~&), 4) + "-" + Right$(Hex$(serial~&), 4)
SERIALFOUND = "" + Sname$ + ""
GetFileInfo = -1
End Function
'---
Function DRIVEEXISTS (V)
DRIVEEXISTS = 0: varX$ = Chr$(V + 64) + ":\" + Chr$(0): VarX = GetDriveType(varX$): If VarX > 1 Then DRIVEEXISTS = 1
End Function
'===========================================Ende der Registrirung==========================
Would be helpful and not too onerous to have NEXT include the control variable to which it is attached? For example
For x = 1 to 50
For y = 2 to 75
.... code here..
NEXT y
NEXT x
Sometimes the control variable provides important info on data being manipulated in the loop and the manipulation can be complex and nested deeply so that the NEXT statements come on multiple pages of code.
For Temperature = 90 to 190
... code here...
For Windspeed = 20 to 150
>>> code here <<<
Next Windspeed
.... more code
Next Temperature
Also, I'm not sure if the Error Warning which for me pops up a lot, and invariably is telling me the Subscript on Line 10250 is out of range. Would it be possible to have a feature where pushing enter or some such key will take me directly to the offending line?
Is there a way to force controller _DEVICES to be cleared and re-detected?
For instance, when _DEVICES is first used in a running program the detected number of controllers will be returned. If one or more of the detected controllers is then disconnected the _DEVICE$ for the disconnected controllers will add "[DISCONNECTED]" to the string returned but still occupy a place in _DEVICES. If a user were to start plugging in random controllers after program startup the _DEVICES value will just keep growing with each new unique controller connected. The program listed below will show this in action. I would like to clear the _DEVICES list when a controller is listed as "[DISCONNECTED]" so _DEVICES can recount the actual number of controllers still plugged in if this is possible while a program is running. Any thoughts?
Code: (Select All)
DIM Devices AS INTEGER
DIM Fcount AS INTEGER
DIM d AS INTEGER
DIM DeviceName AS STRING
Devices = _DEVICES
Fcount = 0
DO
CLS
_LIMIT 30
Fcount = Fcount + 1
IF Fcount = 30 THEN ' check for new devices once per second
Fcount = 1
IF _DEVICES <> Devices THEN Devices = _DEVICES ' if number of devices changes get new count
END IF
PRINT
FOR d = 1 TO Devices ' print found devices
COLOR 14, 1
DeviceName = _DEVICE$(d)
IF INSTR(DeviceName, "[DISCONNECTED]") THEN COLOR 7, 0 ' change color if disconnected
PRINT " Found: "; _DEVICE$(d)
COLOR 7, 0
NEXT d
_DISPLAY
LOOP UNTIL _KEYDOWN(27) ' press ESC to exit
![[Image: image.png]](https://i.ibb.co/d6BS0hb/image.png)
![[Image: image.png]](https://i.ibb.co/T1KzP7V/image.png)
![[Image: image.png]](https://i.ibb.co/kJG4msB/image.png)
