| Welcome, Guest |
You have to register before you can post on our site.
|
| Latest Threads |
The QB64 IDE shell
Forum: Utilities
Last Post: JasonPag
09-16-2024, 05:37 PM
» Replies: 9
» Views: 764
|
Importance regarding Ches...
Forum: Utilities
Last Post: JasonPag
09-01-2024, 06:34 PM
» Replies: 0
» Views: 31
|
Chess and Analysis and En...
Forum: Utilities
Last Post: JasonPag
08-28-2024, 02:37 PM
» Replies: 0
» Views: 32
|
DAY 009:_PutImage
Forum: Keyword of the Day!
Last Post: grymmjack
09-02-2023, 02:57 PM
» Replies: 54
» Views: 2,034
|
Fall Banner Contest?
Forum: Site Suggestions
Last Post: grymmjack
08-31-2023, 11:50 PM
» Replies: 36
» Views: 1,261
|
ColorPicker - Function th...
Forum: Dav
Last Post: Dav
08-31-2023, 11:04 PM
» Replies: 3
» Views: 315
|
Goals(1) = New Tile()
Forum: Works in Progress
Last Post: RhoSigma
08-31-2023, 09:45 PM
» Replies: 3
» Views: 127
|
micro(A)v11
Forum: QBJS, BAM, and Other BASICs
Last Post: bplus
08-31-2023, 09:14 PM
» Replies: 90
» Views: 3,589
|
Updating The Single Most ...
Forum: QBJS, BAM, and Other BASICs
Last Post: bplus
08-31-2023, 09:13 PM
» Replies: 7
» Views: 254
|
QBJS Image Question
Forum: QBJS, BAM, and Other BASICs
Last Post: bplus
08-31-2023, 05:49 PM
» Replies: 5
» Views: 155
|
|
|
| Guess My Number |
|
Posted by: SierraKen - 09-18-2022, 11:04 PM - Forum: Programs
- Replies (18)
|
 |
This is probably the oldest BASIC game I've ever made back in High School in the 80's. I was bored today so I threw it together again with QB64.
Guess the computer's number from 1 to 100. It adds up how many tries you take.
Code: (Select All) start:
Randomize Timer
number = Int(Rnd * 100) + 1
tries = 0
Cls
Do
Print: Print
tries = tries + 1
Print tries; ". ";
Input "Guess My Number (1-100): ", g
If g = number Then
Print: Print "Correct!"
Print: Print "It took you "; tries; " tries."
Print: Input "Again (Y/N)?", ag$
If Left$(ag$, 1) = "y" Or Left$(ag$, 1) = "Y" Then GoTo start:
End
End If
If g > number Then Print: Print "Your number is too high."
If g < number Then Print: Print "Your number is too low."
Loop
|
|
|
| URL Downloader |
|
Posted by: SpriggsySpriggs - 09-17-2022, 09:48 PM - Forum: Spriggsy
- No Replies
|
 |
This code launches a console window, asks for a link and a name for the file. Then it downloads and shows the progress as it goes. Works with HTTP and HTTPS using Win32 API. Enjoy.
P.S. The console window is so you can easily paste the URL
Code: (Select All) Option _Explicit
Const INTERNET_OPEN_TYPE_DIRECT = 1
Const INTERNET_DEFAULT_HTTP_PORT = 80
Const INTERNET_DEFAULT_HTTPS_PORT = 443
Const INTERNET_SERVICE_HTTP = 3
'Flags
Const INTERNET_FLAG_SECURE = &H00800000
Const INTERNET_FLAG_RELOAD = &H80000000
Const HTTP_QUERY_CONTENT_LENGTH = 5
Const TRUE = 1
'CONST FALSE = 0
Const KILOBYTE = 1024
Const MEGABYTE = KILOBYTE ^ 2
Const GIGABYTE = KILOBYTE ^ 3
Const TERABYTE = KILOBYTE ^ 4
Declare Dynamic Library "Wininet"
Function InternetOpen%& Alias "InternetOpenA" (ByVal lpszAgent As _Offset, Byval dwAccessType As Long, Byval lpszProxy As _Offset, Byval lpszProxyBypass As _Offset, Byval dwFlags As Long)
Function InternetConnect%& Alias "InternetConnectA" (ByVal hInternet As _Offset, Byval lpszServerName As _Offset, Byval nServerPort As Integer, Byval lpszUserName As _Offset, Byval lpszPassword As _Offset, Byval dwService As Long, Byval dwFlags As Long, Byval dwContext As _Offset)
Function HTTPOpenRequest%& Alias "HttpOpenRequestA" (ByVal hConnect As _Offset, Byval lpszVerb As _Offset, Byval lpszObjectName As _Offset, Byval lpszVersion As _Offset, Byval lpszReferrer As _Offset, Byval lpszAcceptTypes As _Offset, Byval dwFlags As Long, Byval dwContext As _Offset)
Function HTTPSendRequest%% Alias "HttpSendRequestA" (ByVal hRequest As _Offset, Byval lpszHeaders As _Offset, Byval dwHeadersLength As Long, Byval lpOptional As _Offset, Byval dwOptionalLength As Long)
Sub InternetCloseHandle (ByVal hInternet As _Offset)
Function InternetReadFile%% (ByVal hFile As _Offset, Byval lpBuffer As _Offset, Byval dwNumberOfBytesToRead As Long, Byval lpdwNumberOfBytesRead As _Offset)
Function HTTPQueryInfo%% Alias "HttpQueryInfoA" (ByVal hRequest As _Offset, Byval dwInfoLevel As Long, Byval lpBuffer As _Offset, Byval lpdwBufferLength As _Offset, Byval lpdwIndex As _Offset)
End Declare
Declare Dynamic Library "Kernel32"
Function GetLastError& ()
Sub SetLastError (ByVal dwErrCode As Long)
Function FormatMessage& Alias "FormatMessageA" (ByVal dwFlags As Long, Byval lpSource As Long, Byval dwMessageId As Long, Byval dwLanguageId As Long, Byval lpBuffer As _Offset, Byval nSize As Long, Byval Arguments As _Offset)
End Declare
Declare Library
Function MAKELANGID& (ByVal p As Long, Byval s As Long)
End Declare
Screen _NewImage(480, 80, 32)
$ScreenHide
_ScreenHide
$Console
_Dest _Console
_Title "URL Downloader"
_ConsoleTitle "Enter Link"
Dim link As String
Dim filename As String
Do
Cls
Line Input "Link: ", link
Line Input "File Name : ", filename
Loop Until link <> "" And filename <> ""
_ScreenShow
_Title _Title$ + " - " + Mid$(filename, _InStrRev(filename, "\") + 1)
_Console Off
_Dest 0
DownloadLink link, filename
Sub DownloadLink (URL As String, File As String)
Dim As String URLFile
URLFile = URL
Dim As _Offset hsession
hsession = InternetOpen(0, INTERNET_OPEN_TYPE_DIRECT, 0, 0, 0)
If hsession = 0 Then
Cls
Print "Error : InternetOpen", ErrorMessage(GetLastError)
InternetCloseHandle hsession
Exit Sub
End If
Dim As _Offset httpsession
URL = Mid$(URL, InStr(URL, "/") + 2)
URL = Mid$(URL, 1, InStr(URL, "/") - 1)
Dim As String intURL: intURL = URL + Chr$(0)
httpsession = InternetConnect(hsession, _Offset(intURL), INTERNET_DEFAULT_HTTPS_PORT, 0, 0, INTERNET_SERVICE_HTTP, 0, 0)
If httpsession = 0 Then
Cls
Print "Error : Internet Connect", ErrorMessage(GetLastError)
InternetCloseHandle hsession
Exit Sub
End If
Dim As _Offset httpRequest
Dim As String sessiontype, location, accepttypes
sessiontype = "GET" + Chr$(0)
location = Mid$(URLFile, InStr(URLFile, URL) + Len(URL)) + Chr$(0)
accepttypes = "*/*" + Chr$(0)
httpRequest = HTTPOpenRequest(httpsession, _Offset(sessiontype), _Offset(location), 0, 0, _Offset(accepttypes), INTERNET_FLAG_RELOAD Or INTERNET_FLAG_SECURE, 0)
If httpRequest = 0 Then
Cls
Print "Error : HTTPOpenRequest", ErrorMessage(GetLastError)
InternetCloseHandle hsession
Exit Sub
End If
Dim As Long sendrequest
Dim As String headers
headers = ""
sendrequest = HTTPSendRequest(httpRequest, 0, 0, 0, 0)
If sendrequest <> TRUE Then
Cls
Print "Error : HTTPSendRequest", ErrorMessage(GetLastError)
InternetCloseHandle hsession
Exit Sub
End If
Dim As _Byte query
Dim As String queryinfo
queryinfo = Space$(1024)
Dim As Long querylen
querylen = Len(queryinfo) - 1
query = HTTPQueryInfo(httpRequest, HTTP_QUERY_CONTENT_LENGTH, _Offset(queryinfo), _Offset(querylen), 0)
If query <> TRUE Then
Cls
Print "Error : HTTPQueryInfo", ErrorMessage(GetLastError)
InternetCloseHandle hsession
End If
Dim As _Unsigned _Integer64 bytesToRead
bytesToRead = Val(queryinfo)
Dim As String szBuffer
szBuffer = Space$(4097)
Dim As _Unsigned _Integer64 dwRead, bytesRead
If _FileExists(File) Then
Kill File
End If
Open File For Binary As #1
Dim As _Byte a
Dim As String filedownload
Dim As Long errr, bytesForRate
Dim x!
Dim y!
Dim Rate!
Dim As Single ratetime
Do
x! = Timer
a = InternetReadFile(httpRequest, _Offset(szBuffer), Len(szBuffer) - 1, _Offset(dwRead))
errr = GetLastError
If dwRead > 0 Then
filedownload = Mid$(szBuffer, 1, dwRead)
Put #1, , filedownload
bytesRead = bytesRead + dwRead
bytesForRate = bytesForRate + dwRead
ratetime = timeElapsedSince(x!)
If _Round(ratetime) >= 1 Then
Rate! = (bytesForRate / ratetime) / KILOBYTE
bytesForRate = 0
End If
Cls
Print "Downloading to " + File
If bytesToRead <> 0 Then
Select Case bytesRead
Case Is < KILOBYTE
Print Using "#### B downloaded of "; bytesRead;
Case Is < MEGABYTE And bytesRead >= KILOBYTE
Print Using "####.## KB downloaded of "; (bytesRead / KILOBYTE);
Case Is < GIGABYTE And bytesRead >= MEGABYTE
Print Using "####.## MB downloaded of "; (bytesRead / MEGABYTE);
Case Is < TERABYTE And bytesRead >= GIGABYTE
Print Using "####.## GB downloaded of "; (bytesRead / GIGABYTE);
End Select
Select Case bytesToRead
Case Is < KILOBYTE
Print Using "#### B"; bytesToRead
Case Is < MEGABYTE And bytesToRead >= KILOBYTE
Print Using "####.## KB"; (bytesToRead / KILOBYTE)
Case Is < GIGABYTE And bytesToRead >= MEGABYTE
Print Using "####.## MB"; (bytesToRead / MEGABYTE)
Case Is < TERABYTE And bytesToRead >= GIGABYTE
Print Using "####.## GB"; (bytesToRead / GIGABYTE)
End Select
Print Using "###.##%"; bytesRead / bytesToRead * 100
Else
Select Case bytesRead
Case Is < KILOBYTE
Print Using " #### B downloaded"; bytesRead
Case Is < MEGABYTE And bytesRead >= KILOBYTE
Print Using "####.## KB downloaded"; (bytesRead / KILOBYTE)
Case Is < GIGABYTE And bytesRead >= MEGABYTE
Print Using "####.## MB downloaded"; (bytesRead / MEGABYTE)
Case Is < TERABYTE And bytesRead >= GIGABYTE
Print Using "####.## GB downloaded"; (bytesRead / GIGABYTE)
End Select
End If
Select Case Rate!
Case Is < KILOBYTE
Print Using "Rate: #### Bps"; Rate!
Case Is < MEGABYTE And Rate! >= KILOBYTE
Print Using "Rate: ####.## KBps"; Rate! / KILOBYTE
Case Is < GIGABYTE And Rate! >= MEGABYTE
Print Using "Rate: ####.## MBps"; Rate! / MEGABYTE
Case Is < TERABYTE And Rate! >= GIGABYTE
Print Using "Rate: ####.## GBps"; Rate! / GIGABYTE
End Select
'Print "Rate="; _Round(Rate!); "KBps"
_Display
End If
Loop Until bytesRead = bytesToRead Or errr <> 0
If errr Then
Print "Error downloading file:"; errr
Close #1
InternetCloseHandle hsession
Kill File
Exit Sub
Else
End If
Close #1
InternetCloseHandle hsession
Cls
Select Case bytesRead
Case Is < KILOBYTE
Print Using "#### B downloaded of "; bytesRead;
Case Is < MEGABYTE And bytesRead >= KILOBYTE
Print Using "####.## KB downloaded of "; (bytesRead / KILOBYTE);
Case Is < GIGABYTE And bytesRead >= MEGABYTE
Print Using "####.## MB downloaded of "; (bytesRead / MEGABYTE);
Case Is < TERABYTE And bytesRead >= GIGABYTE
Print Using "####.## GB downloaded of "; (bytesRead / GIGABYTE);
End Select
Select Case bytesToRead
Case Is < KILOBYTE
Print Using "#### B"; bytesToRead
Case Is < MEGABYTE And bytesToRead >= KILOBYTE
Print Using "####.## KB"; (bytesToRead / KILOBYTE)
Case Is < GIGABYTE And bytesToRead >= MEGABYTE
Print Using "####.## MB"; (bytesToRead / MEGABYTE)
Case Is < TERABYTE And bytesToRead >= GIGABYTE
Print Using "####.## GB"; (bytesToRead / GIGABYTE)
End Select
Print Using "###.##%"; bytesRead / bytesToRead * 100
Print "Downloaded to " + File
End Sub
Function timeElapsedSince! (startTime!)
If startTime! > Timer Then startTime! = startTime! - 86400
timeElapsedSince! = Timer - startTime!
End Function
Function ErrorMessage$ (errCode As Long)
Const FORMAT_MESSAGE_ALLOCATE_BUFFER = &H00000100
Const FORMAT_MESSAGE_FROM_SYSTEM = &H00001000
Const FORMAT_MESSAGE_IGNORE_INSERTS = &H00000200
Const LANG_NEUTRAL = &H00
Const SUBLANG_DEFAULT = &H01
Dim As _Offset lpMsgBuf
Dim As Long msg
msg = FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER Or _
FORMAT_MESSAGE_FROM_SYSTEM Or _
FORMAT_MESSAGE_IGNORE_INSERTS, _
0, _
errCode, _
MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), _
_Offset(lpMsgBuf), _
0, 0)
ErrorMessage = pointerToString(lpMsgBuf)
End Function
Function pointerToString$ (pointer As _Offset)
Declare CustomType Library
Function strlen%& (ByVal ptr As _Unsigned _Offset)
End Declare
Dim As _Offset length: length = strlen(pointer)
If length Then
Dim As _MEM pString: pString = _Mem(pointer, length)
Dim As String ret: ret = Space$(length)
_MemGet pString, pString.OFFSET, ret
_MemFree pString
End If
pointerToString = ret
End Function
|
|
|
|
| Change in Function operation? |
|
Posted by: dano - 09-17-2022, 11:59 AM - Forum: Help Me!
- Replies (4)
|
 |
The following worked several versions back:
Function CountUnmarked% (KSorCC$)
CountUnmarked% = 0
If KSorCC$ = "KS" Then
For x = 1 To TotKSrecs%
If KSdata$(Assigned%, x) = "N" Then CountUnmarked% = CountUnmarked% + 1
Next x
Else
For x = 1 To TotCCrecs%
If CCdata$(Assigned%, x) = "N" Then CountUnmarked% = CountUnmarked% + 1
Next x
End If
End Function
With PE edition, you cannot use the variable CountUnmarked% the same as you would any other variable (within the function). It appears that QB64 thinks that you are calling the function again. Instead you have to use a temp variable and then assign that value to CountUnmarked% before exiting the function:
Function CountUnmarked% (KSorCC$)
tCountUnmarked% = 0
If KSorCC$ = "KS" Then
For x = 1 To TotKSrecs%
If KSdata$(Assigned%, x) = "N" Then tCountUnmarked% = tCountUnmarked% + 1
Next x
Else
For x = 1 To TotCCrecs%
If CCdata$(Assigned%, x) = "N" Then tCountUnmarked% = tCountUnmarked% + 1
Next x
End If
CountUnmarked% = tCountUnmarked%
End Function
Is this because recursion code changed ? I can make adjustments if this is proper operation, no biggie. I just wanted to mention this in case is this is a bug...<ahem>...errr...an 'undocumented feature'.
Thanks to all,
Dano
|
|
|
|
| Font anti-aliasing |
|
Posted by: TerryRitchie - 09-16-2022, 10:36 PM - Forum: General Discussion
- Replies (2)
|
 |
I could have swore QB64 at one point supported font anti-aliasing through either the _PRINTSTRING or _PRINTMODE statements? I can't seem to find any way to anti-alias a loaded font. Am I missing something?
|
|
|
|
| 3D how to |
|
Posted by: MasterGy - 09-16-2022, 09:16 PM - Forum: MasterGy
- Replies (4)
|
|
I would like to put together a write up that explains how the 3D display works as I use it. Through an example program, I thought I would describe in detail what it does. After I put together a simple program, I think a lot of things are understandable. I left out all the unnecessary stuff. I will show more detailed writing and explanations later.
Code: (Select All) 'create texture
shadows = 100
DIM texture(shadows - 1)
text_size = 100
FOR at = 0 TO shadows - 1
temp = _NEWIMAGE(text_size, text_size, 32)
_DEST temp
grey = 255 - 252 / (shadows - 1) * at
COLOR _RGB(grey, grey, grey)
CIRCLE (text_size / 2, text_size / 2), text_size * .45
PAINT (text_size / 2, text_size / 2)
texture(at) = _COPYIMAGE(temp, 33)
_FREEIMAGE temp
NEXT at
'create 3D points in a spherical shape
points_c = 3000
space_size = 1000
DIM points(points_c - 1, 2)
FOR ap = 0 TO points_c - 1
DO
points(ap, 0) = space_size * RND
points(ap, 1) = space_size * RND
points(ap, 2) = space_size * RND
LOOP WHILE SQR((points(ap, 0) - space_size / 2) ^ 2 + (points(ap, 1) - space_size / 2) ^ 2 + (points(ap, 2) - space_size / 2) ^ 2) > space_size / 2
NEXT ap
'create spectator
DIM SHARED sp(6)
sp(0) = space_size / 2 'X to center space
sp(1) = space_size / 2 'Y to center space
sp(2) = space_size / 2 'Z to center space
sp(3) = 0 'looking in the direction of the observer XZ
sp(4) = 0 'looking in the direction of the observer YZ
sp(5) = 1 'multiplier X-Y see
sp(6) = 1 'multiplier Z see
'create screen
scr = _NEWIMAGE(1000, 1000 / _DESKTOPWIDTH * _DESKTOPHEIGHT, 32)
SCREEN scr
_MOUSEHIDE
_FULLSCREEN
_DEST scr
_DISPLAYORDER _HARDWARE , _SOFTWARE
PRINT "turn with the mouse, move with the mouse buttons, adjust the light with the mouse wheel!"
DO
_LIMIT 50
'draw points
FOR ap = 0 TO points_c - 1
x = points(ap, 0)
y = points(ap, 1)
z = points(ap, 2)
rotate_to_maptriangle x, y, z 'position of points from the point of view of the observer
actual_shadow = INT(ABS(z) * (.3 + brightness)) 'distance proportional texture
IF actual_shadow > shadows - 1 THEN actual_shadow = shadows - 1
IF actual_shadow < 0 THEN actual_shadow = 0
ps = 2 'point size on the screen
_MAPTRIANGLE (0, 0)-(text_size - 1, 0)-(0, text_size - 1), texture(actual_shadow) TO(x - ps, y - ps, z)-(x + ps, y - ps, z)-(x - ps, y + ps, z)
_MAPTRIANGLE (text_size - 1, text_size - 1)-(text_size - 1, 0)-(0, text_size - 1), texture(actual_shadow) TO(x + ps, y + ps, z)-(x + ps, y - ps, z)-(x - ps, y + ps, z)
NEXT ap
_DISPLAY
'mouse input axis movement and mousewheel
mousex = mousex * .6
mousey = mousey * .6
mw = 0
WHILE _MOUSEINPUT: mousex = mousex + _MOUSEMOVEMENTX: mousey = mousey + _MOUSEMOVEMENTY: mw = mw + _MOUSEWHEEL: WEND 'movement data read
'control spectator
mouse_sens = .001 'mouse rotating sensitive
sp(3) = sp(3) - mousex * mouse_sens
sp(4) = sp(4) + mousey * mouse_sens
IF ABS(sp(4)) > _PI / 2 THEN sp(4) = _PI / 2 * SGN(sp(4))
vec_x = (SIN(sp(3)) * (COS(sp(4) + _PI)))
vec_y = (COS(sp(3)) * (COS(sp(4) + _PI)))
vec_z = -SIN(sp(4) + _PI)
speed = 2 'moving speed
moving = ABS(_MOUSEBUTTON(1) OR _KEYDOWN(ASC("w"))) * speed - ABS(_MOUSEBUTTON(2) OR _KEYDOWN(ASC("s"))) * speed
sp(0) = sp(0) + vec_x * moving
sp(1) = sp(1) + vec_y * moving
sp(2) = sp(2) + vec_z * moving
'control brightness
brightness = brightness + mw / 50
LOOP UNTIL _KEYDOWN(27)
SUB rotate_to_maptriangle (x, y, z)
x2 = x - sp(0)
y2 = y - sp(1)
z2 = z - sp(2)
rotate_2d x2, y2, sp(3)
rotate_2d y2, z2, sp(4) + _PI / 2
x = x2 * sp(5)
y = y2 * sp(5)
z = z2 * sp(6)
END SUB
SUB rotate_2d (x, y, ang)
x1 = x * COS(ang) - y * SIN(ang)
y1 = x * SIN(ang) + y * COS(ang)
x = x1: y = y1
END SUB
|
|
|
|
| Minimal Text Animator |
|
Posted by: James D Jarvis - 09-15-2022, 08:42 PM - Forum: Works in Progress
- Replies (5)
|
|
Minimal Text Animator is exactly what this is. This is a very simple program to create and playback animations in 80x25 text mode.
It's simply structured with a main input loop, functions and subroutines are called from that loop. I want beginners to be able to look at this and modify it for their own needs. Currently there isn't much in the way of comments and there's a couple other commands I want to add but it certainly is a Minimal Text Animator right now.
Currently the user can Save and Load files, change the pen foreground and background color, change the character being drawn, and change the framerate. It's currently limited to 200 frames but that can easily be modified (just keep memory use and file size in mind).
Code: (Select All) 'Minimal Text Animator
'by James D. Jarvis Sept 15,2022 v 0.1
'
' a very minimal program to create and playback simple text screen animations
'S - Save file
'L - load file
'use mosue to draw
'N,n - create a new frame (limited to 200 as coded but you can edit that if you wish
'P,p - play animation
'F,f - change pen foreground color , you'll have to enter color number afterward
'B,b - change pen background color, you'll have to enter color number afterward
'esc - to quit program.... be careful this just dumps you out and you'll lose any work currently
'
'nothing fancy here at all, just a minimal program that functions
Screen _NewImage(80, 25, 0)
_Title "Minimal Text Animator"
Type gcelltype
t As String * 1
fgk As _Byte
bgk As _Byte
End Type
Dim Shared maxtx, maxty, maxframes, pen$, fg_klr, bg_klr, pen_klr
Dim Shared showonion, framerate, lastframe
framerate = 20
maxtx = _Width
maxty = _Height
maxframes = 200
pen$ = "*"
showonion = 0
Print "Minimal Text Animator"
_ControlChr Off
Dim Shared gcell(maxframes, maxtx, maxty) As gcelltype
For f = 1 To maxframes
For y = 1 To _Height
For x = 1 To _Width
gcell(f, x, y).t = " "
gcell(f, x, y).fgk = 15
gcell(f, x, y).bgk = 0
Next x
Next y
Next f
frameno = 1
fg_klr = 15
bg_klr = 0
pen_klr = 15
Color fg_klr, bg_klr
'main program loop
Do
_Limit 60
Do While _MouseInput ' Check the mouse status
If _MouseButton(1) Then 'draw that square if the
mx = _MouseX: my = _MouseY
gcell(frameno, mx, my).t = pen$
gcell(frameno, mx, my).fgk = pen_klr
gcell(frameno, mx, my).bgk = bg_klr
Color pen_klr, gcell(frameno, mx, my).bgk
_PrintString (mx, my), gcell(frameno, mx, my).t
End If
Color 15, 0
Loop
Select Case kk$
Case "n", "N"
Cls
frameno = frameno + 1
If frameno > maxframes Then frameno = 1
If showonion = 1 And frameno > 1 Then drawonion (frameno - 1)
drawframe frameno
lastframe = frameno
Case "o", "O"
If showonion = 0 Then
Cls
showonion = 1
drawonion (frameno - 1)
drawframe frameno
Else
showonion = 0
End If
Case "p", "P" 'play the animation
playanimation 1, lastframe
Case ",", "<" 'cycle down through drawn frames
frameno = frameno - 1
If frameno < 1 Then frameno = lastframe
drawframe frameno
Case ".", ">" 'cycle up through drawn frames
frameno = frameno + 1
If frameno > lastframe Then frameno = 1
Cls
drawframe frameno
Case "f", "F"
pen_klr = select_pencolor
Cls
drawframe frameno
Case "b", "B"
bg_klr = select_backgroundcolor
Cls
drawframe frameno
Case "S"
savefile
Cls
drawframe frameno
Case "L"
loadfile
Cls
playanimation 1, lastframe
frameno = 1
Case "h", "H", "?"
helpme
Cls
drawframe frameno
Case "r", "R"
framerate = newrate
Cls
drawframe frameno
Case "c", "C"
pen$ = Chr$(newchar)
Cls
drawframe frameno
End Select
kk$ = InKey$
If kk$ = "f" Then _PrintString (1, 1), Str$(frameno)
Loop Until kk$ = Chr$(27)
Sub drawframe (f As Integer)
For y = 1 To _Height
For x = 1 To _Width
If onion = 0 Then
Color gcell(f, x, y).fgk, gcell(f, x, y).bgk
_PrintString (x, y), gcell(f, x, y).t
Else
If gcell(f, x, y).t <> " " Then
Color gcell(f, x, y).fgk, gcell(f, x, y).bgk
_PrintString (x, y), gcell(f, x, y).t
End If
End If
Next
Next
Color 15, 0
End Sub
Sub drawonion (f As Integer)
For y = 1 To _Height
For x = 1 To _Width
Color 8, 0
_PrintString (x, y), gcell(f, x, y).t
Next
Next
Color 15, 0
End Sub
Sub playanimation (ff, lf)
For f = ff To lf
Cls
_Limit framerate
For y = 1 To _Height
For x = 1 To _Width
Color gcell(f, x, y).fgk, gcell(f, x, y).bgk
_PrintString (x, y), gcell(f, x, y).t
Next
Next
_Display
Next f
_AutoDisplay
Color 15, 0
End Sub
Function select_pencolor
Cls
Color 15, 0
Print "SELECT PEN COLOR"
Print
Print " 0.",: Color 0, 0: Print Chr$(219),: Color 15, 0: Print "16.",: Color 16, 0: Print Chr$(219): Color 15, 0
Print " 1.",: Color 1, 0: Print Chr$(219),: Color 15, 0: Print "17.",: Color 17, 0: Print Chr$(219): Color 15, 0
Print " 2.",: Color 2, 0: Print Chr$(219),: Color 15, 0: Print "18.",: Color 18, 0: Print Chr$(219): Color 15, 0
Print " 3.",: Color 3, 0: Print Chr$(219),: Color 15, 0: Print "19.",: Color 19, 0: Print Chr$(219): Color 15, 0
Print " 4.",: Color 4, 0: Print Chr$(219),: Color 15, 0: Print "20.",: Color 20, 0: Print Chr$(219): Color 15, 0
Print " 5.",: Color 5, 0: Print Chr$(219),: Color 15, 0: Print "21.",: Color 21, 0: Print Chr$(219): Color 15, 0
Print " 6.",: Color 6, 0: Print Chr$(219),: Color 15, 0: Print "22.",: Color 22, 0: Print Chr$(219): Color 15, 0
Print " 7.",: Color 7, 0: Print Chr$(219),: Color 15, 0: Print "23.",: Color 23, 0: Print Chr$(219): Color 15, 0
Print " 8.",: Color 8, 0: Print Chr$(219),: Color 15, 0: Print "24.",: Color 24, 0: Print Chr$(219): Color 15, 0
Print " 9.",: Color 9, 0: Print Chr$(219),: Color 15, 0: Print "25.",: Color 25, 0: Print Chr$(219): Color 15, 0
Print "10.",: Color 10, 0: Print Chr$(219),: Color 15, 0: Print "26.",: Color 26, 0: Print Chr$(219): Color 15, 0
Print "11.",: Color 11, 0: Print Chr$(219),: Color 15, 0: Print "27.",: Color 27, 0: Print Chr$(219): Color 15, 0
Print "12.",: Color 12, 0: Print Chr$(219),: Color 15, 0: Print "28.",: Color 28, 0: Print Chr$(219): Color 15, 0
Print "13.",: Color 13, 0: Print Chr$(219),: Color 15, 0: Print "29.",: Color 29, 0: Print Chr$(219): Color 15, 0
Print "14.",: Color 14, 0: Print Chr$(219),: Color 15, 0: Print "30.",: Color 30, 0: Print Chr$(219): Color 15, 0
Print "15.",: Color 15, 0: Print Chr$(219),: Color 15, 0: Print "31.",: Color 31, 0: Print Chr$(219): Color 15, 0
Do
Locate 20, 3: Input "enter color from 0 to 31 ", kk$
Loop Until Val(kk$) > -1 Or Val(kk$) < 32
select_pencolor = Val(kk$)
End Function
Function newrate
Cls
Print "Change Frame Rate ?"
Print
Print "Current frame rate is "; framerate
Print
Do
Locate 20, 3: Input "enter color from 1 to 60 ", kk$
Loop Until Val(kk$) > 0 Or Val(kk$) < 61
newrate = Val(kk$)
End Function
Function select_backgroundcolor
Cls
Color 15, 0
Print "SELECT Background COLOR"
Print
Print " 0.",: Color 0, 0: Print Chr$(219),: Color 15, 0
Print " 1.",: Color 1, 0: Print Chr$(219): Color 15, 0
Print " 2.",: Color 2, 0: Print Chr$(219),: Color 15, 0
Print " 3.",: Color 3, 0: Print Chr$(219): Color 15, 0
Print " 4.",: Color 4, 0: Print Chr$(219),: Color 15, 0
Print " 5.",: Color 5, 0: Print Chr$(219): Color 15, 0
Print " 6.",: Color 6, 0: Print Chr$(219),: Color 15, 0
Print " 7.",: Color 7, 0: Print Chr$(219): Color 15, 0
Print " 8.",: Color 8, 0: Print Chr$(219),: Color 15, 0
Print " 9.",: Color 9, 0: Print Chr$(219): Color 15, 0
Print "10.",: Color 10, 0: Print Chr$(219),: Color 15, 0
Print "11.",: Color 11, 0: Print Chr$(219): Color 15, 0
Print "12.",: Color 12, 0: Print Chr$(219),: Color 15, 0
Print "13.",: Color 13, 0: Print Chr$(219): Color 15, 0
Print "14.",: Color 14, 0: Print Chr$(219),: Color 15, 0
Print "15.",: Color 15, 0: Print Chr$(219): Color 15, 0
Do
Locate 20, 1: Input "enter color from 0 to 31", kk$
Loop Until Val(kk$) > -1 Or Val(kk$) < 32
select_backgroundcolor = Val(kk$)
End Function
Sub helpme
Cls
Print "HELP"
Print
Print "S - Save file "
Print "L - load file "
Print "use mosue to draw"
Print "N,n - create a new frame (limited to 200 as coded but you can edit that if you wish"
Print "P,p - play animation"
Print "C,c - change pen foreground color , you'll have to enter color number afterward"
Print "B,b - change pen background color, you'll have to enter color number afterward"
Print "R,r - change framerate for animation"
Print "esc - to quit program.... be careful this just dumps you out and you'll lose any work currently"
Print
Print "Press any key to continue"
any$ = Input$(1)
End Sub
Function newchar
Dim mc(0 To 256, 2)
Cls
x = 0
y = 3
newc = -1
Print "Click on the Character you wish to use."
For c = 0 To 255
x = x + 2
If x > 60 Then
x = 2
y = y + 2
End If
_PrintString (x, y), Chr$(c)
mc(c, 1) = x
mc(c, 2) = y
Next c
Do
_Limit 60
Do While _MouseInput ' Check the mouse status
If _MouseButton(1) Then 'draw that square if the
mx = _MouseX: my = _MouseY
c = 0
Do
If mc(c, 1) = mx And mc(c, 2) = my Then newc = c
c = c + 1
If c = 256 Then newc = -2
Loop Until newc <> -1
If newc = -2 Then newc = -1
End If
Color 15, 0
Loop
Loop Until newc <> -1
newchar = newc
End Function
Sub savefile
Locate 1, 1
Print "Enter file name "
Locate 2, 1
Input filename$
Open filename$ For Output As #1
Write #1, framerate, maxtx, maxty, lastframe
For f = 1 To lastframe
For y = 1 To maxty
For x = 1 To maxtx
Write #1, gcell(f, x, y).t, gcell(f, x, y).fgk, gcell(f, x, y).bgk
Print gcell(f, x, y).t, gcell(f, x, y).fgk, gcell(f, x, y).bgk
Next x
Next y
Next f
Close #1
Locate 3, 1
Print filename$; " saved"
Print "press any key to continue"
any$ = Input$(1)
End Sub
Sub loadfile
Locate 1, 1
Print "Enter file name "
Locate 2, 1
Input filename$
Open filename$ For Input As #1
Input #1, framerate, maxtx, maxty, lastframe
For f = 1 To lastframe
For y = 1 To maxty
For x = 1 To maxtx
Input #1, gcell(f, x, y).t, gcell(f, x, y).fgk, gcell(f, x, y).bgk
Print gcell(f, x, y).t, gcell(f, x, y).fgk, gcell(f, x, y).bgk
Next x
Next y
Next f
Close #1
Locate 3, 1
Print filename$; " loaded"
Print "press any key to continue"
any$ = Input$(1)
End Sub
|
|
|
|
| Lakeshore 218 Temperature Monitor |
|
Posted by: CJAlva - 09-15-2022, 03:46 PM - Forum: Help Me!
- Replies (14)
|
|
Hey all!
I'm currently using a Lakeshore 218 Temperature monitor and was hoping to be able to grab readings using QBasic. Here's what I have so far:
CLS 'Clear screen
PRINT " SERIAL COMMUNICATION PROGRAM"
PRINT
TIMEOUT = 2000 'Read timeout (may need more)
BAUD$ = "9600"
TERM$ = CHR$(13) + CHR$(10) 'Terminators are <CR><LF>
OPEN "COM1:" + BAUD$ + ",O,7,1,RS" FOR RANDOM AS #1 LEN = 256
LOOP1: LINE INPUT "ENTER COMMAND (or EXIT):"; CMD$ 'Get command from keyboard
CMD$ = UCASE$(CMD$) 'Change input to upper case
IF CMD$ = "EXIT" THEN CLOSE #1: END 'Get out on Exit
CMD$ = CMD$ + TERM$
PRINT #1, CMD$; 'Send command to instrument
IF INSTR(CMD$, "?") <> 0 THEN 'Test for query
RS$ = "" 'If query, read response
N = 0 'Clr return string and count
WHILE (N < TIMEOUT) AND (INSTR(RS$, TERM$) = 0) 'Wait for response
IN$ = INPUT$(LOC(1), #1) 'Get one character at a time
IF IN$ = "" THEN N = N + 1 ELSE N = 0 'Add 1 to timeout if no chr
RS$ = RS$ + IN$ 'Add next chr to string
WEND 'Get chrs until terminators
IF RS$ <> "" THEN 'See if return string is empty
RS$ = MID$(RS$, 1, (INSTR(RS$, TERM$) - 1))'Strip off terminators
PRINT "RESPONSE:"; RS$ 'Print response to query
ELSE
PRINT "NO RESPONSE" 'No response to query
END IF
END IF 'Get next command
GOTO LOOP1
When I compile and run, I get an error calling out line 17 (IN$ = INPUT$(LOC(1), #1) 'Get one character at a time) and saying "Input past end of file". No clue how to mitigate this. Can anyone help out?
|
|
|
|
| Forum down time. |
|
Posted by: Pete - 09-14-2022, 09:29 PM - Forum: Announcements
- Replies (10)
|
 |
For the past 24 hours, I've noticed an inability to connect to the forum for several minutes. This has occurred approximately 6 times so far. Anyone else experiencing similar forum down time?
Pete
|
|
|
|
|
