Welcome, Guest |
You have to register before you can post on our site.
|
|
|
Limited Time Programs |
Posted by: SMcNeill - 02-05-2023, 09:44 PM - Forum: Utilities
- Replies (10)
|
|
Ever wanted to give someone a timed trial of your program? Let them download it, play around for a few days, and then pop up a nag screen telling them to buy your junk? Well, now you can!!
First the timestamper!
Code: (Select All) INPUT "File to stamp TimeStamp to =>"; file$
OPEN file$ FOR BINARY AS #1
filesize = LOF(1)
DIM TS AS _FLOAT
TS = TimeStamp(DATE$, TIMER)
PUT #1, filesize + 1, TS
t$ = "TS"
PUT #1, , t$
CLOSE #1
PRINT "TimeStamp Added"
SLEEP
SYSTEM
FUNCTION TimeStamp## (d$, t##) 'date and timer
'Based on Unix Epoch time, which starts at year 1970.
DIM l AS _INTEGER64, l1 AS _INTEGER64, m AS _INTEGER64
DIM d AS _INTEGER64, y AS _INTEGER64, i AS _INTEGER64
DIM s AS _FLOAT
l = INSTR(d$, "-")
l1 = INSTR(l + 1, d$, "-")
m = VAL(LEFT$(d$, l))
d = VAL(MID$(d$, l + 1))
y = VAL(MID$(d$, l1 + 1))
IF y < 1970 THEN 'calculate shit backwards
SELECT CASE m 'turn the day backwards for the month
CASE 1, 3, 5, 7, 8, 10, 12: d = 31 - d '31 days
CASE 2: d = 28 - d 'special 28 or 29.
CASE 4, 6, 9, 11: d = 30 - d '30 days
END SELECT
IF y MOD 4 = 0 AND m < 3 THEN 'check for normal leap year, and we're before it...
d = d + 1 'assume we had a leap year, subtract another day
IF y MOD 100 = 0 AND y MOD 400 <> 0 THEN d = d - 1 'not a leap year if year is divisible by 100 and not 400
END IF
'then count the months that passed after the current month
FOR i = m + 1 TO 12
SELECT CASE i
CASE 2: d = d + 28
CASE 3, 5, 7, 8, 10, 12: d = d + 31
CASE 4, 6, 9, 11: d = d + 30
END SELECT
NEXT
'we should now have the entered year calculated. Now lets add in for each year from this point to 1970
d = d + 365 * (1969 - y) '365 days per each standard year
FOR i = 1968 TO y + 1 STEP -4 'from 1968 onwards,backwards, skipping the current year (which we handled previously in the FOR loop)
d = d + 1 'subtract an extra day every leap year
IF (i MOD 100) = 0 AND (i MOD 400) <> 0 THEN d = d - 1 'but skipping every year divisible by 100, but not 400
NEXT
s## = d * 24 * 60 * 60 'Seconds are days * 24 hours * 60 minutes * 60 seconds
TimeStamp## = -(s## + 24 * 60 * 60 - t##)
EXIT FUNCTION
ELSE
y = y - 1970
END IF
FOR i = 1 TO m 'for this year,
SELECT CASE i 'Add the number of days for each previous month passed
CASE 1: d = d 'January doestn't have any carry over days.
CASE 2, 4, 6, 8, 9, 11: d = d + 31
CASE 3 'Feb might be a leap year
IF (y MOD 4) = 2 THEN 'if this year is divisible by 4 (starting in 1972)
d = d + 29 'its a leap year
IF (y MOD 100) = 30 AND (y MOD 400) <> 30 THEN 'unless..
d = d - 1 'the year is divisible by 100, and not divisible by 400
END IF
ELSE 'year not divisible by 4, no worries
d = d + 28
END IF
CASE 5, 7, 10, 12: d = d + 30
END SELECT
NEXT
d = (d - 1) + 365 * y 'current month days passed + 365 days per each standard year
FOR i = 2 TO y - 1 STEP 4 'from 1972 onwards, skipping the current year (which we handled previously in the FOR loopp)
d = d + 1 'add an extra day every leap year
IF (i MOD 100) = 30 AND (i MOD 400) <> 30 THEN d = d - 1 'but skiping every year divisible by 100, but not 400
NEXT
s## = d * 24 * 60 * 60 'Seconds are days * 24 hours * 60 minutes * 60 seconds
TimeStamp## = (s## + t##)
END FUNCTION
And, a program set up to showcase the basic workings of it:
Code: (Select All) TYPE SYSTIME
year AS INTEGER
month AS INTEGER
weekday AS INTEGER
day AS INTEGER
hour AS INTEGER
minute AS INTEGER
second AS INTEGER
millis AS INTEGER
END TYPE
DECLARE DYNAMIC LIBRARY "Kernel32"
SUB GetSystemTime (lpSystemTime AS SYSTIME)
SUB GetLocalTime (lpSystemTime AS SYSTIME)
END DECLARE
AppendTimeStamp
SUB AppendTimeStamp
DIM AS _FLOAT TS
f = FREEFILE
OPEN COMMAND$(0) FOR BINARY AS #f
FileSize = LOF(f)
check$ = " "
GET #f, FileSize - 1, check$
SELECT CASE UCASE$(check$)
CASE "VC" 'verified copy. All is good
PRINT "You have a paid copy of this software. All is good, kindly feel free to carry on with your existence, puny human."
CASE "TS" 'already has a timestamp, is a limited time test version. Toss NAG Screen.
GET #1, FileSize - 33, TS
PRINT "Original TimeStamp:"; TS
PRINT "Current TimeStamp: "; TimeStamp(DATE$, TIMER)
PRINT USING "This is a trial version of the program. You have been testing it for ###,####.#### seconds"; TimeStamp(DATE$, TIMER) - TS
CASE ELSE 'first run.
PRINT "Illegal copy of software! Terminating Now!"
SLEEP
SYSTEM
END SELECT
CLOSE #f
END SUB
FUNCTION TimeStamp## (d$, t##) 'date and timer
'Based on Unix Epoch time, which starts at year 1970.
DIM l AS _INTEGER64, l1 AS _INTEGER64, m AS _INTEGER64
DIM d AS _INTEGER64, y AS _INTEGER64, i AS _INTEGER64
DIM s AS _FLOAT
l = INSTR(d$, "-")
l1 = INSTR(l + 1, d$, "-")
m = VAL(LEFT$(d$, l))
d = VAL(MID$(d$, l + 1))
y = VAL(MID$(d$, l1 + 1))
IF y < 1970 THEN 'calculate shit backwards
SELECT CASE m 'turn the day backwards for the month
CASE 1, 3, 5, 7, 8, 10, 12: d = 31 - d '31 days
CASE 2: d = 28 - d 'special 28 or 29.
CASE 4, 6, 9, 11: d = 30 - d '30 days
END SELECT
IF y MOD 4 = 0 AND m < 3 THEN 'check for normal leap year, and we're before it...
d = d + 1 'assume we had a leap year, subtract another day
IF y MOD 100 = 0 AND y MOD 400 <> 0 THEN d = d - 1 'not a leap year if year is divisible by 100 and not 400
END IF
'then count the months that passed after the current month
FOR i = m + 1 TO 12
SELECT CASE i
CASE 2: d = d + 28
CASE 3, 5, 7, 8, 10, 12: d = d + 31
CASE 4, 6, 9, 11: d = d + 30
END SELECT
NEXT
'we should now have the entered year calculated. Now lets add in for each year from this point to 1970
d = d + 365 * (1969 - y) '365 days per each standard year
FOR i = 1968 TO y + 1 STEP -4 'from 1968 onwards,backwards, skipping the current year (which we handled previously in the FOR loop)
d = d + 1 'subtract an extra day every leap year
IF (i MOD 100) = 0 AND (i MOD 400) <> 0 THEN d = d - 1 'but skipping every year divisible by 100, but not 400
NEXT
s## = d * 24 * 60 * 60 'Seconds are days * 24 hours * 60 minutes * 60 seconds
TimeStamp## = -(s## + 24 * 60 * 60 - t##)
EXIT FUNCTION
ELSE
y = y - 1970
END IF
FOR i = 1 TO m 'for this year,
SELECT CASE i 'Add the number of days for each previous month passed
CASE 1: d = d 'January doestn't have any carry over days.
CASE 2, 4, 6, 8, 9, 11: d = d + 31
CASE 3 'Feb might be a leap year
IF (y MOD 4) = 2 THEN 'if this year is divisible by 4 (starting in 1972)
d = d + 29 'its a leap year
IF (y MOD 100) = 30 AND (y MOD 400) <> 30 THEN 'unless..
d = d - 1 'the year is divisible by 100, and not divisible by 400
END IF
ELSE 'year not divisible by 4, no worries
d = d + 28
END IF
CASE 5, 7, 10, 12: d = d + 30
END SELECT
NEXT
d = (d - 1) + 365 * y 'current month days passed + 365 days per each standard year
FOR i = 2 TO y - 1 STEP 4 'from 1972 onwards, skipping the current year (which we handled previously in the FOR loopp)
d = d + 1 'add an extra day every leap year
IF (i MOD 100) = 30 AND (i MOD 400) <> 30 THEN d = d - 1 'but skiping every year divisible by 100, but not 400
NEXT
s## = d * 24 * 60 * 60 'Seconds are days * 24 hours * 60 minutes * 60 seconds
TimeStamp## = (s## + t##)
END FUNCTION
So, to start with, run the second file first. It'll make an EXE for you and tell you that it's illegal! You're not allowed to use it. This is all someone that grabs your program out of the blue will see.
Now, if you want to send someone a timestamped trial version, run the first program and point it to your other program's compiled EXE. It'll stick a timestamp to the end of it for you, and now you can now run that EXE and have it make use of that timestamp however you want.
If they buy your junk, send (or change) the last 2 bytes of the EXE to "VC" for "Verified Copy", and they're good to go without any message for illegal downloading or nag screen to buy your stuff.
Screenshots follow:
|
|
|
Blank Line Remover |
Posted by: bplus - 02-04-2023, 10:00 PM - Forum: Utilities
- No Replies
|
|
Quick little code for Windows .bas code that got double spaced at a forum:
Code: (Select All) _Title "Blank Line Remover" ' b+ 2023-02-04
FixMe$ = _OpenFileDialog$("Select .bas file to remove blank lines from", _CWD$, "*.bas", "Basic files")
t$ = Mid$(FixMe$, 1, _InStrRev(FixMe$, "\")) + "temp.bas"
cancel& = _MessageBox("Check Names", "Fix file: " + FixMe$ + Chr$(10) + "Temp: " + t$, "okcancel", "question")
If cancel& = 1 Then
Open FixMe$ For Input As #1
Open t$ For Output As #2
While EOF(1) = 0
Line Input #1, fline$
If _Trim$(fline$) <> "" Then Print #2, fline$
Wend
Close
Kill FixMe$
Name t$ As FixMe$
Print "File converted."
End If
|
|
|
Profile Pong Game Development |
Posted by: bplus - 02-04-2023, 08:30 PM - Forum: bplus
- Replies (29)
|
|
Ever since I saw Rosy's video at RCBasic (where I lurk) I have been meaning to do a version in QB64.
We all know the Classic Pong and this Perspective is very amusing, to me any way!
Rosy's video, just click into it about halfway through and watch until you get an idea how it should go...
https://www.youtube.com/watch?v=jfod2O5Oq7s
I thought I'd show the evolution of my version of development over last couple of days.
So here, my starter I just get started on images and some basic ball handling:
Code: (Select All) Option _Explicit
_Title "Profile Pong 0-1" ' b+ 2023-02-01 started inspired by Rosy game at RCBasic
Const Xmax = 1200, Ymax = 700, PaddleR = 30, BallR = 5, TableL = 100, TableR = 1100
Const TableY = Ymax - 80
Const NetY = TableY - 40
Const NetL = 598
Const NetR = 602
Const Gravity = .1
Const BallSpeed = 8
Dim Shared As Long Table, LPaddle, RPaddle ' images
Screen _NewImage(Xmax, Ymax, 32)
_ScreenMove 0, 0 ' <<<<<<< you may want different
Dim As Long mx, my, playerX, playerY, ballX, ballY, computerX, computerY, playerPt, computerPt, flagPt
Dim As Double ballDX, ballDY, a
makeTableImg
makeLeftPaddle
makeRightpaddle
computerX = 50
Do
flagPt = 0
ballY = 300: ballX = TableR - BallR: ballDX = .01
Do
_PutImage , Table, 0
_PrintString (100, 100), "Computer:" + Str$(computerPt)
_PrintString (1100 - _PrintWidth("Player:" + Str$(playerPt)), 100), "Player:" + Str$(playerPt)
' player is RPaddle
10 If _MouseInput Then GoTo 10
mx = _MouseX: my = _MouseY
If mx > NetR + PaddleR Then
If mx > 1100 + PaddleR Then
playerX = mx: playerY = my
Else
If my + PaddleR < TableY Then playerX = mx: playerY = my
End If
End If
_PutImage (playerX - PaddleR, playerY - PaddleR)-Step(PaddleR, 2 * PaddleR), RPaddle, 0
' computer opponent
computerY = ballY + 5
_PutImage (computerX, computerY - PaddleR)-Step(PaddleR, 2 * PaddleR), LPaddle, 0
' ball handling
ballDY = ballDY + Gravity
ballX = ballX + ballDX: ballY = ballY + ballDY
' collide player
If Sqr((ballX - playerX) ^ 2 + (ballY - playerY) ^ 2) < (BallR + PaddleR) And ballDX > 0 Then
a = _Atan2(ballY - playerY, ballX - playerX)
ballDX = BallSpeed * Cos(a)
ballDY = BallSpeed * Sin(a)
ballX = ballX + 2 * ballDX ' boost
ballY = ballY + 2 * ballDY
End If
' collide computer
If Sqr((ballX - computerX) ^ 2 + (ballY - computerY) ^ 2) < (BallR + PaddleR) And ballDX < 0 Then
a = _Atan2(ballY - computerY, ballX - computerX)
ballDX = BallSpeed * Cos(a)
ballDY = BallSpeed * Sin(a)
ballX = ballX + 2 * ballDX ' boost
ballY = ballY + 2 * ballDY
End If
' collide net
If ballY + BallR > NetY Then
If ballDX > 0 Then ' going towards player
If ballX > NetL - BallR And ballX < NetR + BallR Then ' collide
playerPt = playerPt + 1
flagPt = 1
fcirc ballX, ballY, BallR, &HFFFFFFFF
_Display
_Delay 1
End If
Else ' going towards computer
If ballX > NetL - BallR And ballX < NetR + BallR Then ' collide
computerPt = computerPt + 1
flagPt = 1
fcirc ballX, ballY, BallR, &HFFFFFFFF
_Display
_Delay 1
End If
End If
End If
' collide table
If ballY + BallR > TableY And ((ballX > TableL) Or (ballX < TableR)) Then
ballY = TableY - BallR
ballDY = -ballDY
End If
' collide floor
If ballY + BallR > Ymax Then
If ballX + BallR < TableL Then
playerPt = playerPt + 1
flagPt = 1
ElseIf ballX - BallR > TableR Then
computerPt = computerPt + 1
flagPt = 1
End If
End If
' collide left
If ballX - BallR < 0 Then
playerPt = playerPt + 1
flagPt = 1
ElseIf ballX + BallR > Xmax Then 'collide right
computerPt = computerPt + 1
flagPt = 1
End If
fcirc ballX, ballY, BallR, &HFFFFFFFF
_Display
_Limit 60
Loop Until flagPt
_Delay 1
If computerPt >= 21 Then
_MessageBox "Sorry,", "The Computer out did you this game."
computerPt = 0: playerPt = 0
ElseIf playerPt >= 21 Then
_MessageBox "Congrats!", "You beat the Computer."
computerPt = 0: playerPt = 0
End If
Loop
Sub makeLeftPaddle
LPaddle = _NewImage(PaddleR, 2 * PaddleR, 32)
_Dest LPaddle
fcirc -1, PaddleR, PaddleR, &HFFBB6600
_Dest 0
End Sub
Sub makeRightpaddle
RPaddle = _NewImage(PaddleR, 2 * PaddleR, 32)
_Dest RPaddle
fcirc PaddleR, PaddleR, PaddleR, &HFFFFAA00
_Dest 0
End Sub
Sub makeTableImg
Table = _NewImage(_Width, _Height, 32)
_Dest Table
Cls
Line (TableL, TableY)-(TableR, TableY + 20), &HFF008855, BF
Line (TableL + 40, TableY + 20)-(TableL + 50, _Height), &HFF444444, BF
Line (TableR - 50, TableY + 20)-(TableR - 40, _Height), &HFF444444, BF
Line (NetL, NetY)-(NetR, TableY), &HFF444444, BF
Line (NetL + 1, NetY)-(NetR - 1, NetY + 20), &HFFFFFFFF, BF
_Dest 0
End Sub
Sub fcirc (CX As Long, CY As Long, R As Long, C As _Unsigned Long)
Dim Radius As Long, RadiusError As Long
Dim X As Long, Y As Long
Radius = Abs(R): RadiusError = -Radius: X = Radius: Y = 0
If Radius = 0 Then PSet (CX, CY), C: Exit Sub
Line (CX - X, CY)-(CX + X, CY), C, BF
While X > Y
RadiusError = RadiusError + Y * 2 + 1
If RadiusError >= 0 Then
If X <> Y + 1 Then
Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
End If
X = X - 1
RadiusError = RadiusError - X * 2
End If
Y = Y + 1
Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
Wend
End Sub
|
|
|
Anyone know how frostbite thresholds are calculated? |
Posted by: SMcNeill - 02-04-2023, 08:46 AM - Forum: Help Me!
- Replies (13)
|
|
Something small I was working on to go with my home weather system:
Code: (Select All) SCREEN _NEWIMAGE(800, 600, 32)
$COLOR:32
PRINT " ";
count = 1
FOR temp = 40 TO -45 STEP -5
LOCATE , 4 * count
PRINT temp;
count = count + 1
NEXT
PRINT
FOR windspeed = 5 TO 60 STEP 5
COLOR White, Black
PRINT windspeed;
COLOR Black, SkyBlue
count = 1
FOR temp = 40 TO -45 STEP -5
wc& = WindChill(temp, windspeed)
LOCATE , 4 * count
count = count + 1
SELECT CASE wc&
CASE IS > -18: COLOR Black, LightBlue
CASE IS > -32: COLOR White, SkyBlue
CASE IS > -48: COLOR White, Blue
CASE ELSE: COLOR White, Purple
END SELECT
PRINT wc&; " ";
NEXT
PRINT
NEXT
COLOR White, Black
FUNCTION WindChill& (temp AS _FLOAT, windspeed AS _FLOAT)
WindChill = 35.74 + 0.6215 * temp - 35.75 * windspeed ^ 0.16 + 0.427 * temp * windspeed ^ 0.16
END FUNCTION
Now, as you can see, my chart matches the values from the chart here: WindChill (weather.gov)
Only issue is my color values don't match. Anyone know why -62 windchills are light blue at the top of the chart, but then are purple at the bottom? If the implied temperature is -52 in both cases, shouldn't frostbite occur at the same time? Isn't that basically what windchill is for -- to give an equal representation of what the temperature would feel like it the wind wasn't blowing?
How's that frostbite time calculated? Anyone have a clue, just so I can get my color scheme to match?
|
|
|
Where's Pete? |
Posted by: bplus - 02-03-2023, 12:28 AM - Forum: Programs
- Replies (3)
|
|
Code: (Select All) 'Option _Explicit
_Title "Signal" 'b+ 2023-01-23
Randomize Timer
Screen _NewImage(800, 600, 32)
Dim As Long d, spot, back, i, x, y, w, h, r, mx, my
Dim dx, dy
d = _LoadFont("ARIALBD.ttf", 64) ' <<<< easy for Windows probably no one else sorry
spot = _NewImage(200, 200, 32)
_Dest spot
_Font d
_PrintMode _KeepBackground
Color _RGB32(0, 0, 0, 60)
_PrintString ((200 - _PrintWidth("Pete")) / 2, (200 - _FontHeight(d)) / 2 + 10), "Pete"
_Dest 0
back = _NewImage(800, 600, 32)
_Dest back
For y = 0 To 600
Line (0, y)-(800, y), _RGB32(50, 0, y / 600 * 128)
Next
For i = 1 To 20
w = Rnd * 100 + 30: y = Rnd * 200 + 400: x = Rnd * (800 - w)
Line (x, y)-(x + w, 600), &HFF000000, BF
Next
Line (0, 550)-(800, 600), &HFF000000, BF
_Dest 0
r = 100
Do
_PutImage , back, 0
10 If _MouseInput Then GoTo 10
mx = _MouseX: my = _MouseY
For i = r To 0 Step -1
fcirc mx, my, i, _RGB32(255, 255, 255, 1)
Next
h = ((mx + 10) ^ 2 + (my - 550) ^ 2) ^ .5
dx = (mx + 10) / h: dy = (my - 550) / h
For i = 0 To h Step 2
fcirc -10 + i * dx, 550 + i * dy, i / h * 100, _RGB32(255, 255, 255, 1)
Next
_PutImage (mx - 100, my - 100), spot, 0
_Display
_Limit 30
Loop Until _KeyDown(27)
Sub fcirc (CX As Long, CY As Long, R As Long, C As _Unsigned Long)
Dim Radius As Long, RadiusError As Long
Dim X As Long, Y As Long
Radius = Abs(R): RadiusError = -Radius: X = Radius: Y = 0
If Radius = 0 Then PSet (CX, CY), C: Exit Sub
Line (CX - X, CY)-(CX + X, CY), C
While X > Y
RadiusError = RadiusError + Y * 2 + 1
If RadiusError >= 0 Then
If X <> Y + 1 Then
Line (CX - Y, CY - X)-(CX + Y, CY - X), C
Line (CX - Y, CY + X)-(CX + Y, CY + X), C
End If
X = X - 1
RadiusError = RadiusError - X * 2
End If
Y = Y + 1
Line (CX - X, CY - Y)-(CX + X, CY - Y), C
Line (CX - X, CY + Y)-(CX + X, CY + Y), C
Wend
End Sub
|
|
|
a simple Palette Builder |
Posted by: James D Jarvis - 02-01-2023, 04:42 PM - Forum: Programs
- Replies (7)
|
|
Needed a palette editor for another 256 color mode program screen so I wrote this program. This makes use of dialog commands, the mouse, and simple keyboard commands. Loads and save the palette files as a simple data file. Also saves out the palette as lines of basic code.
EDIT: added commands to copy and paste individual colors cells.
Code: (Select All) 'Palette_Builder
'by James D. Jarvis , Feb 2/1/2023
'
'a simple 256 color palette builder for QB64 PE
' saves and loads simple palette data files or basic source code to build a palette
Dim klr(0 To 255) As _Unsigned Long
Dim tklr As _Unsigned Long
Screen _NewImage(1100, 400, 256)
_Title "Palette_Builder"
Dim Shared showpalnos
showpalnos = 0
klr(0) = _RGB32(0, 0, 0)
klr(1) = _RGB32(0, 0, 255)
klr(2) = _RGB32(0, 128, 0)
klr(3) = _RGB32(0, 217, 217)
klr(4) = _RGB32(255, 0, 0)
klr(5) = _RGB32(193, 0, 193)
klr(6) = _RGB32(149, 5, 5)
klr(7) = _RGB32(192, 192, 192)
klr(8) = _RGB32(100, 100, 100)
klr(9) = _RGB32(0, 128, 255)
klr(10) = _RGB32(128, 255, 128)
klr(11) = _RGB32(128, 255, 255)
klr(12) = _RGB32(255, 128, 0)
klr(13) = _RGB32(255, 128, 255)
klr(14) = _RGB32(255, 255, 128)
klr(15) = _RGB32(250, 250, 250)
klr(255) = _RGB32(250, 250, 250)
For k = 16 To 254
klr(k) = _RGB32(k, Int(k * .8), Int(k * .4))
Next k
klr(101) = _RGB32(100, 100, 100)
For k = 16 To 255
_PaletteColor k, klr(k)
Next k
Color 255, 0
drawgrid
Do
_Limit 500
kk$ = InKey$
Mouser mx, my, mb
If mb = -1 And lb = 0 Then 'open color dialog on left button mouse click over grid position for color
If mx > -1 And mx < 1024 And my > -1 And my < 256 Then
px = mx \ 32
py = my \ 32
pk = py * 32 + px
Line (10, 310)-(800, 340), klr(0), BF
pm$ = "Color #: " + Str$(pk) + " R,G,B: " + Str$(_Red32(klr(pk))) + "," + Str$(_Green32(klr(pk))) + "," + Str$(_Blue32(klr(pk)))
_PrintString (10, 312), pm$
End If
End If
If mb = 0 And lb = -2 Then 'open color dialog on right button mouse release over grid position for color
If mx > -1 And mx < 1024 And my > -1 And my < 256 Then
px = mx \ 32
py = my \ 32
pk = py * 32 + px
If pk > -1 And pk < 256 Then
klr(pk) = _ColorChooserDialog("Choose Color", _RGB32(_Red32(klr(pk)), _Green32(klr(pk)), _Blue32(klr(pk))))
_PaletteColor pk, klr(pk)
End If
End If
End If
lb = mb 'record mouse button just clicked as last button clicked
Select Case kk$
Case "s", "S" 'save palette
savefile$ = _SaveFileDialog$("Save File", "", "*.*", "")
If savefile$ <> "" Then
_MessageBox "Information", "File will be saved to " + savefile$
Open savefile$ For Output As #1
For k = 0 To 255
Print #1, klr(k)
Next k
Close #1
End If
Case "l", "L" 'load palette
loadfile$ = _OpenFileDialog$("Open File", "", "*.*", "*.*", -1)
If loadfile$ <> "" Then
_MessageBox "Information", "You selected " + loadfile$
k = 0
Open loadfile$ For Input As #1
Do Until EOF(1)
Input #1, klr(k)
_PaletteColor k, klr(k)
k = k + 1
Loop
Close #1
drawgrid
End If
Case "b", "B" 'save basic code for palette to a file
savefile$ = _SaveFileDialog$("Save Basic Code to File", "", "*.*", "")
If savefile$ <> "" Then
_MessageBox "Information", "File will be saved to " + savefile$
Open savefile$ For Output As #1
Print #1, "'256 color palette uncomment lines as needed for use"
Print #1, "'Screen _NewImage(600, 400,256) "
Print #1, "'dim shared klr(0 to 255) as _unsigned long"
For k = 0 To 255
bc$ = ""
bc$ = "klr(" + _Trim$(Str$(k)) + ") = _rgb32(" + _Trim$(Str$(_Red32(klr(k)))) + "," + _Trim$(Str$(_Green32(klr(k)))) + "," + _Trim$(Str$(_Blue32(klr(k)))) + ")"
Print #1, bc$
Next k
Print #1, "'For k = 0 To 255 "
Print #1, "' _PaletteColor k, klr(k) "
Print #1, "' Next k"
Close #1
End If
Case "n", "N" 'toggle display of color numbers on palette grid
If showpalnos = 0 Then showpalnos = 1 Else showpalnos = 0
drawgrid
Case "c", "C"
Mouser mx, my, mb
If mx > -1 And mx < 1024 And my > -1 And my < 256 Then
px = mx \ 32
py = my \ 32
pk = py * 32 + px
Line (10, 310)-(800, 340), klr(0), BF
pm$ = "Color #: " + Str$(pk) + " R,G,B: " + Str$(_Red32(klr(pk))) + "," + Str$(_Green32(klr(pk))) + "," + Str$(_Blue32(klr(pk)))
_PrintString (10, 312), pm$
If pk > 0 And pk < 256 Then tklr = klr(pk)
End If
Case "p", "P"
Mouser mx, my, mb
If mx > -1 And mx < 1024 And my > -1 And my < 256 Then
px = mx \ 32
py = my \ 32
pk = py * 32 + px
If pk > 0 And pk < 256 Then klr(pk) = tklr
_PaletteColor pk, klr(pk)
End If
End Select
Loop Until kk$ = Chr$(27)
System
'draw the palette grid
Sub drawgrid
_PrintMode _KeepBackground
For y = 0 To 7
For x = 0 To 31
yy = y * 32
xx = x * 16
dk = yy + x
xx = xx * 2
Line (xx, yy)-(xx + 30, yy + 30), dk, BF
If showpalnos = 1 Then
_PrintString (xx + 2, yy + 6), _Trim$(Str$(dk))
End If
Next x, y
_PrintString (10, 257), "S - Save File L - Load File B - Save Basic Code N - show color #'s <ESC> -QUIT "
_PrintString (10, 275), "Left Click - show RGB values Right Click - change RGB values "
_PrintString (10, 293), "C - Copy color P - Paste color"
End Sub
'mouse sub from wiki with added check for mouse(2)
Sub Mouser (x, y, b)
mi = _MouseInput
b = _MouseButton(1)
If _MouseButton(2) = -1 Then b = -2
x = _MouseX
y = _MouseY
End Sub
|
|
|
|