| 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: 762
|
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
|
|
|
| DAY 038: _MOUSEWHEEL |
|
Posted by: Pete - 12-18-2022, 10:11 AM - Forum: Keyword of the Day!
- No Replies
|
 |
Pretty simple...
SYNTAX scrollAmount% = _MOUSEWHEEL
Usage: Track the scrolling increments of the mouse wheel.
Example:
Code: (Select All) DIM x AS INTEGER
DO
_LIMIT 30
WHILE _MOUSEINPUT
x = x + _MOUSEWHEEL ' Must be placed inside WHILE/WEND loop.
WEND
lb = _MOUSEBUTTON(1) ' Left mouse button. Better placed outside of WHILE/WEND loop.
IF lb THEN x = 0 ' reset mousewheel counter.
LOCATE 1, 1: PRINT x; " ";
LOOP
One thing to keep in mind is unlike most of the other _MOUSE... keywords, _MOUSEWHEEL has to be placed between WHILE _MOUSEINPUT and WEND statements to be read, not after it like the _MOUSEBUTTON statements.
Note: _MOUSEMOVEX and _MOUSEMOVEY is another example of _MOUSE keywords which need to b placed between, not after, the WHILE/WEND _MOUSEINPUT loop.
Now if you only want to know the direction of the mouse wheel, use SGN() as in...
Code: (Select All) DIM AS INTEGER x, sgnx
DO
_LIMIT 30
WHILE _MOUSEINPUT
x = x + _MOUSEWHEEL
WEND
lb = _MOUSEBUTTON(1) ' Left mouse button.
IF lb THEN x = 0 ' reset mousewheel counter.
sgnx = SGN(x - oldx): oldx = x
LOCATE 1, 1: PRINT x; " ";: IF sgnx THEN PRINT sgnx; " ";: IF sgnx = -1 THEN PRINT "Up "; ELSE PRINT "Down"; " ";
LOOP
Pete
|
|
|
| program crashes about 20% of the time |
|
Posted by: billythebull - 12-18-2022, 12:55 AM - Forum: Help Me!
- Replies (21)
|
 |
PITABLE.txt (Size: 44.47 KB / Downloads: 36)
This program crashes about 20% of the time. Any help appreciated.
Code: (Select All) '_FullScreen
Version$ = "Beta Version 0.31"
$ExeIcon:'ultpizza.ico'
_Icon
_Title "ULTIMATE PIZZA POS - POINT OF SALE" + " " + Version$ + " " + "© 2006-2016 MasterSoft LLC. All Rights Reserved."
_ScreenMove _Middle
Do '**********************************************************************************************************
1
K$ = "frank"
result$ = _InputBox$("ULTIMATE PIZZA POS PASSWORD", "You must enter your password to run this program. If you forgot your password please see management", "")
'_ScreenMove _Middle
'If result$ = "" Then
'_MessageBox "ENTER PASSWORD", "Password Field can not be empty", "error"
'GoTo 1
'Else
If UCase$(result$) = UCase$(K$) Then
Exit Do
'Shell _DontWait "C:\Users\Bradley\Desktop\qb64pe_\ULTPIZZA-COUPONS.exe"
ElseIf result$ = "" Then
System
Else
_NotifyPopup "ERROR", "INCORRECT PASSWORD ENTERED", "warning"
GoTo 1
End If
Loop
'**********************************************************************************************************
_FullScreen
'_MOUSEHIDE
'**************************************************************************************************************
'********************************************** Shared Variables **********************************************
'**************************************************************************************************************
Const CTRL = 100306
Const ALT = 100308
Const F12 = 34304
Dim Shared useprinter
Dim Shared HF
Common Shared BK1
Dim Shared CN
Dim Shared ENDER
Dim Shared printstring3$
Dim Shared fontpath$
Dim Shared phone$
Dim Shared Back$
Dim Shared chkno
Dim Shared PRICE
Dim Shared VOIDS
Dim Shared REFUNDS
Dim Shared COUPCNT$
Dim Shared TOTALSALESCNT$
Dim Shared TOTALSALESCNT
Dim Shared COUPON
Dim Shared COUPCNT
Dim Shared code
Dim Shared Styper$
Dim Shared typer$
Dim Shared SALESTYPE$
Dim Shared taxrate
Dim Shared RECEIPT$
Dim Shared PP$
Dim Shared mask$
Dim Shared line1
Dim Shared row
Dim Shared page
Dim Shared M$
Dim Shared tax
Dim Shared DELCNT
Dim Shared VOIDCOUPDOLLARS
Dim Shared subtotal As _Integer64
ReDim Shared RECEIPT$(1100, 2)
Dim Shared DESCRIPTION$
Dim Shared total As _Integer64
Dim Shared ZSUBTOTAL As _Float
Dim Shared ZTAX As _Float
Dim Shared ZTOTAL As _Float
Dim Shared XSUBTOTAL As _Float
Dim Shared XTAX As _Float
Dim Shared XTOTAL As _Float
Dim Shared XCOUPON As _Float
Dim Shared del As _Integer64
Dim Shared TABLE$(540, 6, 1), PRICE$(4) ' FORMAT$(5), X(5)
Common Shared DESCRIPTION$(), PRICE(), LINES, OFFSET, INSTRUCT$(), F1, delivery, DELTIME, PICKTIME
Common Shared NAME1$, NAME$, STREET1$, STREET$, CITY1$, CITY$, FKEY(), opencode$
Common Shared PHONE1$, PHONE2$, LASTRECORD$, BK, USEMENU, MENU$(), MENULABEL$()
'**************************************************************************************************************
'**************************************** Turn on Screen Resizing *********************************************
'**************************************************************************************************************
$Resize:On
_Resize , _Smooth
'**************************************************************************************************************
'********************************************* Set Font Path **************************************************
'**************************************************************************************************************
fontpath$ = Environ$("SYSTEMROOT") + "\fonts\cour.ttf"
printstring3$ = " " + "###"
'**************************************************************************************************************
'********************************************* Screen Settings ************************************************
'**************************************************************************************************************
DeskTop& = _ScreenImage ' *** Capture the Desktop image
DT_Width& = _Width(DeskTop&) - 27 ' *** Get the Desktop Width
DT_Height& = _Height(DeskTop&) ' *** Get the Desktop Height
MainScreen~& = _NewImage(DT_Width&, DT_Height&, 32) '1600, 900, 32)
Screen MainScreen~&
_ScreenMove (DT_Width& - _Width(MainScreen~&)) / 2, (DT_Height& - _Height(MainScreen~&)) / 2
_FullScreen
'**************************************************************************************************************
'**************************************** Set Title and Load Splash screen ************************************
'**************************************************************************************************************
i& = _LoadImage("pizzasplash.jpg", 32)
_Icon i&
Screen i&
Sleep 10
Rem $DYNAMIC
Screen 0, 0, 0, 0: Cls
Dim MENU$(1): MENU$(0) = "MENU1": MENU$(1) = "MENU2"
Dim INSTRUCT$(7), FKEY(20, 2), MENULABEL$(20)
Call BEGINNING
'**************************************************************************************************************
'****************************** Open and Read table.dat and load arrays into memory ***************************
'**************************************************************************************************************
Sub MENUCHOICE
Screen 0, 0, 23, 23
View Print 1 To 25
If CsrLin <> 25 Then Print Else flag = 1
If CsrLin = 25 And flag = 1 Then Locate 25, 1:
font& = _LoadFont(fontpath$, 20, "MONOSPACE,BOLD")
_Font font&
Color 14, 1
Print Chr$(201) + String$(78, Chr$(205)) + Chr$(187)
For a = 1 To 2
Print Chr$(186) + String$(78, Chr$(255)) + Chr$(186)
Next a
Print Chr$(204) + String$(50, Chr$(205)) + Chr$(209) + String$(27, Chr$(205)) + Chr$(185)
For a = 1 To 19
Print Chr$(186) + String$(50, Chr$(255)) + Chr$(179) + String$(27, Chr$(255)) + Chr$(186)
Next a
Print Chr$(200) + String$(50, Chr$(205)) + Chr$(207) + String$(27, Chr$(205)) + Chr$(188)
Color 15, 12
Locate 2, 14: Print " P I Z Z A O P T I O N S "
Locate 3, 14: Print " M A I N M E N U "
Color 15, 5
Locate 21, 5: Print "** PLEASE SEE DESCRIPTION TO THE RIGHT **"
Color 15, 13
Locate 6, 5: Print "PRESS THE F KEY or HIGHLIGHT SELECTION FROM"
Locate 7, 5: Print "BELOW USING" + " " + Chr$(24) + Chr$(25) + " AND PRESS ENTER TO SELECT. "
Color 15, 11
For a = 8 To 20
Locate a, 5: Print String$(43, Chr$(255)) ' menu header
Next a
Start:
Option Base 1
Dim MenuItem(8) As String * 30 'define the menu item array
Dim ChooseItem As Integer ' currently chossen menu item
Dim XMenuPosn As Integer 'controls menu x positions
Dim YMenuPosn As Integer 'controls menu y position
Dim Count As Integer
Dim EndMenu As Integer
' menu items
MenuItem$(1) = "F1 - Z READING REPORT "
MenuItem$(2) = "F2 - X READING REPORT "
MenuItem$(3) = "F3 - VOID/REPRINT CHK "
MenuItem$(4) = "F4 - CHECK TICKET STATUS "
MenuItem$(5) = "F5 - RING UP A SALE "
MenuItem$(6) = "F6 - RTN TO MAIN SCREEN "
MenuItem$(7) = "F7 - EXIT PIZZA PROGRAM "
MenuItem$(8) = "F8 - STOCK TABLE SETTINGS"
ChooseItem = 1 'Starting point of highlighted menu item
XMenuPosn = 26 'X starting point of menu
YMenuPosn = 10 'Y starting point of menu
GoSub DrawMenu
Do
Cmmnd$ = (InKey$)
If Len(Cmmnd$) = 2 Then Cmmnd$ = Right$(Cmmnd$, 1)
If Cmmnd$ = "8" Or Cmmnd$ = Chr$(72) Then GoSub MoveUp
If Cmmnd$ = "2" Or Cmmnd$ = Chr$(80) Then GoSub MoveDown
If Cmmnd$ = "7" Or Cmmnd$ = Chr$(71) Then ChooseItem = 1
If Cmmnd$ = "1" Or Cmmnd$ = Chr$(79) Then ChooseItem = UBound(MenuItem)
If Cmmnd$ = Chr$(13) Then EndMenu = 1
If Cmmnd$ = Chr$(59) Or Cmmnd$ = Chr$(30) Then
ChooseItem = 1
'EndMenu = 1
End If
If Cmmnd$ = Chr$(60) Or Cmmnd$ = Chr$(19) Then
ChooseItem = 2
'EndMenu = 1
End If
If Cmmnd$ = Chr$(61) Or Cmmnd$ = Chr$(50) Then
ChooseItem = 3
'EndMenu = 1
End If
If Cmmnd$ = Chr$(62) Or Cmmnd$ = Chr$(31) Then
ChooseItem = 4
'EndMenu = 1
End If
If Cmmnd$ = Chr$(63) Or Cmmnd$ = Chr$(25) Then
ChooseItem = 5
'EndMenu = 1
End If
If Cmmnd$ = Chr$(64) Or Cmmnd$ = Chr$(32) Then
ChooseItem = 6
'EndMenu = 1
End If
If Cmmnd$ = Chr$(65) Or Cmmnd$ = Chr$(16) Then
ChooseItem = 7
EndMenu = 1
End If
If Cmmnd$ = Chr$(66) Or Cmmnd$ = Chr$(16) Then
ChooseItem = 8
End If
If ChooseItem = 1 Then
Color 15, 1
GoSub ClearSidePanel
Locate 6, 53: Print "This Option Displays The "
Locate 7, 53: Print "Sales Information Over "
Locate 8, 53: Print "The Life Of The Register "
Locate 9, 53: Print "And Can Not Be Cleared. "
Locate 12, 53: Print "Options Include: "
Locate 14, 53: Print "Print Data To the Screen "
Locate 16, 53: Print "Print Z-Report On Printer "
Color 15, 3
ElseIf ChooseItem = 2 Then
Color 15, 1
GoSub ClearSidePanel
Locate 6, 53: Print "Display The X-Report Screen"
Locate 7, 53: Print "And Gives You A Quick snap-"
Locate 8, 53: Print "Shot Of Cash Drawer Sales "
Locate 10, 53: Print "Options Include: "
Locate 12, 53: Print "Display report on-screen "
Locate 14, 53: Print "Print without Clearing Sale"
Locate 15, 53: Print "Data File To Zero"
Locate 17, 53: Print "Print X-Report and Clear "
Locate 18, 53: Print "All Sales Data To Zero. "
Color 15, 3
ElseIf ChooseItem = 3 Then
Color 15, 1
GoSub ClearSidePanel
Locate 10, 53: Print " Void/Reprint Options: "
Locate 12, 53: Print " Void A Sale "
Locate 14, 53: Print " Reprint A Check "
Color 15, 3
ElseIf ChooseItem = 4 Then
Color 15, 1
GoSub ClearSidePanel
Locate 12, 53: Print " Allows you to check the "
Locate 13, 53: Print " Status of a order ticket "
Locate 14, 53: Print " Open, Closed, or Voided "
Color 15, 3
ElseIf ChooseItem = 5 Then
Color 15, 1
GoSub ClearSidePanel
Locate 12, 53: Print " Allows you to ring up a "
Locate 13, 53: Print " Customers order when they "
Locate 14, 53: Print " come to pick it up "
Color 15, 3
ElseIf ChooseItem = 6 Then
Color 15, 1
GoSub ClearSidePanel
Locate 12, 53: Print "Exits Program Execution and"
Locate 13, 53: Print "Returns Control Over To The"
Locate 14, 53: Print "Main Program Order Screen. "
Color 15, 3
ElseIf ChooseItem = 7 Then
Color 15, 1
GoSub ClearSidePanel
Locate 12, 53: Print "Exits Program Execution and"
Locate 13, 53: Print "Returns Control Over To The"
Locate 14, 53: Print "Operating System "
Color 15, 3
End If
If Len(Cmmnd$) = 2 Then Cmmnd$ = Right$(Cmmnd$, 1)
GoSub DrawMenu
Loop Until EndMenu = 1
If ChooseItem = 1 Then Call GET_ZREPORT
If ChooseItem = 2 Then Call GET_XREPORT
If ChooseItem = 3 Then Call VOID
If ChooseItem = 4 Then Call CHKSTATUS
If ChooseItem = 5 Then F1 = 0: Call RINGSALE
If ChooseItem = 6 Then MAIN
If ChooseItem = 7 Then System
If ChooseItem = 8 Then Run "NEWSTOCK21"
MAIN
Exit Sub
ClearSidePanel:
_Limit (10)
For xx = 5 To 22
Locate xx, 53: Print " "
Next xx
Return
DrawMenu:
Locate YMenuPosn, XMenuPosn
For Counts = 1 To UBound(MenuItem$)
If Counts = ChooseItem Then Color 6 Else Color 15
Locate , 14: Print MenuItem$(Counts)
Locate CsrLin, XMenuPosn
Next Counts
Return
MoveUp:
If ChooseItem = 1 Then
ChooseItem = UBound(MenuItem$)
Else
ChooseItem = ChooseItem - 1
End If
Return
MoveDown:
If ChooseItem = UBound(MenuItem$) Then
ChooseItem = 1
Else
ChooseItem = ChooseItem + 1
End If
Return
exit1:
System
End Sub
Sub BEGINNING
PP$ = "##,###.##"
a = 1100
ReDim DESCRIPTION$(a), PRICE(a) ', FKEY(20, 1)
Open "R", 1, "PITABLE.DB", 60
Field #1, 24 As DESCRIBE$, 1 As CODE$
For a = 1 To 4: Field #1, 26 + (a - 1) * 6 As A$, 6 As PRICE$(a): Next
Field #1, 50 As A$, 2 As MENU$: Field #1, 60 As AA$
For a = 1 To 360
Get 1, a
TABLE$(a, 0, 0) = DESCRIBE$: TABLE$(a, 1, 0) = CODE$
For B = 1 To 4: TABLE$(a, B + 1, 0) = PRICE$(B): Next B
TABLE$(a, 6, 0) = MENU$
Next a
For a = 1 To 360
Get 1, a + 360
TABLE$(a, 0, 1) = DESCRIBE$: TABLE$(a, 1, 1) = CODE$
For B = 1 To 4: TABLE$(a, B + 1, 1) = PRICE$(B): Next B
TABLE$(a, 6, 1) = MENU$
Next a
F$ = ""
Get 1, 721
For B = 0 To 2: For a = 1 To 20: FKEY(a, B) = Sgn(Asc(Mid$(AA$, a + B * 20, 1))): Next a, B
For a = 1 To 20
Get 1, a + 721: B$ = A$
88 G = InStr(B$, Chr$(0)): If G > 0 Then Mid$(B$, G, 1) = " ": GoTo 88
B$ = LTrim$(RTrim$(B$))
B$ = Space$(12 - Len(B$) \ 2) + B$
MENULABEL$(a) = B$
Next a
opencode$ = ""
Get 1, 758: Q$ = Left$(A$, 6): For a = 1 To 6: opencode$ = opencode$ + Chr$(Asc(Mid$(A$, a, 1))): Next a
For a = 6 To 1 Step -1
If Mid$(opencode$, a, 1) <> Chr$(0) Then Exit For
Next
opencode$ = Left$(opencode$, a)
useprinter = Sgn(Asc(Mid$(A$, 7, 1))) + 1
Field #1, 9 As NULL$, 4 As T$: T& = CVL(T$): If T& < 0 Or T& > 99999 Then T& = 0
taxrate = T& / 100000
Field #1, 13 As NULL$, 4 As D$: D& = CVL(D$): If D& < 0 Or D& > 9999 Then D& = 0
delivery = D& / 100
Get 1, 759
Field #1, 4 As DELTIME1$, 4 As PICKTIME1$
DELTIME = CVL(DELTIME1$): If DELTIME < 0 Or DELTIME > 99 Then DELTIME = 0
PICKTIME = CVL(PICKTIME1$): If PICKTIME < 0 Or PICKTIME > 99 Then PICKTIME = 0
'pickup time and delivery time in record 759
Close 1
' ***************************************************************************
' *** Select Case to control main screen Destination ***
' ***************************************************************************
Call MAIN
1 A$ = "": While A$ = "": A$ = InKey$: Wend
PP$ = "##,###.##"
X = _KeyHit
If A$ = Chr$(9) Then Call SEEMENUS(A$)
If A$ = Chr$(43) Then Call PICKUP_DEL ' <===> Plus key press to display the Carry-Out Delivery menu
If A$ = Chr$(0) + Chr$(59) Then Call Fkey_main(1) ' <=========================> F1 key press
If A$ = Chr$(0) + Chr$(60) Then Call Fkey_main(2) ' <=========================> F2 key press
If A$ = Chr$(0) + Chr$(61) Then Call Fkey_main(3) ' <=========================> F3 key press
If A$ = Chr$(0) + Chr$(62) Then Call Fkey_main(4) ' <=========================> F4 key press
If A$ = Chr$(0) + Chr$(63) Then Call Fkey_main(5) ' <=========================> F5 key press
If A$ = Chr$(0) + Chr$(64) Then Call Fkey_main(6) ' <=========================> F6 key press
If A$ = Chr$(0) + Chr$(65) Then Call Fkey_main(7) ' <=========================> F7 key press
If A$ = Chr$(0) + Chr$(66) Then Call Fkey_main(8) ' <=========================> F8 key press
If A$ = Chr$(0) + Chr$(67) Then Call Fkey_main(9) ' <=========================> F9 key press
If A$ = Chr$(0) + Chr$(68) Then Call Fkey_main(10) ' <=========================> F10 key press
If A$ = Chr$(0) + Chr$(71) Then Call Fkey_main(13) ' <=========================> Home Key press <=============> PAGE 13 = Fkey_13A
If A$ = Chr$(0) + Chr$(79) Then Call Fkey_main(15) ' <=========================> END Key press <=============> PAGE 14 = Fkey_14A
If A$ = Chr$(0) + Chr$(82) Then Call Fkey_main(14) ' <=========================> INSERT Key press <===========> PAGE 15 = Fkey_15A
If A$ = Chr$(0) + Chr$(83) Then Call Fkey_main(16) ' <=========================> DELETE Key press <===========> PAGE 16 = Fkey_16A
If UCase$(A$) = "P" Then Call Fkey_main(17) ' <=========================> "P" Key press <===> PAGE 17 = Fkey_17A
If UCase$(A$) = "L" Then Call Fkey_main(18) ' <=========================> "L" Key press <===> PAGE 18 = Fkey_18A
If UCase$(A$) = "X" Then Call Fkey_main(19) ' <=========================> "X" Key press <===> PAGE 19 = Fkey_19A
If UCase$(A$) = "Z" Then Call Fkey_main(20) ' <=========================> "Z" Key press <===> PAGE 20 = Fkey_20A
If A$ = Chr$(0) + Chr$(133) Then Call Fkey_main(11) '<=========================> F11 key press
If A$ = Chr$(0) + Chr$(134) Then Call Fkey_main(12) '<=========================> F12 key press
If A$ = Chr$(0) + Chr$(111) Then Call CUSTINFO ' <=========================> ALT + F8 Combo key press
If A$ = Chr$(0) + Chr$(112) Then Call TYPEINSTRUCTIONS ' <=========================> ALT + F9 Combo key press
If UCase$(A$) = "R" And LINES > 0 Then ' <=========================> (R) or (r) key press
Call REMOVELINE(DESCRIPTION$(), PRICE(), DESCRIPTION$, PRICE, LINES, line1) ' to remove line from sale
End If
If A$ = Chr$(0) + Chr$(140) Then
Call MENUCHOICE
Call SCROLL(DESCRIPTION$(), PRICE(), LINES, UPDOWN, DESCRIPTION$, PRICE, OFFSET, line1)
End If
If A$ = Chr$(0) + Chr$(72) Then ' <=======> Up Arrow Key Press to scroll the main order screen up
UPDOWN = -1: Call SCROLL(DESCRIPTION$(), PRICE(), LINES, UPDOWN, DESCRIPTION$, PRICE, OFFSET, line1)
End If
If A$ = Chr$(0) + Chr$(80) Then ' <===> Down Arrow Key Press to scroll the main order screen down
UPDOWN = 1: Call SCROLL(DESCRIPTION$(), PRICE(), LINES, UPDOWN, DESCRIPTION$, PRICE, OFFSET, line1)
End If
If A$ = Chr$(0) + Chr$(118) Then System ' <===================> CTRL + Page Down Key Press to exit program
If _KeyDown(CTRL) And _KeyDown(F12) Then
Erase RECEIPT$
ReDim RECEIPT$(1100, 2)
Erase DESCRIPTION$
Erase PRICE
del = 0
LINES = 0
DESCRIPTION$ = ""
COUPON = 0
COUPCNT = 0
TOTALSALESCNT = 0
VOIDCOUPDOLLARS = 0
PRICE = 0
line1 = 0
subtotal = 0
tax = 0
total = 0
NAME1$ = ""
STREET1$ = ""
CITY1$ = ""
PHONE1$ = ""
typer$ = ""
ReDim INSTRUCT$(7)
Call BEGINNING
End If
GoTo 1
End Sub
'**************************************************************************************************************
'**************************************** Add Item to the order screen ****************************************
'**************************************************************************************************************
Sub ADDARRAY (RECEIPT$(), DESCRIPTION$, PRICE, line1)
If LTrim$(DESCRIPTION$) <> "" Then
line1 = line1 + 1
RECEIPT$(line1, 1) = DESCRIPTION$
RECEIPT$(line1, 2) = Str$(PRICE)
Else
End If
End Sub
'**************************************************************************************************************
'********************************* Get totals for items in the order screen ***********************************
'**************************************************************************************************************
Sub GETTOTALS
'taxrate = VAL(TABLE$(540, 2, 0)) / 100
subtotal = subtotal + PRICE
del = delivery * 100
tax = subtotal * taxrate
If typer$ = "DELIVERY" Then
total = subtotal + tax + del
Else
total = subtotal + tax: del = 0!
End If
PRICE = 0
DESCRIPTION$ = ""
End Sub
Sub Fkey_main (pages)
If FKEY(pages, 0) = 0 Then Exit Sub
Color 12, 15
PCopy 0, 1
Screen 0, 0, 1, 1
Color 0, 15
page = pages
row = 4
OFFSET2 = pages * 18 - 27
Call MENUS
Color 4: Locate 2, 53: Print MENULABEL$(pages)
Do
WW: CHOOSE$ = "": While CHOOSE$ = "": CHOOSE$ = InKey$: Wend
TablePointer = Asc(UCase$(CHOOSE$)) - 55
If Asc(CHOOSE$) = 27 Or Asc(CHOOSE$) = 9 Then DESCRIPTION$ = "": Exit Do
If TablePointer < 10 Or TablePointer > 27 Then GoTo WW
DESCRIPTION$ = Mid$(TABLE$(OFFSET2 + TablePointer, 0, USEMENU), 1, 24)
If FKEY(page, 2) = 1 Then
If TablePointer = 10 Or TablePointer = 11 Or TablePointer = 12 Or TablePointer = 13 Then code = Val(TABLE$(OFFSET2 + TablePointer, 1, USEMENU))
End If
PRICETEMP = Val(TABLE$(OFFSET2 + TablePointer, 2, USEMENU))
If code = 0 Then PRICE = Val(TABLE$(OFFSET2 + TablePointer, 2, USEMENU))
If code = 1 Then PRICE = Val(TABLE$(OFFSET2 + TablePointer, 2, USEMENU))
If code = 2 Then PRICE = Val(TABLE$(OFFSET2 + TablePointer, 3, USEMENU))
If code = 3 Then PRICE = Val(TABLE$(OFFSET2 + TablePointer, 4, USEMENU))
If code = 4 Then PRICE = Val(TABLE$(OFFSET2 + TablePointer, 5, USEMENU))
If PRICE < 0 Then COUPCNT = COUPCNT + 1
If PRICE < 0 Then COUPON = COUPON + PRICE
If PRICETEMP <> 0 And PRICE = 0 Then PRICE = PRICETEMP
Call SCROLL(DESCRIPTION$(), PRICE(), LINES, updown, DESCRIPTION$, PRICE, OFFSET, line1)
Call ADDARRAY(RECEIPT$(), DESCRIPTION$, PRICE, line1)
GETTOTALS
PRINTTOTAL: row = 4: Color 0, 15: Call MENUS: Locate 2, 56: Color 4: Print MENULABEL$(pages)
If FKEY(pages, 1) = 1 Then
Exit Do
End If
Loop
Screen 0, 0, 0, 0: Call PRINTTOTAL
If liner <> LINES Then
Call SCROLL(DESCRIPTION$(), PRICE(), LINES, updown, DESCRIPTION$, PRICE, OFFSET, line1)
If FKEY(pages, 1) = 1 Then
Call Fkey_sub(pages)
End If
End If
End Sub
Sub Fkey_sub (pages)
If FKEY(pages, 1) = 1 Then USEMENU = 1
Color 12, 15
PCopy 0, 1
Screen 0, 0, 1, 1
Color 0, 15
page = pages
row = 4
OFFSET2 = pages * 18 - 27
Call MENUS
Color 4: Locate 2, 56: Print MENULABEL$(pages)
Do
WW: CHOOSE$ = "": While CHOOSE$ = "": CHOOSE$ = InKey$: Wend
TablePointer = Asc(UCase$(CHOOSE$)) - 55
If Asc(CHOOSE$) = 27 Then DESCRIPTION$ = "": Exit Do
If TablePointer < 10 Or TablePointer > 27 Then GoTo WW
DESCRIPTION$ = Mid$(TABLE$(OFFSET2 + TablePointer, 0, USEMENU), 1, 24)
PRICETEMP = Val(TABLE$(OFFSET2 + TablePointer, 2, USEMENU))
If code = 0 Then PRICE = Val(TABLE$(OFFSET2 + TablePointer, 2, USEMENU))
If code = 1 Then PRICE = Val(TABLE$(OFFSET2 + TablePointer, 2, USEMENU))
If code = 2 Then PRICE = Val(TABLE$(OFFSET2 + TablePointer, 3, USEMENU))
If code = 3 Then PRICE = Val(TABLE$(OFFSET2 + TablePointer, 4, USEMENU))
If code = 4 Then PRICE = Val(TABLE$(OFFSET2 + TablePointer, 5, USEMENU))
If PRICETEMP <> 0 And PRICE = 0 Then PRICE = PRICETEMP
Call SCROLL(DESCRIPTION$(), PRICE(), LINES, updown, DESCRIPTION$, PRICE, OFFSET, line1)
Call ADDARRAY(RECEIPT$(), DESCRIPTION$, PRICE, line1)
GETTOTALS
PRINTTOTAL: row = 4: Color 0, 15: Call MENUS: Locate 2, 56: Color 4: Print MENULABEL$(pages)
Exit Do
Loop
USEMENU = USEMENU - USEMENU
Screen 0, 0, 0, 0: Call PRINTTOTAL
If liner <> LINES Then
Call SCROLL(DESCRIPTION$(), PRICE(), LINES, updown, DESCRIPTION$, PRICE, OFFSET, line1)
End If
End Sub
' ***************************************************************************
' *** Displays Main Order Screen ***
' ***************************************************************************
Rem $STATIC
Sub MAIN ()
Screen 0, 0, 0, 0
View Print 1 To 25
If CsrLin = 25 And flag = 1 Then Locate 25, 1:
If CsrLin <> 25 Then Print Else flag = 1
font& = _LoadFont(fontpath$, 20, "MONOSPACE,BOLD")
_Font font&
Color 15, 1
Print "ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍËÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»"
Print "º LINE DESCRIPTION PRICE º º"
Print "ÌÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ͹ º"
Print "º º º"
Print "º º º"
Print "º ÌÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ͹"
Print "º º Special Instructions º"
Print "º ÌÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ͹"
Print "º º º"
Print "º º º"
Print "º º º"
Print "º º º"
Print "º º º"
Print "º º º"
Print "º º º"
Print "º ÌÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ͹"
Print "º º º"
Print "º º º"
Print "º º º"
Print "º º º"
Print "º º º"
Print "ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÊÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ"
Color 12, 1
Print "[R] = REMOVE ITEM - [ALT] + [F9] = Instructions - [ALT + F12] = Menu Options "
'PRINT " [TAB] Show Menus "
Locate 24, 37: Print " "
If LTrim$(NAME1$ + STREET1$ + CITY1$ + PHONE1$) = "" Then
Color 10, 6
Locate 2, 54: Print " "
Locate 3, 54: Print "PRESS [ALT + F8] TO ENTER"
Locate 4, 54: Print " CUSTOMER INFORMATION "
Locate 5, 54: Print " "
Else
Color 15, 1: P$ = "\ \" '' : ' <-There are 25 spaces between the back slashes
Locate 2, 53: Print Using P$; NAME1$
Locate 3, 53: Print Using P$; STREET1$
Locate 4, 53: Print Using P$; CITY1$
Call PHONES(mask$, PHONE1$, 1, 53, 5, 15, 1, Back$)
End If
Color 14, 1
PRINTTOTAL
Locate 17, 53: Print " Subtotal =====> "
Locate 18, 53: Print " Tax =====> "
Locate 19, 53: Print " Del Fee =====> "
Locate 20, 71: Print "ÄÄÄÄÄÄÄÄÄ"
Locate 21, 53: Print "Total Due =====> "
End Sub
' ***************************************************************************
' *** Displays the menus to the screen ***
' ***************************************************************************
Sub MENUS
Locate 1, 52: Print Chr$(201) + String$(27, Chr$(205)) + Chr$(187)
Locate 2, 52: Print Chr$(186) + Spc(27) + Chr$(186)
Locate 3, 52: Print Chr$(204) + String$(27, Chr$(205)) + Chr$(185)
For a = page * 18 - 17 To page * 18
DESCRIPTION$ = Mid$(TABLE$(a, 0, USEMENU), 1, 24)
M$ = Left$(TABLE$(a, 6, USEMENU), 2)
If RTrim$(M$) <> "" Then
Locate row, 52: Print Chr$(186) + Spc(27) + Chr$(186)
Locate row, 53: row = row + 1
Color 1,: Print M$ + " ";: Color 0,: Print DESCRIPTION$
End If
Next a
Locate row, 52: Print Chr$(200) + String$(27, Chr$(205)) + Chr$(188)
'END
End Sub
Rem $DYNAMIC
' ***************************************************************************
' *** Displays the Customer information screen ***
' ***************************************************************************
Sub CUSTINFO
Screen 0, 0, 4, 4
Color 15, 1: Cls: PCopy 0, 4
Locate 1, 41: Print "ËÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»"
Locate 2, 41: Print "º º"
Locate 3, 41: Print "ÎÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ͹"
Locate 4, 41: Print "º º"
Locate 5, 41: Print "º º"
Locate 6, 41: Print "º º"
Locate 7, 41: Print "º º"
Locate 8, 41: Print "ÇÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄĶ"
Locate 9, 41: Print "º º"
Locate 10, 41: Print "º º"
Locate 11, 41: Print "º º"
Locate 12, 41: Print "ÈÍÍÍÍÍÍÍÍÍÍËÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ͹"
Locate 2, 51: Color 10,: Print "Customer Information"
GoSub SHOWED
If _FileExists("PIZZA.CST") Then Call OPENER: Get 1, 1: LASTRECORD = CVL(LASTRECORD$): Close 1
GoSub SHOWED
Locate 9, 42: Color 2: Print "[F1] = SEARCH [F2] = GET [F3] = SAVE"
Locate 10, 42: Print " [F4] = CLEAR [ESC] = QUIT "
Color 15, 1
Locate 4, 42: Print "Name: "; NAME1$
Locate 5, 42: Print "Address: "; STREET1$
Locate 6, 42: Print "City: "; CITY1$
Locate 7, 42: Print "Phone: ";
Call PHONES(mask$, PHONE1$, 1, 48, 7, 15, 1, Back$)
Do
FCOLOR = 14: BCOLOR = 5: NUMB = 0
I:
77
T = 0: X = 48: Y = 7
Call PHONES(mask$, PHONE1$, T, X, Y, 14, 5, Back$)
GoSub FUNCTIONS
If T = 72 Then 66
T = 0
44 X = 48: Y = 4: LENGTHS = 27: NUMB = 0
Call INPUTS(X, Y, FCOLOR, BCOLOR, LENGTHS, NUMB, NAME1$, KEYPRESS, 1)
If KEYPRESS = 72 Then 77
GoSub FUNCTIONS
If KEYPRESS <> 13 And KEYPRESS <> 80 Then 44
55 X = 50: Y = 5: LENGTHS = 27: NUMB = 0
Call INPUTS(X, Y, FCOLOR, BCOLOR, LENGTHS, NUMB, STREET1$, KEYPRESS, 1)
If KEYPRESS = 72 Then 44
GoSub FUNCTIONS
If KEYPRESS <> 13 And KEYPRESS <> 80 Then 55
66 X = 48: Y = 6: LENGTHS = 27: NUMB = 0
Call INPUTS(X, Y, FCOLOR, BCOLOR, LENGTHS, NUMB, CITY1$, KEYPRESS, 1)
If KEYPRESS = 72 Then 55
GoSub FUNCTIONS
If KEYPRESS <> 13 And KEYPRESS <> 80 Then 66
GoTo I
FUNCTIONS:
If KEYPRESS = 27 Or T = 27 Then Exit Do
If KEYPRESS = 59 Or T = 59 Then
PCopy 4, 6
Call CHOICEBOX
Locate 15, 10: Print "START SEARCH FROM HERE OR BEGINNING"
Locate 16, 10: Print "[H] [B] [ESC] = QUIT"
If Y = 4 Then SEARCH$ = LTrim$(RTrim$(UCase$(NAME1$)))
If Y = 5 Then SEARCH$ = LTrim$(RTrim$(UCase$(STREET1$)))
If Y = 6 Then SEARCH$ = LTrim$(RTrim$(UCase$(CITY1$)))
If Y = 7 Then SEARCH$ = LTrim$(RTrim$(UCase$(PHONE1$)))
FOUND = 0
WW3: Close 1
A$ = "": While A$ = "": A$ = UCase$(InKey$): Wend
If Asc(A$) = 27 Then Close 1: GoSub CLEARS: Return
If A$ <> "H" And A$ <> "B" Then GoTo WW3
If A$ = "H" Then START = RECORDNUMBER + 1 Else START = 1
Call OPENER
For a = START To LASTRECORD
Call GETTER(a)
RECORDNUMBER = a: GoSub SHOWED
If Y = 4 Then B = InStr(NAME1$, SEARCH$): If B Then FOUND = a: Exit For
If Y = 5 Then B = InStr(STREET1$, SEARCH$): If B Then FOUND = a: Exit For
If Y = 6 Then B = InStr(CITY1$, SEARCH$): If B Then FOUND = a: Exit For
If Y = 7 Then B = InStr(PHONE1$, SEARCH$): If B Then FOUND = a: Exit For
Next
If FOUND = 0 Then
RECORDNUMBER = 0
NAME1$ = "": STREET1$ = "": CITY1$ = "": PHONE1$ = "": GoSub SHOWED
Else
Call GETTER(FOUND)
RECORDNUMBER = FOUND: GoSub SHOWED
End If
GoTo WW3
End If
If KEYPRESS = 60 Or T = 60 Then
PCopy 4, 6
Call CHOICEBOX
Locate 15, 10: Print "ENTER THE RECORD NUMBER YOU WANT OR"
Locate 16, 10: Print "[PG UP] [PG DN] [ESC] = QUIT"
Call OPENER: N$ = ""
WW1: Call INPUTS(40, 16, FCOLOR, BCOLOR, 5, 1, N$, KEYPRESS, 1)
If KEYPRESS = 27 Then Close 1: GoSub CLEARS: Return
If KEYPRESS = 73 And RECORDNUMBER > 1 Then
RECORDNUMBER = RECORDNUMBER - 1: Call GETTER(RECORDNUMBER)
GoSub SHOWED: GoTo WW1
End If
If KEYPRESS = 81 And RECORDNUMBER < LASTRECORD Then
RECORDNUMBER = RECORDNUMBER + 1: Call GETTER(RECORDNUMBER)
GoSub SHOWED: GoTo WW1
End If
If KEYPRESS = 13 Then
N = Val(N$)
If N > 0 And N < LASTRECORD + 1 Then
RECORDNUMBER = N: Call GETTER(RECORDNUMBER)
GoSub SHOWED: N$ = "": GoTo WW1
End If
End If
GoTo WW1
End If
If KEYPRESS = 61 Or T = 61 Then
If RECORDNUMBER <> 0 Then
Call CHOICEBOX
PCopy 4, 6
Locate 15, 10: Print "SAVE AS CURRENT RECORD OR LAST RECORD"
Locate 16, 10: Print "[C] [L] [ESC] = QUIT "
WW: A$ = "": While A$ = "": A$ = UCase$(InKey$): Wend
If A$ = Chr$(27) Then GoSub CLEARS: Return
If A$ = "C" Then
Call OPENER: Call PUTTER(RECORDNUMBER): Close 1: GoSub CLEARS: Return
End If
If A$ <> "L" Then GoTo WW
End If
Call OPENER: LASTRECORD = LASTRECORD + 1: RECORDNUMBER = LASTRECORD
Call PUTTER(RECORDNUMBER): LSet LASTRECORD$ = MKL$(RECORDNUMBER): Put 1, 1
Close 1: GoSub CLEARS: GoSub SHOWED: Return
End If
If KEYPRESS = 62 Or T = 62 Then
RECORDNUMBER = 0
NAME1$ = "": STREET1$ = "": CITY1$ = "": PHONE1$ = "": GoSub SHOWED
End If
Return
CLEARS: For a = 18 To 19: Locate a, 5: Print Space$(40);: Next: Return
SHOWED: P$ = "\ \"
Locate 11, 42: Print "RECORD NUMBER: ";: Print Using "#####"; RECORDNUMBER;
Locate 4, 48: Print Using P$; NAME1$
Locate 5, 50: Print Using P$; STREET1$
Locate 6, 48: Print Using P$; CITY1$
Call PHONES(mask$, PHONE1$, 1, 48, 7, 15, 1, Back$)
Return
Loop
Screen 0, 0, 0, 0: Cls
Call MAIN
For a = 2 To 5: Locate a, 54: Print Space$(25): Next
Locate 2, 53: Print NAME1$
Locate 3, 53: Print STREET1$
Locate 4, 53: Print CITY1$
Locate 5, 53: Print Back$
Call SCROLL(DESCRIPTION$(), PRICE(), LINES, UPDOWN, DESCRIPTION$, PRICE, OFFSET, line1)
End Sub
' ***************************************************************************
' *** Retreve Customer information Record ***
' ***************************************************************************
Sub GETTER (RECORDNUMBER)
Get 1, RECORDNUMBER + 1
NAME1$ = NAME$: STREET1$ = STREET$: CITY1$ = CITY$: PHONE1$ = PHONE2$
End Sub
' ***************************************************************************
' *** Dale Harris' INPUTS SUB ***
' ***************************************************************************
Sub INPUTS (X, Y, FCOLOR, BCOLOR, LENGTHS, NUMB, INPUTER$, KEYPRESS, CAPS)
SC = Screen(Y, X, 1): FFCOLOR = Int(SC / 16): BBCOLOR = SC Mod 16: 'CURRENT COLOR
P = 1: INPUTER$ = Left$(INPUTER$ + Space$(LENGTHS), LENGTHS): GoSub SHOW
II: A$ = "": While A$ = "": A$ = InKey$: Wend: If CAPS Then A$ = UCase$(A$)
If Len(A$) = 1 Then
a = Asc(A$)
If NUMB And ((a > 31 And a < 48) Or a > 57) Then
If a > 31 Then GoTo II Else GoTo III
End If
If a > 31 And P <= LENGTHS Then
If INSERTS Then
INPUTER$ = Left$(Left$(INPUTER$, P - 1) + A$ + Mid$(INPUTER$, P, LENGTHS), LENGTHS)
P = P + 1: GoSub SHOW: GoTo II
Else
Mid$(INPUTER$, P, 1) = A$
P = P + 1: GoSub SHOW: GoTo II
End If
Else
If a > 31 And P <= LENGTHS Then
Mid$(INPUTER$, P, 1) = A$: P = P + 1
GoSub SHOW: GoTo II
Else
III: If a = 27 Or a = 13 Then GoTo LEAVE: '[ESC] [ENTER]
'[BACKSPACE]
If a = 8 And P > 1 Then
INPUTER$ = Left$(Left$(INPUTER$, P - 2) + Mid$(INPUTER$, P, LENGTHS) + " ", LENGTHS)
P = P - 1: GoSub SHOW
End If
End If
End If
End If
a = Asc(Right$(A$, 1))
If a = 71 Then P = 1: GoSub SHOW: '[HOME]
If a = 75 And P > 1 Then P = P - 1: GoSub SHOW: '[LEFT]
If a = 77 And P < LENGTHS Then P = P + 1: GoSub SHOW: '[RIGHT]
If a = 79 Then P = Len(RTrim$(INPUTER$)): GoSub SHOW: '[END]
If a = 82 Then INSERTS = Abs(INSERTS - 1): '[INSERT]
If a = 83 Then
'[DELETE]
INPUTER$ = Left$(Left$(INPUTER$, P - 1) + Mid$(INPUTER$, P + 1, LENGTHS) + " ", LENGTHS)
GoSub SHOW
End If
If a > 58 And a < 69 Then GoTo LEAVE: '[F?]
If a = 73 Or a = 81 Then GoTo LEAVE: '[PG UP] [PG DN]
If a = 72 Or a = 80 Then GoTo LEAVE: '[PG UP] [PG DN]
GoTo II
SHOW: If P < 1 Then P = 1
Color FCOLOR, BCOLOR
Locate Y, X: Print INPUTER$: Locate Y, X + P - 1
Return
LEAVE: KEYPRESS = a: CAPS = 0
Color BBCOLOR, FFCOLOR: Locate Y, X: Print INPUTER$
INPUTER$ = RTrim$(INPUTER$)
End Sub
' ***************************************************************************
' *** Opens The customer Database ***
' ***************************************************************************
Sub OPENER
Open "R", 1, "PIZZA.CST", 120
Field #1, 27 As NAME$, 27 As STREET$, 27 As CITY$, 15 As PHONE2$
Field #1, 4 As LASTRECORD$
End Sub
' ***************************************************************************
' *** Phone Sub Mask - Dale Harris ***
' ***************************************************************************
Sub PHONES (MASK$, PHONE$, T, X, Y, FCOLOR, BCOLOR, BACK$)
'T = 0=INPUT 1=DISPLAY ONLY 2=SEND BACK$ ONLY
SC = Screen(Y, X, 1): FFCOLOR = Int(SC / 16): BBCOLOR = SC Mod 16: 'CURRENT COLOR
MASK$ = "(###) ###-#### ex.#####": TT = T
For a = 1 To Len(MASK$): If Mid$(MASK$, a, 1) = "#" Then B = B + 1
Next: BW = 1
If BW Then Color FCOLOR, BCOLOR Else Color 0, 7
PHONE$ = Left$(PHONE$ + Space$(B), B): Locate , , 1, 7, 9
C = 1: GoSub DISPLAY: If T Then T = 0: GoTo ENDER
19 T# = Timer: A$ = ""
While A$ = "": A$ = InKey$: Wend
If Len(A$) = 2 Then E = Asc(Right$(A$, 1)) Else E = 0
If A$ = Chr$(27) Then T = 27: Locate , , , 7, 8: GoTo ENDER
If A$ = Chr$(9) Then T = 9: Locate , , , 8, 8: GoTo ENDER
If A$ = Chr$(13) Or E = 80 Then T = 80: Locate , , , 8, 8: GoTo ENDER
If E > 58 And E < 68 Then T = E:: Locate , , , 7, 8: GoTo ENDER
If E = 72 Then T = 72: Locate , , , 7, 8: GoTo ENDER
If E = 75 And C > 1 Then C = C - 1: INS = 0: Locate , , , 7, 8
If E = 77 And C < B Then C = C + 1: INS = 0: Locate , , , 7, 8
If E = 82 Then INS = Abs(INS - 1): If INS Then Locate , , , 5, 8 Else Locate , , , 7, 9
If E = 83 Then PHONE$ = Left$(PHONE$, C - 1) + Mid$(PHONE$, C + 1, B) + " "
If Asc(A$) = 8 And C > 1 Then PHONE$ = Left$(PHONE$, C - 2) + Mid$(PHONE$, C, B) + " ": C = C - 1
If E = 71 Then C = 1
If E = 79 Then
For C = B To 1 Step -1: If Mid$(PHONE$, C, 1) <> " " Then Exit For
Next: C = C + 1: If C > B Then C = B
End If
If InStr(" 0123456789", A$) Then
If INS Then
PHONE$ = Left$(Left$(PHONE$, C - 1) + A$ + Mid$(PHONE$, C, 50), B): C = C + 1
Else
Mid$(PHONE$, C, 1) = A$: C = C + 1: If C > B Then C = B
End If
End If
GoSub DISPLAY
GoTo 19
DISPLAY: BACK$ = ""
If T < 2 Then Locate Y, X
P = 0: PP = 1: P1 = 0
MASK$ = "(###) ###-#### ex.#####"
For a = 1 To Len(MASK$)
If Mid$(MASK$, a, 1) = "#" Then
P = P + 1: P1 = P1 + 1
If P <= Len(PHONE$) Then
BACK$ = BACK$ + Mid$(PHONE$, P, 1)
Else
BACK$ = BACK$ + " "
End If
Else
BACK$ = BACK$ + Mid$(MASK$, a, 1)
End If
If P1 < C Then PP = PP + 1
Next
If T < 2 Then Locate Y, X: Print BACK$;: Locate Y, X + PP - 1
Return
ENDER:
If TT <> 2 Then Color BBCOLOR, FFCOLOR: Locate Y, X: Print BACK$
End Sub
' ***************************************************************************
' *** Put Customer information into Database ***
' ***************************************************************************
Sub PUTTER (RECORDNUMBER)
LSet NAME$ = NAME1$: LSet STREET$ = STREET1$:
LSet CITY$ = CITY1$: LSet PHONE2$ = PHONE1$
Put 1, RECORDNUMBER + 1
End Sub
' ***************************************************************************
' *** Print totals to the order screen ***
' ***************************************************************************
Rem $STATIC
Sub PRINTTOTAL
Color 14, 1
Locate 17, 71: Print Using PP$; subtotal / 100
Locate 18, 71: Print Using PP$; tax / 100
Locate 19, 71: Print Using PP$; del / 100
Locate 21, 71: Print Using PP$; total / 100
End Sub
' ***************************************************************************
' *** Scroll the lines on the order screen ***
' ***************************************************************************
Rem $DYNAMIC
Sub SCROLL (DESCRIPTION$(), PRICE(), LINES, UPDOWN, DESCRIPTION$, PRICE, OFFSET, line1)
Color 15, 1
5 X = 2: Y = 3: 'UPPER LEFT CORNER OF SCROLL BOX
PRINTSTRING$ = "#### \ \ ####.## ": WIDTHS = Len(PRINTSTRING$)
printstring2$ = "#### \ \" + " ": WIDTHS = Len(printstring2$)
'THE WITH OF PRINTSTRING$ SETS THE WIDTH OF THE SCROLL BOX
HEIGHT = 18: 'NUMBER OF LINES IN THE SCROLL BOX
'LINES IS THE NUMBER OF THE BOTTOM LINE TO RECEIVE DATA IN THE SCROLL BOX
'OFFSET IS THE NUMER OF LINES BETWEEN THE BOTTOM LINE DISPLAYED AND "LINES"
'UPDOWN = EITHER +1 OR -1 TO MOVE THE TEXT EITHER UP OR DOWN 0 = NO MOVE
'DESCRIPTION$ IS THE NEW DESCRIPTION YOU WANT TO SEND TO THE SCROLL BOX
'PRICE IS THE NEW PRICE YOU WANT TO SEND TO THE SCROLL BOX
'DESCRIPTION$() HOLDS THE DESCRIPTIONS AND MUST BE RESET FOR A NEW SALE
'PRICE() HOLDS THE PRICES AND MUST BE RESET FOR A NEW SALE
If UPDOWN = 10 Then
ReDim PRICE$(1100), DESCRIPTION$(1100)
LINES = 0: UPDOWN = 0: DESCRIPTION$ = "": PRICE = 0: OFFSET = 0
End If
If RTrim$(DESCRIPTION$) <> "" Then
LINES = LINES + 1: DESCRIPTION$(LINES) = DESCRIPTION$: PRICE(LINES) = PRICE
End If
If UPDOWN <> 0 Then
OFFSET = OFFSET + UPDOWN * -1
If OFFSET = LINES * -1 Then OFFSET = OFFSET + 1
If OFFSET > 0 Then OFFSET = 0
End If
For a = 0 To HEIGHT - 1
B = a - HEIGHT + LINES + 1 + OFFSET
Locate a + Y + 1, X
If B < 1 Then
Print Spc(WIDTHS);
Else
If PRICE(B) = 0 Then
Print Using printstring2$; B; DESCRIPTION$(B);
Else
Print Using PRINTSTRING$; B; DESCRIPTION$(B); PRICE(B) / 100;
End If
End If
Next
End Sub
Sub PICKUP_DEL
Color 12, 15
PCopy 0, 1
Screen 0, 0, 1, 1
Color 0, 15
Locate 1, 52: Print Chr$(201) + String$(27, Chr$(205)) + Chr$(187)
Locate 2, 52: Print Chr$(186) + Spc(27) + Chr$(186)
Locate 3, 52: Print Chr$(204) + String$(27, Chr$(205)) + Chr$(185)
row = 4
'CALL MENUS
liner = LINES
Color 4: Locate 2, 56: Print " PRINT CHECK"
Color 12, 15: Color 0, 15
For linespace = 4 To 7
Locate linespace, 52: Print Chr$(186) + Spc(27) + Chr$(186)
Next linespace
Color 1, 15
Locate 4, 53: Print "A)"
Locate 5, 53: Print "B)"
Locate 6, 53: Print "C)"
Locate 7, 53: Print "D)"
Color 12, 15: Color 0, 15
Locate 4, 56: Print "PICK UP"
Locate 5, 56: Print "CARRY OUT"
Locate 6, 56: Print "DELIVERY"
Locate 7, 56: Print "OPEN TILL - NS"
Locate 8, 52: Print Chr$(200) + String$(27, Chr$(205)) + Chr$(188)
WERT: Do
choose$ = "": While choose$ = "": choose$ = UCase$(InKey$): Wend:
If Asc(choose$) = 27 Then Exit Do: Exit Sub
Select Case choose$
Case "A"
typer$ = " PICK UP "
Call PRINTRECEIPT(RECEIPT$(), DESCRIPTION$, PRICE, line1)
Case "B"
typer$ = "CARRY OUT"
Call PRINTRECEIPT(RECEIPT$(), DESCRIPTION$, PRICE, line1)
Case "C"
DESCRIPTION$ = ""
typer$ = "DELIVERY"
DELCNT = 1
Call ADDARRAY(RECEIPT$(), DESCRIPTION$, PRICE, line1)
Call SCROLL(DESCRIPTION$(), PRICE(), LINES, updown, DESCRIPTION$, PRICE, OFFSET, line1)
GETTOTALS
Call PRINTRECEIPT(RECEIPT$(), DESCRIPTION$, PRICE, line1)
Case Chr$(68), Chr$(100)
Open "lpt1" For Output As 2
Print #2, opencode$;
Close 2
Sound 696, 20
Exit Do
Case Else
GoTo WERT
End Select
Loop
Screen 0, 0, 0, 0
If liner = LINES Then DESCRIPTION$ = ""
Call SCROLL(DESCRIPTION$(), PRICE(), LINES, updown, DESCRIPTION$, PRICE, OFFSET, line1)
End Sub
Sub CHECKFORFILE
If Not _FileExists("checknofile\CHKNO.NO") Then FLAG = 1
Open "checknofile\CHKNO.NO" For Random As #3 Len = 1000
Field #3, 1000 As A$
If FLAG = 1 Then LSet A$ = String$(1000, ""): Put 3, 1
Close #3
End Sub
Sub RINGSALE
Screen 0, 0, 2, 2: BK = 0
Color 15, 1: Cls
'******************************************************************************************************************************
' THIS SECTION WAS ADDED TO KEEP FROM CREATING A BLANK CHKNO.NO FILE
'******************************************************************************************************************************
Call CHECKFORFILE
'******************************************************************************************************************************
' END ADDED SECTION
'******************************************************************************************************************************
Call CHECKOUT
FCOLOR = 14: BCOLOR = 5: DECIMAL$ = "000.00": X = 30: Y = 8
NUMBER = 0
Locate 13, 53: Print " Subtotal =====> "
Locate 14, 53: Print " Tax =====> "
Locate 15, 53: Print " Del Fee =====> "
Locate 16, 71: Print "ÄÄÄÄÄÄÄÄÄ"
Locate 17, 53: Print "Total Due =====> "
Color 1, 15
Call GETTER2(NAME1$, STREET1$, CITY1$, Back$, total$, tax$, subtotal$, Desc$, price$, CN, booboo, COUPON$)
If Styper$ = "D" Then DELCNT = 1 Else DELCNT = 0
If booboo = 1 Then booboo = 0: GoTo 78
For a = 2 To 5: Locate a, 54: Print Space$(25): Next
Locate 2, 53: Print NAME1$
Locate 3, 53: Print STREET1$
Locate 4, 53: Print CITY1$
Locate 5, 53: Print Back$
Locate 19, 53: Print " "
Locate 19, 53: Print "Amt Tendered: "
redo: Call NUMBERS(67, 19, FCOLOR, BCOLOR, DECIMAL$, NUMBER, KEYPRESS)
If KEYPRESS = 27 Then
Open "checknofile\CHKNO.NO" For Random As #3 Len = 1000
Field #3, 1000 As A$
Get 3, 1: B$ = A$: Mid$(B$, CN, 1) = "A": LSet A$ = B$: Put 3, 1: Close 3
GoTo 78
End If
If KEYPRESS = 59 Then
For a = 1 To LINES
DESCRIPTION$(a) = RECEIPT$(a, 1): PRICE(a) = Val(RECEIPT$(a, 2))
Next
If del <> 0 Then total = total - del: del = 0 '<== Deletes the Delivery Charge, if still a delivery when Choosen will add the del back on
Open "checknofile\CHKNO.NO" For Random As #3 Len = 1000
Field #3, 1000 As A$
Get 3, 1: B$ = A$: Mid$(B$, CN, 1) = "A": LSet A$ = B$: Put 3, 1: Close 3
BK = CN: BK1 = 1: F1 = 1
Exit Sub
End If
IF NUMBER < total THEN sound 554,20 : LOCATE 21, 53: COLOR 26,: _
PRINT "Tender less then Total Due": COLOR 15 ,: LOCATE 22,53: PRINT "RE-ENTER AMOUNT TENDERED": _
NUMBER = .00:SLEEP: LOCATE 21,53: PRINT " ": _
LOCATE 22,53: PRINT "ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ": GOTO redo
If NUMBER = 0 Then
chgdue = 0
Else
chgdue = NUMBER - total
End If
Locate 21, 53: Print " "
Locate 21, 53: Print " Change Due: ";
TOTALSALESCNT = 1
'CALL BIG(chgdue)
Locate 21, 67: Print Using PP$; chgdue / 100
Color 15, 3
Locate 14, 3: Print "ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»"
Locate 15, 3: Print "º º"
Locate 16, 3: Print "ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ"
Locate 15, 3: Print Chr$(186) + Space$(23 - Len("PRESS ANY KEY TO RETURN TO MAIN SCREEN") / 2); "PRESS ANY KEY TO RETURN TO MAIN SCREEN"
Beep
Open "lpt1" For Output As 2
Print #2, opencode$;
Close 2
Color 15, 1
Open "checknofile\CHKNO.NO" For Random As #3 Len = 1000
Field #3, 1000 As A$
Get 3, 1: B$ = A$
Mid$(B$, CN, 1) = "B"
LSet A$ = B$
Put 3, 1
Close 3
CHKNO$ = LTrim$(Str$(CN)) + ".TRN"
Call SAVE_ZREPORT
Call SAVE_XREPORT
Sleep
78 subtotal = 0
NAME1$ = ""
STREET1$ = ""
CITY1$ = ""
PHONE1$ = ""
tax = 0
COUPCNT = 0
TOTALSALESCNT = 0
total = 0
del = 0
COUPON = 0
LINES = 0
line1 = 0
Call PRINTTOTAL
End Sub
Sub SAVER (name1$, street1$, City1$, back$, total$, tax$, subtotal$, Desc$, price$)
If BK = 0 Then
Call CHECKFORFILE
Open "checknofile\CHKNO.NO" For Random As #3 Len = 1000
Field #3, 1000 As A$
Get 3, 1: B$ = A$
'''FOR A = 1 TO 50: PRINT ASC(MID$(B$, A, 1));: NEXT
For a = 1 To 1000
N = Asc(Mid$(B$, a, 1))
If N <> 65 And N <> 66 And N <> 86 Then Mid$(B$, a, 1) = "A": Exit For
Next
LSet A$ = B$
Put 3, 1
Close 3
chkno = a
Else
chkno = BK: BK = 0
End If
If Not _DirExists("checknofile") Then
Shell _Hide ("mkdir checknofile")
End If
CHKNO$ = "checknofile\" + LTrim$(Str$(chkno)) + ".TRN"
Open CHKNO$ For Random As #3 Len = 80
Field #3, 80 As A$
FIELD #3, 4 AS subtotal$, 4 AS tax$, 4 AS DEL$, 4 AS total$, 4 AS LINE1$, 1 AS SALESTYPE$, 4 AS COUPON$, 2 AS COUPCNT$, 4 AS XVOIDCOUPDOLLARS$, _
2 as TOTALSALESCNT$, 8 as ORDERTIME$
LSet subtotal$ = MKL$(subtotal): LSet tax$ = MKL$(tax): LSet COUPON$ = MKL$(COUPON): LSet COUPCNT$ = MKI$(COUPCNT)
LSet XVOIDCOUPDOLLARS$ = MKL$(VOIDCOUPDOLLARS): LSet TOTALSALESCNT$ = MKI$(TOTALSALESCNT)
LSet DEL$ = MKL$(del): LSet total$ = MKL$(total): LSet LINE1$ = MKL$(line1): LSet SALESTYPE$ = LTrim$(typer$): RSet ORDERTIME$ = Right$(CLOCK$, 7)
Put 3, 1
LSet A$ = name1$: Put 3, 2
LSet A$ = street1$: Put 3, 3
LSet A$ = City1$: Put 3, 4
LSet A$ = back$: Put 3, 5
Field #3, 30 As Desc$, 10 As price$
For a = 1 To line1
LSet Desc$ = RECEIPT$(a, 1): LSet price$ = RECEIPT$(a, 2)
Put 3, a + 5
Next a
For a = 1 To 7: LSet A$ = INSTRUCT$(a): Put 3: Next a
Close 3
End Sub
Sub CHKSTATUS
Screen 0, 0, 22, 22
Color 15, 1: Cls
Locate 7, 25: Print "Choose Option to display...": Print
Locate 10, 30: Print "1. Open sales"
Locate 11, 30: Print "2. Completed sales"
Locate 12, 30: Print "3. Voided sales"
Locate 13, 30: Print "4. All sales"
Locate 14, 30: Print "5. Quit"
1 A$ = "": While A$ = "": A$ = InKey$: Wend
P = Val(A$): If P = 5 Then Exit Sub
If P = 0 Or P > 4 Then GoTo 1
If Not _FileExists("checknofile\CHKNO.NO") Then FLAG = 1
Open "checknofile\CHKNO.NO" For Random As #3 Len = 1000
Field #3, 1000 As A$
If FLAG = 1 Then LSet A$ = String$(1000, ""): Put 3, 1
Close #3
Open "checknofile\CHKNO.NO" For Random As #3 Len = 1000
Field #3, 1000 As A$
Get 3, 1: B$ = A$: Close 3
If _FileExists("OPENSCRL.DAT") Then Close #4: Kill "OPENSCRL.DAT"
Open "OPENSCRL.DAT" For Random As #4 Len = 80
Field #4, 80 As RECORD$
Field #4, 8 As TIMEORDER$, 1 As NULL$, 4 As COUNT$, 4 As NULL$, 28 As NAMER$, 25 As phone$, 5 As OPEN$
For A = 1 To 1000
If Mid$(B$, A, 1) = Chr$(15) Then Exit For
CK$ = Mid$(B$, A, 1)
If (P = 1 And CK$ = "A") Or (P = 2 And CK$ = "B") Or (P = 3 And CK$ = "V") Or P = 4 Then
CHKNO$ = LTrim$(Str$(A)) + ".TRN"
counter = counter + 1
Open "checknofile\" + CHKNO$ For Random As #3 Len = 80
Field #3, 80 As A$
FIELD #3, 4 AS subtotal$, 4 AS tax$, 4 AS DEL$, 4 AS total$, 4 AS LINE1$, 1 AS SALESTYPE$, 4 AS COUPON$, 2 AS COUPCNT$, 4 AS XVOIDCOUPDOLLARS$, _
2 as TOTALSALESCNT$, 8 as ORDERTIME$
Get #3, 1: LSet TIMEORDER$ = ORDERTIME$
Get 3, 2: NAME1$ = RTrim$(A$)
Get 3, 5: Back$ = RTrim$(A$)
NAME2$ = NAME1$
BACK1$ = Back$
Close #3
STATUS$ = "OPEN": If CK$ = "B" Then STATUS$ = "CLSD" Else If CK$ = "V" Then STATUS$ = "VOID"
RSet COUNT$ = LTrim$(RTrim$(Str$(A))): LSet NAMER$ = NAME1$: LSet phone$ = Back$: LSet OPEN$ = STATUS$
Print RECORD$
Put 4
End If
Next
Close
Open "OPENSCRL.DAT" For Random As #4 Len = 80
Field #4, 8 As TIMEORDER$, 1 As NULL$, 4 As COUNT$, 4 As NULL$, 28 As NAMER$, 25 As phone$, 5 As OPEN$
Field #4, 80 As RECORD$
RC = LOF(4) \ 80
Print RC
Color 15, 1:
Cls
Locate 4, 5: Print "Time In CHK # Customer Phone Status "
Locate 5, 4: Print "--------------------------------------------------------------------------"
5 X = 4: Y = 5: 'UPPER LEFT CORNER OF SCROLL BOX
WIDTHS = 74: ' WIDTH OF SCROLL BOX
HEIGHT = 18: 'NUMBER OF LINES IN THE SCROLL BOX
'LINES IS THE NUMBER OF THE BOTTOM LINE TO RECEIVE DATA IN THE SCROLL BOX
'OFFSET IS THE NUMER OF LINES BETWEEN THE BOTTOM LINE DISPLAYED AND "LINES"
OFFSET = 0
LINE6 = 1
6
For A = 0 To HEIGHT - 1
B = A + LINE6 + OFFSET
Locate A + Y + 1, X
Color 15, 1: If B = LINE6 Then Color 15, 3: TRN = Val(COUNT$)
If LINE6 < 0 Or LINE6 = 0 Then
Else
Get 4, B: Print Left$(RECORD$, WIDTHS);
Locate 1, 70: Print "LINE #"; Using "###"; LINE6
End If
Next
7 A$ = "": While A$ = "": A$ = InKey$: Wend
IN = Asc(A$):
If Len(A$) = 2 Then IN2 = Asc(Right$(A$, 1)) Else IN2 = 0
If IN2 = 72 Then
LINE6 = LINE6 - 1: If LINE6 = 0 Then LINE6 = 1
GoTo 6
End If
If IN2 = 80 Then
LINE6 = LINE6 + 1: If LINE6 > RC Then LINE6 = RC
GoTo 6
End If
If IN2 = 73 Then
LINE6 = LINE6 - HEIGHT: If LINE6 < 1 Then LINE6 = 1
GoTo 6
End If
If IN2 = 81 Then
LINE6 = LINE6 + HEIGHT: If LINE6 > RC Then LINE6 = RC
GoTo 6
End If
If IN2 = 71 Then
LINE6 = 1
GoTo 6
End If
If IN2 = 79 Then
LINE6 = RC
GoTo 6
End If
If IN = 27 Then Exit Sub
If IN = 13 Then Get 4, LINE6: TRN = Val(COUNT$): Locate 24, 1: Print TRN: Exit Sub
GoTo 7
End Sub
Sub GETTER2 (name1$, street1$, City1$, back$, total$, tax$, subtotal$, Desc$, price$, CN, booboo, COUPON$)
Color 15, 1
Locate 10, 53: Input "CHECK NUMBER"; CN
chkno = CN
CHKNO$ = "checknofile\" + LTrim$(Str$(chkno)) + ".TRN"
'CHKNO$ = LTRIM$(STR$(chkno)) + ".TRN"
If Not _FileExists(CHKNO$) Then
Color 15, 1
Locate 10: Print Space$(25 - Len("SORRY, I COULD NOT FIND A CHECK NUMBER " + CHKNO$) / 2); " I COULD NOT FIND A CHECK NUMBER " + CHKNO$
Locate 11: Print Space$(25 - Len("CHECK ALREADY PAID or CHECK DOES NOT EXIST") / 2); " CHECK PAID or CHECK DOESN'T EXIST"
Locate 15: Print Space$(25 - Len("PRESS ANY KEY TO CONTINUE") / 2); " PRESS ANY KEY TO CONTINUE"
Color 15, 1
Locate 10, 1: Print Chr$(186)
Locate 11, 1: Print Chr$(186)
Locate 15, 1: Print Chr$(186)
Sleep
booboo = 1: Exit Sub
End If
Open "checknofile\CHKNO.NO" For Random As #3 Len = 1000
Field #3, 1000 As A$
Get 3, 1: B$ = A$: Close 3
'''FOR A = 1 TO 50: PRINT ASC(MID$(B$, A, 1));: NEXT
If Mid$(B$, CN, 1) <> "A" Then
Color 15, 1
Locate 10: Print Space$(25 - Len("SORRY, I COULD NOT FIND A CHECK NUMBER " + CHKNO$) / 2); " I COULD NOT FIND A CHECK NUMBER " + CHKNO$
Locate 11: Print Space$(25 - Len("CHECK ALREADY PAID or CHECK DOES NOT EXIST") / 2); " CHECK PAID or CHECK DOESN'T EXIST"
Locate 15: Print Space$(25 - Len("PRESS ANY KEY TO CONTINUE") / 2); " PRESS ANY KEY TO CONTINUE"
Color 15, 1
Locate 10, 1: Print Chr$(186)
Locate 11, 1: Print Chr$(186)
Locate 15, 1: Print Chr$(186)
Sleep
booboo = 1: Exit Sub
End If
Open CHKNO$ For Random As #3 Len = 80
Field #3, 80 As A$
FIELD #3, 4 AS subtotal$, 4 AS tax$, 4 AS DEL$, 4 AS total$, 4 AS LINE1$, 1 AS SALESTYPE$, 4 AS COUPON$, 2 AS COUPCNT$, 4 AS VOIDCOUPDOLLARS$, _
2 as TOTALSALESCNT$
Get 3, 1
subtotal = CVL(subtotal$): tax = CVL(tax$): VOIDCOUPDOLLARS = CVL(VOIDCOUPDOLLARS$): TOTALSALESCNT = CVI(TOTALSALESCNT$)
del = CVL(DEL$): total = CVL(total$): line1 = CVL(LINE1$): COUPON = CVL(COUPON$): COUPCNT = CVI(COUPCNT$): Styper$ = SALESTYPE$
Get 3, 2: name1$ = RTrim$(A$)
Get 3, 3: street1$ = RTrim$(A$)
Get 3, 4: City1$ = RTrim$(A$)
Get 3, 5: back$ = RTrim$(A$)
Field #3, 30 As Desc$, 10 As price$
For a = 1 To line1
Get 3, a + 5
RECEIPT$(a, 1) = RTrim$(Desc$): RECEIPT$(a, 2) = RTrim$(price$)
Next a
For a = 1 To 7
Get 3
INSTRUCT$(a) = Left$(A$, 27)
88 I = InStr(INSTRUCT$(a), Chr$(0))
If I Then Mid$(INSTRUCT$(a), I, 1) = " ": GoTo 88
Next
Close 3
LINES = line1: GoSub SCROLLER
PP$ = "###.##"
Locate 13, 72: Print Using PP$; subtotal / 100
Locate 14, 72: Print Using PP$; tax / 100
Locate 15, 72: Print Using PP$; del / 100
Locate 17, 72: Print Using PP$; total / 100
LINES = line1: GoSub SCROLLER
If Len(A$) = 2 Then
a = Asc(Right$(A$, 1))
If a = 72 Then UPDOWN = -1: GoSub SCROLLER
If a = 80 Then UPDOWN = 1: GoSub SCROLLER
End If
Exit Sub
SCROLLER:
PRINTSTRING$ = "#### \ \ ####.## ": WIDTHS = Len(PRINTSTRING$)
printstring2$ = "#### \ \" + " ": WIDTHS = Len(printstring2$)
X = 2: Y = 3: HEIGHT = 18
If UPDOWN <> 0 Then
OFFSET = OFFSET + UPDOWN * -1
If OFFSET = LINES * -1 Then OFFSET = OFFSET + 1
If OFFSET > 0 Then OFFSET = 0
End If
For a = 0 To HEIGHT - 1
B = a - HEIGHT + LINES + 1 + OFFSET
Locate a + Y + 1, X
If B < 1 Then
Print Spc(WIDTHS);
Else
If Val(RECEIPT$(B, 2)) = 0 Then
Print Using printstring2$; B; RECEIPT$(B, 1);
Else
Print Using PRINTSTRING$; B; RECEIPT$(B, 1); Val(RECEIPT$(B, 2)) / 100;
End If
End If
Next
Return
End Sub
Sub PRINTHEAD (HF)
'FOR B = 0 TO 1: FOR a = 1 TO 8:
' GET 1, a + B * 8 + 721: HEADER$(B, a) = LEFT$(A$, 39):
'next a,b
ReDim HEAD$(2, 8)
Open "R", 10, "PITABLE.DB", 60
Field #10, 39 As A$
For B = 1 To 2
For a = 1 To 8
Get 10, a + (B - 1) * 8 + 741: H$ = A$
888 Q = InStr(H$, Chr$(0)): If Q Then Mid$(H$, Q, 1) = " ": GoTo 888 Else H$ = LTrim$(RTrim$(H$))
HEAD$(B, a) = Space$(19 - Len(H$) / 2) + H$
Next a
Next B
Close #10
For a = 8 To 1 Step -1
If RTrim$(HEAD$(HF, a)) <> "" Then Exit For
Next a
For B = 1 To a
26 NULL = InStr(HEAD$(HF, B), Chr$(0)): If NULL Then Mid$(HEAD$(HF, B), NULL, 1) = " ": GoTo 26
Print #2, RTrim$(HEAD$(HF, B))
Next B
Print #2, Chr$(29)
End Sub
Sub PRINTRECEIPT (RECEIPT$(), DESCRIPTION$, PRICE, line1)
Call SAVER(NAME1$, STREET1$, CITY1$, Back$, total$, tax$, subtotal$, Desc$, price$)
If useprinter = 1 Then Open "LPT1" For Output As #2
If useprinter = 2 Then Open "wlsdfkjn.dry" For Output As #2
If BK1 = 1 Then
REPRINT1$ = "*********************************"
REPRINT2$ = "*** REPRINT REPRINT REPRINT ***"
Print #2, Space$(20 - Len(REPRINT1$) / 2); REPRINT1$
Print #2, Space$(20 - Len(REPRINT2$) / 2); REPRINT2$
Print #2, Space$(20 - Len(REPRINT1$) / 2); REPRINT1$
For i = 1 To 2
Print #2, ""
Next i
BK1 = 0
End If
Call PRINTHEAD(1)
lined$ = "________________________________________"
Print #2, Space$(20 - Len(lined$) / 2); lined$
dateline$ = Date$ + Spc(9) + CLOCK$
Print #2, ""
Print #2, Space$(20 - Len(dateline$) / 2); dateline$
Print #2, ""
Print #2, Space$(20 - Len(DELCLOCK$) / 2); DELCLOCK$
Print #2, Space$(20 - Len(lined$) / 2); lined$
Print #2, ""
Print #2, NAME1$
Print #2, STREET1$
Print #2, CITY1$
Print #2, Back$
Print #2, Space$(20 - Len(lined$) / 2); lined$
Print #2, ""
Star$ = String$(40, "-")
Print #2, Chr$(29)
Print #2, Chr$(31); Space$(10 - Len(typer$) / 2); typer$
Print #2, Chr$(29)
Print #2, Space$(20 - Len(Star$) / 2); Star$
Print #2, ""
Print #2, ""
PP$ = "##,###.##"
PR$ = "\ \##,###.##"
For count = 1 To line1
If Val(RECEIPT$(count, 2)) = 0.00 Then
Print #2, RECEIPT$(count, 1)
Else
Print #2, Using PR$; RECEIPT$(count, 1); Val(RECEIPT$(count, 2)) / 100
End If
Next count
If typer$ = " PICK UP " Or typer$ = "CARRY OUT" Then
For i = 1 To 3
Print #2, ""
Next i
Print #2, Spc(21); "Subtotal "; Using PP$; subtotal / 100
Print #2, Spc(21); " Tax "; Using PP$; tax / 100
Print #2, Spc(32); "-------"
Print #2, Spc(21); " Total "; Using PP$; total / 100
Else
For i = 1 To 3
Print #2, ""
Next i
Print #2, Spc(21); "Subtotal "; Using PP$; subtotal / 100
Print #2, Spc(21); " Tax "; Using PP$; tax / 100
Print #2, Spc(21); "Delivery "; Using PP$; del / 100
Print #2, Spc(32); "-------"
Print #2, Spc(21); " Total "; Using PP$; total / 100
End If
Message2$ = "** GRATUITY NOT INCLUDED **"
CheckNumber$ = "Chk #"
For counter = 1 To 5
Print #2, ""
Next counter
KB$ = "INSTRUCTIONS"
XX3 = 0
For A = 1 To 7
If LTrim$(INSTRUCT$(A)) <> "" Then XX3 = 1: Exit For
Next A
If XX3 = 1 Then Print #2, Space$(20 - Len(KB$) / 2); KB$: Print #2, lined$
For A = 1 To 7
If LTrim$(INSTRUCT$(A)) <> "" Then Print #2, Space$(20 - Len(INSTRUCT$(A)) / 2); INSTRUCT$(A):
Next A
If XX3 = 1 Then Print #2, lined$
For A = 1 To 4
Print #2, ""
Next A
If typer$ = "DELIVERY" Then Print #2, Space$(20 - Len(Message2$) / 2); Message2$: Print #2, "": Print #2, ""
Call PRINTHEAD(2)
For counter = 1 To 5
Print #2, ""
Next counter
Print #2, Space$(16 - Len(chkno) / 2); CheckNumber$; " "; chkno
For counter = 1 To 5
Print #2, ""
Next counter
Call PRINTCOUPONS
For counter = 1 To 17
Print #2, " "
Next counter
Close #2
Erase RECEIPT$
ReDim RECEIPT$(1100, 2)
Erase DESCRIPTION$
Erase PRICE
del = 0
LINES = 0
DESCRIPTION$ = ""
COUPON = 0
COUPCNT = 0
TOTALSALESCNT = 0
VOIDCOUPDOLLARS = 0
PRICE = 0
line1 = 0
subtotal = 0
tax = 0
total = 0
NAME1$ = ""
STREET1$ = ""
CITY1$ = ""
PHONE1$ = ""
typer$ = ""
ReDim INSTRUCT$(7)
Call BEGINNING
End Sub
Sub REMOVELINE (DESCRIPTION$(), PRICE(), DESCRIPTION$, PRICE, LINES, line1)
Color 15,
Locate 1, 1: Print Chr$(201) + String$(35, Chr$(205)) + Chr$(203)
Locate 2, 1: Print Chr$(186)
Locate 2, 3: Color 15,: Print " Enter"
Locate 2, 10: Color 26,: Print "Line Number "
Locate 2, 22: Color 15,: Print "To Remove?" '
Locate 2, 37: Color 15,: Print Chr$(186)
Locate 3, 1: Print Chr$(204) + String$(35, Chr$(205)) + Chr$(202)
Color 15
Locate 2, 34: Input "", start
Color 15, 1
Locate 1, 1: Print "ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍË"
Locate 2, 1: Print "º LINE DESCRIPTION PRICE º"
Locate 3, 1: Print "ÌÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ͹"
REMOVEPRICE = Val(RECEIPT$(start, 2)): subtotal = subtotal - REMOVEPRICE
If REMOVEPRICE < 0 And CN > 0 Then
CHKNO$ = "checknofile\" + LTrim$(Str$(chkno)) + ".TRN"
'CHKNO$ = LTRIM$((STR$(CN))) + ".TRN"
Open CHKNO$ For Random As #3 Len = 80
Field #3, 80 As A$
Field #3, 4 As subtotal$, 4 As tax$, 4 As DEL$, 4 As total$, 4 As LINE1$, 1 As SALESTYPE$, 4 As COUPON$, 2 As COUPCNT$, 4 As VOIDCOUPDOLLARS$
Field #3, 4 As DELCNT$, 2 As TOTALSALESCNT$, 7 As ORDERTIME$
COUPON = COUPON - REMOVEPRICE
COUPCNT = COUPCNT - 1
LSet subtotal$ = MKL$(subtotal): LSet tax$ = MKL$(tax): LSet COUPON$ = MKL$(COUPON): LSet COUPCNT$ = MKI$(COUPCNT)
LSet XVOIDCOUPDOLLARS$ = MKL$(VOIDCOUPDOLLARS): LSet DELCNT$ = MKL$(DELCNT): LSet TOTALSALESCNT$ = MKI$(TOTALSALESCNT)
LSet DEL$ = MKL$(del): LSet total$ = MKL$(total): LSet LINE1$ = MKL$(line1): LSet SALESTYPE$ = LTrim$(typer$)
If Styper$ = "D" Then DELCNT = DELCNT - 1
TOTALSALESCNT = TOTALSALESCNT - 1
Put 3, 1
Close #3
End If
For a = start To LINES: For B = 0 To 2: RECEIPT$(a, B) = RECEIPT$(a + 1, B): Next B, a
For a = start To LINES: DESCRIPTION$(a) = DESCRIPTION$(a + 1): Next a
For a = start To LINES: PRICE(a) = PRICE(a + 1): Next a
LINES = LINES - 1
line1 = line1 - 1
Call GETTOTALS
Call PRINTTOTAL
Call SCROLL(DESCRIPTION$(), PRICE(), LINES, UPDOWN, DESCRIPTION$, PRICE, OFFSET, line1)
Exit Sub
End Sub
Function CLOCK$
hour$ = Left$(Time$, 2): H% = Val(hour$)
min$ = Mid$(Time$, 3, 3)
If H% >= 12 Then ampm$ = " PM" Else ampm$ = " AM"
If H% > 12 Then
If H% - 12 < 10 Then hour$ = Str$(H% - 12) Else hour$ = LTrim$(Str$(H% - 12))
ElseIf H% = 0 Then hour$ = "12" ' midnight hour
Else: If H% < 10 Then hour$ = Str$(H%) ' eliminate leading zeros
End If
CLOCK$ = "Time In: " + hour$ + min$ + ampm$
End Function
Function DELCLOCK$
Cls
temp$ = Time$
hour = Val(temp$)
min = Val(Mid$(temp$, 4, 2))
If typer$ = " PICK UP " Or typer$ = "CARRY OUT" Then gap = PICKTIME
If typer$ = "DELIVERY" Then gap = DELTIME
min = min + gap
If min > 59 Then min = min - 60: hour = hour + 1
If hour > 12 Then hour = hour - 12: M$ = "PM" Else M$ = "AM"
If hour = 12 Then If M$ = "AM" Then M$ = "PM" Else M$ = "AM"
If hour = 0 Then hour = 12: M$ = "AM"
If min < 10 Then x$ = "0" Else x$ = ""
DELCLOCK$ = "Target ETA: " + LTrim$(Str$(hour)) + ":" + x$ + LTrim$(Str$(min)) + M$
PickUPCLOCK$ = temp$
End Function
Sub CHOICEBOX
Screen 0, 0, 6, 6
Color 15, 1
Locate 14, 3: Print "ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»"
Locate 15, 3: Print "º º"
Locate 16, 3: Print "º º"
Locate 17, 3: Print "ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ"
End Sub
Sub CHECKOUT
Screen 0, 0, 19, 19
PCopy 0, 19
Color 15, 1
Locate 11, 52: Print "ÌÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ͹"
Locate 12, 52: Print "º º"
Locate 13, 52: Print "º º"
Locate 14, 52: Print "º º"
Locate 15, 52: Print "º º"
Locate 16, 52: Print "º º"
Locate 17, 52: Print "º º"
Locate 18, 52: Print "º º"
Locate 19, 52: Print "º º"
Locate 20, 52: Print "º º"
Locate 21, 52: Print "º º"
Locate 22, 52: Print "ÊÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ"
End Sub
Sub NUMBERS (X, Y, FCOLOR, BCOLOR, DECIMAL$, NUMBER, KEYPRESS)
SC = Screen(Y, X, 1): FFCOLOR = Int(SC / 16): BBCOLOR = SC Mod 16: 'CURRENT COLOR
DECIMAL = InStr(DECIMAL$, ".")
DIGITS = Len(DECIMAL$) - Sgn(DECIMAL)
GoSub SHOWS
NII: A$ = "": While A$ = "": A$ = InKey$: Wend
If Len(A$) = 1 Then
a = Asc(A$)
If a > 47 And a < 58 And NUMBER * 10 < 10 ^ DIGITS Then
NUMBER = NUMBER * 10 + Val(A$): GoSub SHOWS: GoTo NII
End If
NIII:
If a = 27 Or a = 13 Or a = 9 Then GoTo LEAVES: '[ESC] [ENTER] [TAB]
If a = 8 Then NUMBER = NUMBER \ 10: GoSub SHOWS: '[BACKSPACE]
End If
a = Asc(Right$(A$, 1))
If a = 75 Then NUMBER = NUMBER \ 10: GoSub SHOWS '[LEFT]
If a = 83 Then NUMBER = 0: GoSub SHOWS: '[DELETE]
If a > 58 And a < 69 Then GoTo LEAVES: '[F?]
If a = 73 Or a = 81 Then GoTo LEAVES: '[PG UP] [PG DN]
If a = 72 Or a = 80 Then GoTo LEAVES: '[UP] [DN]
GoTo NII
SHOWS:
N$ = Space$(DIGITS): RSet N$ = LTrim$(Str$(NUMBER))
If DECIMAL Then
N$ = Left$(N$, DECIMAL - 1) + "." + Mid$(N$, DECIMAL, 20)
If Mid$(N$, DECIMAL + 1, 1) = " " Then Mid$(N$, DECIMAL + 1, 1) = "0"
End If
If P < 1 Then P = 1
Color FCOLOR, BCOLOR
Locate Y, X: Print N$: Locate Y, X + DIGITS + Sgn(DECIMAL) - 1
Return
LEAVES: KEYPRESS = a
Color BBCOLOR, FFCOLOR: Locate Y, X: Print N$
End Sub
Sub GET_ZREPORT
_Delay 3
Cls
Screen 0, 0, 3, 3
PRINTSTRING$ = "##,###,###.##"
path$ = Environ$("LocalAppData") + "\WINDOWZ.Dll"
Open path$ For Random As #1 Len = 200
Field #1, 200 As A$
Get 1, 1
RANDOM$ = A$
'Get totals from file
ZSUBTOTAL = CVL(Mid$(RANDOM$, 56, 4)) / 100
ZTAX = CVL(Mid$(RANDOM$, 89, 4)) / 100
ZTOTAL = CVL(Mid$(RANDOM$, 122, 4)) / 100
ZVOIDS = CVL(Mid$(RANDOM$, 150, 4)) / 100
ZREFUNDS = CVL(Mid$(RANDOM$, 175, 4)) / 100
ZCOUPON = CVL(Mid$(RANDOM$, 180, 4)) / 100
ZDELIVERY = CVL(Mid$(RANDOM$, 190, 4)) / 100
'************************ REPORT FORMATTING ******************************
Color , 1
'BUILD BOX AROUND TOTAL DATA
Locate 4, 2: Print Chr$(201) + String$(76, Chr$(205)) + Chr$(187)
For i = 5 To 8
Locate i, 2: Print Chr$(186) + Spc(76) + Chr$(186)
Next i
Locate 9, 2: Print Chr$(200) + String$(76, Chr$(205)) + Chr$(188)
'END BOX BUILD
Color 15, 0
Locate 3, 27: Print "Z R E P O R T T O T A L S"
DATAS$ = "PRESS [F1] TO PRINT Z-REPORT"
Locate 18,: Print Space$(40 - Len(DATAS$) / 2); DATAS$
Color 15, 1
Locate 5, 56: Print "SUBTOTAL "; Using PRINTSTRING$; ZSUBTOTAL
Locate 6, 56: Print " TAX "; Using PRINTSTRING$; ZTAX
Locate 7, 56: Print "DELIVERY "; Using PRINTSTRING$; ZDELIVERY
Locate 8, 56: Print " TOTAL "; Using PRINTSTRING$; ZTOTAL
Locate 5, 8: Print " VOIDS "; Using PRINTSTRING$; ZVOIDS
Locate 6, 8: Print " REFUNDS "; Using PRINTSTRING$; ZREFUNDS
Locate 7, 8: Print " COUPONS "; Using PRINTSTRING$; ZCOUPON
Do Until A$ = Chr$(27)
_Limit (30)
A$ = InKey$
If A$ = Chr$(0) + Chr$(59) Then GoSub PRINTREPORTZ
Loop
Close #1
Exit Sub
PRINTREPORTZ:
If useprinter = 1 Then Open "LPT1" For Output As #2
If useprinter = 2 Then Open "wlsdfkjn.dry" For Output As #2
Call HEADER
Print #2, ""
Print #2, ""
Print #2, ""
REPORTHEAD$ = " TOTAL Z - READING REPORT "
lined$ = "================================="
Print #2, Space$(20 - Len(REPORTHEAD$) / 2); REPORTHEAD$
Print #2, Space$(20 - Len(lined$) / 2); lined$
Print #2, ""
Print #2, Spc(8) + " VOIDS"; Using "#,###,###.##"; ZVOIDS
Print #2, Spc(8) + " REFUNDS"; Using "#,###,###.##"; ZREFUNDS
Print #2, Spc(8) + " COUPONS"; Using "#,###,###.##"; ZCOUPON
Print #2, ""
Print #2, ""
Print #2, Spc(18) + "SUBTOTAL"; Using "#,###,###.##"; ZSUBTOTAL
Print #2, Spc(18) + " TAX"; Using "#,###,###.##"; ZTAX
Print #2, Spc(18) + "DELIVERY"; Using "#,###,###.##"; ZDELIVERY
Print #2, Spc(27) + "-----------"
Print #2, Spc(18) + " TOTAL"; Using "#,###,###.##"; ZTOTAL
For i = 1 To 4
Print #2, ""
Next i
Call PRINTHEAD(2)
For i = 1 To 20
Print #2, ""
Next
Close #2
Return
End Sub
Sub SAVE_ZREPORT
Randomize Timer
random$ = ""
For a = 1 To 200: random$ = random$ + Chr$(Int(Rnd(a) * (223 + 32))): Next
path$ = Environ$("LocalAppData") + "\WINDOWZ.Dll"
Open path$ For Random As #1 Len = 200
Field #1, 200 As A$
'*************** PUT AMOUNTS IN FILE ******************************
If _FileExists(path$) Then
Get 1, 1
ZSUBTOTAL = CVL(Mid$(A$, 56, 4)): ZSUBTOTAL = ZSUBTOTAL + subtotal '* 100
Mid$(random$, 56, 4) = MKL$(ZSUBTOTAL)
ZTAX = CVL(Mid$(A$, 89, 4)): ZTAX = ZTAX + tax '* 100
Mid$(random$, 89, 4) = MKL$(ZTAX)
ZTOTAL = CVL(Mid$(A$, 122, 4)): ZTOTAL = ZTOTAL + total '* 100
Mid$(random$, 122, 4) = MKL$(ZTOTAL)
ZVOIDS = CVL(Mid$(A$, 150, 4)): ZVOIDS = ZVOIDS + VOIDS '* 100
Mid$(random$, 150, 4) = MKL$(ZVOIDS)
ZREFUNDS = CVL(Mid$(A$, 175, 4)): ZREFUNDS = ZREFUNDS + REFUNDS '* 100
Mid$(random$, 175, 4) = MKL$(ZREFUNDS)
ZCOUPON = CVL(Mid$(A$, 180, 4)): ZCOUPON = ZCOUPON + COUPON '* 100
Mid$(random$, 180, 4) = MKL$(ZCOUPON)
ZDELIVERY = CVL(Mid$(A$, 190, 4)): ZDELIVERY = ZDELIVERY + del '* 100
Mid$(random$, 190, 4) = MKL$(ZDELIVERY)
LSet A$ = random$
Put 1, 1
Close 1
Else
Mid$(random$, 56, 4) = MKL$(ZSUBTOTAL)
Mid$(random$, 89, 4) = MKL$(ZTAX)
Mid$(random$, 122, 4) = MKL$(ZTOTAL)
Mid$(random$, 150, 4) = MKL$(ZVOIDS)
Mid$(random$, 175, 4) = MKL$(ZREFUNDS)
Mid$(random$, 180, 4) = MKL$(ZCOUPON)
Mid$(random$, 190, 4) = MKL$(ZDELEVERY)
LSet A$ = random$
Put 1, 1
Close 1
End If
Exit Sub
End Sub
Sub SAVE_XREPORT
Randomize Timer
random$ = ""
For a = 1 To 300: random$ = random$ + Chr$(Int(Rnd(a) * (223 + 32))): Next
path$ = Environ$("LocalAppData") + "\WINDOWX.DLL"
Open path$ For Random As #1 Len = 300
Field #1, 300 As A$
'*************** PUT AMOUNTS IN FILE ******************************
If _FileExists(path$) Then
Get 1, 1
XSUBTOTAL = CVL(Mid$(A$, 56, 4)): XSUBTOTAL = XSUBTOTAL + subtotal '* 100
Mid$(random$, 56, 4) = MKL$(XSUBTOTAL)
XTAX = CVL(Mid$(A$, 89, 4)): XTAX = XTAX + tax '* 100
Mid$(random$, 89, 4) = MKL$(XTAX)
XTOTAL = CVL(Mid$(A$, 122, 4)): XTOTAL = XTOTAL + total '* 100
Mid$(random$, 122, 4) = MKL$(XTOTAL)
XVOIDS = CVL(Mid$(A$, 150, 4)): XVOIDS = XVOIDS + VOIDS '* 100
Mid$(random$, 150, 4) = MKL$(XVOIDS)
XREFUNDS = CVL(Mid$(A$, 175, 4)): XREFUNDS = XREFUNDS + REFUNDS '* 100
Mid$(random$, 175, 4) = MKL$(XREFUNDS)
XCOUPON = CVL(Mid$(A$, 180, 4)): XCOUPON = XCOUPON + COUPON '* 100
Mid$(random$, 180, 4) = MKL$(XCOUPON)
XDELIVERY = CVL(Mid$(A$, 190, 4)): XDELIVERY = XDELIVERY + del '* 100
Mid$(random$, 190, 4) = MKL$(XDELIVERY)
XCOUPCNT = CVL(Mid$(A$, 215, 4)): XCOUPCNT = XCOUPCNT + COUPCNT '* 100
Mid$(random$, 215, 4) = MKL$(XCOUPCNT)
XUNUSED4 = CVL(Mid$(A$, 225, 4)): XUNUSED4 = XUNUSED4 + UNUSED4 'Used for XVOIDCOUPDOLLARS
Mid$(random$, 225, 4) = MKL$(XUNUSED4) ' USED FOR XVOIDCOUPDOLLARS
XDELCNT = CVL(Mid$(A$, 235, 4)): XDELCNT = XDELCNT + DELCNT '* 100
Mid$(random$, 235, 4) = MKL$(XDELCNT)
XTOTALSALESCNT = CVL(Mid$(A$, 245, 4)): XTOTALSALESCNT = XTOTALSALESCNT + TOTALSALESCNT '* 100
Mid$(random$, 245, 4) = MKL$(XTOTALSALESCNT)
XUNUSED7 = CVL(Mid$(A$, 255, 4)): XUNUSED7 = XUNUSED7 + UNUSED7 '* 100
Mid$(random$, 255, 4) = MKL$(XUNUSED7)
XUNUSED8 = CVL(Mid$(A$, 265, 4)): XUNUSED8 = XUNUSED8 + UNUSED8 '* 100
Mid$(random$, 265, 4) = MKL$(XUNUSED8)
XUNUSED9 = CVL(Mid$(A$, 275, 4)): XUNUSED9 = XUNUSED9 + UNUSED9 '* 100
Mid$(random$, 275, 4) = MKL$(XUNUSED9)
XUNUSED10 = CVL(Mid$(A$, 285, 4)): XUNUSED10 = XUNUSED10 + UNUSED10 '* 100
Mid$(random$, 285, 4) = MKL$(XUNUSED10)
LSet A$ = random$
Put 1, 1
Close 1
Else
Mid$(random$, 56, 4) = MKL$(XSUBTOTAL)
Mid$(random$, 89, 4) = MKL$(XTAX)
Mid$(random$, 122, 4) = MKL$(XTOTAL)
Mid$(random$, 150, 4) = MKL$(XVOIDS)
Mid$(random$, 175, 4) = MKL$(XREFUNDS)
Mid$(random$, 180, 4) = MKL$(XCOUPON)
Mid$(random$, 190, 4) = MKL$(XDELIVERY)
Mid$(random$, 215, 4) = MKL$(XCOUPCNT)
Mid$(random$, 225, 4) = MKL$(XUNUSED4) 'USED FOR XVOIDCOUPDOLLARS
Mid$(random$, 235, 4) = MKL$(XDELCNT)
Mid$(random$, 245, 4) = MKL$(TOTALSALESCNT)
Mid$(random$, 255, 4) = MKL$(XUNUSED7)
Mid$(random$, 265, 4) = MKL$(XUNUSED8)
Mid$(random$, 275, 4) = MKL$(XUNUSED9)
Mid$(random$, 285, 4) = MKL$(XUNUSED10)
LSet A$ = random$
Put 1, 1
Close 1
End If
Exit Sub
End Sub
Sub GET_XREPORT
Cls
Screen 0, 0, 7, 7
View Print 1 To 25
If CsrLin <> 25 Then Print Else flag = 1
If CsrLin = 25 And flag = 1 Then Locate 25, 1:
font& = _LoadFont(fontpath$, 20, "MONOSPACE,BOLD")
_Font font&
PRINTSTRING$ = "#,###,###.##"
PRINTSTRING1$ = "###"
path1$ = Environ$("LocalAppData") + "\WINDOWX.Dll"
Open path1$ For Random As #1 Len = 300
Field #1, 300 As A$
Get 1, 1
RANDOM$ = A$
'Get totals from file Location
XSUBTOTAL = CVL(Mid$(RANDOM$, 56, 4)) / 100
XTAX = CVL(Mid$(RANDOM$, 89, 4)) / 100
XTOTAL = CVL(Mid$(RANDOM$, 122, 4)) / 100
XVOIDS = CVL(Mid$(RANDOM$, 150, 4)) / 100
XREFUNDS = CVL(Mid$(RANDOM$, 175, 4)) / 100
XCOUPON = CVL(Mid$(RANDOM$, 180, 4)) / 100
XDELIVERY = CVL(Mid$(RANDOM$, 190, 4)) / 100
XCOUPCNT = CVL(Mid$(RANDOM$, 215, 4))
XVOIDCOUPDOLLARS = CVL(Mid$(RANDOM$, 225, 4)) / 100
XDELCNT = CVL(Mid$(RANDOM$, 235, 4))
XTOTALSALESCNT = CVL(Mid$(RANDOM$, 245, 4))
XUNUSED7 = CVL(Mid$(RANDOM$, 255, 4)) / 100
XUNUSED8 = CVL(Mid$(RANDOM$, 265, 4)) / 100
XUNUSED9 = CVL(Mid$(RANDOM$, 275, 4)) / 100
XUNUSED10 = CVL(Mid$(RANDOM$, 285, 4)) / 100
'************************ REPORT FORMATTING ******************************
Color , 1
'LOCATE 1, 1
Print "ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»"
Print "º º"
Print "ÌÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍËÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ͹"
Print "º º º"
Print "ÇÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ×ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄĶ"
Print "º º º"
Print "º º º"
Print "º º º"
Print "º º º"
Print "º º º"
Print "º º º"
Print "º º º"
Print "º º º"
Print "º º º"
Print "ÇÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄĶ º"
Print "º º º"
Print "ÇÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄĶ º"
Print "º º º"
Print "º ÌÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ͹"
Print "º º º"
Print "º º º"
Print "º º º"
Print "º º º"
Print "ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÊÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ"
Dim XREAD(3, 9)
Open "R", 6, "CHECKNOFILE\CHKNO.NO", 1000: Field #6, 1000 As A$: Get 6, 1
For A = 1 To 1000
B$ = Mid$(A$, A, 1): If B$ <> "A" And B$ <> "B" And B$ <> "V" Then Exit For
Next A: A = A - 1: B$ = Left$(A$, A): Close 6
For B = 1 To A
LEVEL = Asc(Mid$(B$, B, 1)) - 64
If LEVEL < 3 Then
CHKNO$ = "checknofile\" + LTrim$(Str$(B)) + ".TRN"
Open CHKNO$ For Random As #3 Len = 80: Field #3, 80 As A$
FIELD #3, 4 AS subtotal$, 4 AS tax$, 4 AS DEL$, 4 AS total$, 4 AS LINE1$, 1 AS SALESTYPE$, 4 AS COUPON$, 2 AS COUPCNT$, 4 AS XVOIDCOUPDOLLARS$, _
2 as TOTALSALESCNT$, 8 as ORDERTIME$
Get 3, 1
XREAD(LEVEL, 1) = XREAD(LEVEL, 1) + CVL(subtotal$): XREAD(LEVEL, 2) = XREAD(LEVEL, 2) + CVL(tax$)
XREAD(LEVEL, 3) = XREAD(LEVEL, 3) + CVL(DEL$): XREAD(LEVEL, 4) = XREAD(LEVEL, 4) + CVL(total$)
XREAD(LEVEL, 5) = XREAD(LEVEL, 5) + CVL(COUPON$): XREAD(LEVEL, 7) = XREAD(LEVEL, 7) + 1
XREAD(LEVEL, 8) = XREAD(LEVEL, 8) + CVI(COUPCNT$): If CVI(DEL$) > 0 Then XREAD(LEVEL, 6) = XREAD(LEVEL, 6) + 1
End If
Close 3
Next B
For B = 1 To 8: XREAD(3, B) = XREAD(1, B) + XREAD(2, B): Next B
Locate 19, 40: Print "ÌÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ͹"
'END BOX BUILD
Color 12, 1
Header0$ = "COMPLETED + PENDING SALES TOTALS"
Header1$ = "DAILY SALES REPORT TOTALS - [X-REPORT]"
Header2$ = "COMPLETED SALES TOTALS"
Header3$ = "PENDING SALES TOTALS"
Locate 2, 2: Print Space$(40 - Len(Header1$) / 2); Header1$
Color 2,
Locate 16, 2: Print Space$(18 - Len(Header0$) / 2); Header0$
Locate 4, 2: Print Space$(18 - Len(Header2$) / 2); Header2$
Locate 4, 41: Print Space$(18 - Len(Header3$) / 2); Header3$
Color 7, 4
Locate 20, 41: Print " [F1] = Print X-Report "
Locate 21, 41: Print " [F2] = Print X-Report & Clear Totals "
Locate 22, 41: Print " [Esc] = EXIT "
Color 15, 1
'**************************************************************************************************
'* COMPLETED SALES LINES FOR DISPLAY X-REPORT *
'**************************************************************************************************
Locate 6, 2: Print " SUB SALES"; Using PRINTSTRING$; XREAD(2, 1) / 100 'XSUBTOTAL
Locate 7, 2: Print " TAX"; Using PRINTSTRING$; XREAD(2, 2) / 100 'XTAX
Locate 8, 2: Print " DELIVERY"; Using PRINTSTRING$; XREAD(2, 3) / 100 'XDELIVERY
Locate 9, 2: Print "TOTAL COUPONS"; Using PRINTSTRING$; XREAD(2, 5) / 100 'XCOUPON
Locate 10, 2: Print " TOTAL SALES"; Using PRINTSTRING$; XREAD(2, 4) / 100 'XTOTAL
Locate 11, 2: Print " VOID COUPONS"; Using PRINTSTRING$; XVOIDCOUPDOLLARS
Locate 12, 2: Print " TOTAL VOID"; Using PRINTSTRING$; XTOTALVOID
Locate 13, 2: Print " SUB VOIDS"; Using PRINTSTRING$; XVOIDS
Locate 14, 2: Print " REFUNDS"; Using PRINTSTRING$; XREFUNDS
Locate 8, 27: Print ""; Using PRINTSTRING1$; XDELCNT
Locate 9, 27: Print ""; Using PRINTSTRING1$; XCOUPCNT
Locate 10, 27: Print ""; Using PRINTSTRING1$; XTOTALSALESCNT
'**************************************************************************************************
'* PENDING SALES LINES FOR DISPLAY X-REPORT *
'**************************************************************************************************
Locate 6, 42: Print "PENDING-SUB SALES"; Using PRINTSTRING$; XREAD(1, 1) / 100
Locate 7, 42: Print " PENDING-TAX"; Using PRINTSTRING$; XREAD(1, 2) / 100
Locate 8, 42: Print " PENDING-DELIVERY"; Using PRINTSTRING$; XREAD(1, 3) / 100
Locate 8, 73: Print ""; Using PRINTSTRING1$; XREAD(1, 6)
Locate 9, 42: Print " PENDING-COUPON $"; Using PRINTSTRING$; XREAD(1, 5) / 100
Locate 9, 73: Print ""; Using PRINTSTRING1$; XREAD(1, 8)
Locate 10, 42: Print "PENDING-TOT SALES"; Using PRINTSTRING$; XREAD(1, 4) / 100
Locate 10, 73: Print ""; Using PRINTSTRING1$; XREAD(1, 7)
'**************************************************************************************************
'* COMPLETED and PENDING SALES LINES FOR DISPLAY X-REPORT *
'**************************************************************************************************
Locate 18, 2: Print " SUB SALES"; Using PRINTSTRING$; XREAD(3, 1) / 100
Locate 19, 2: Print " TAX"; Using PRINTSTRING$; XREAD(3, 2) / 100
Locate 20, 2: Print " DELIVERY"; Using PRINTSTRING$; XREAD(3, 3) / 100
Locate 20, 27: Print Using PRINTSTRING1$; XREAD(3, 6)
Locate 21, 2: Print " COUPON $"; Using PRINTSTRING$; XREAD(3, 5) / 100
Locate 21, 27: Print Using PRINTSTRING1$; XREAD(3, 8)
Locate 22, 2: Print " TOTAL SALES"; Using PRINTSTRING$; XREAD(3, 4) / 100
Locate 22, 27: Print Using PRINTSTRING1$; XREAD(3, 7)
'**************************** END COMPLETED & PENDING LINES ****************************************
'file$ = "checknofile\"
'DO UNTIL A$ = CHR$(27)
'A$ = INKEY$
'IF A$ = CHR$(0) + CHR$(59) THEN GOSUB PRINTREPORTX: CLOSE #1
'IF A$ = CHR$(0) + CHR$(60) THEN GOSUB PRINTREPORTX: CLOSE #1
'IF NOT _DIREXISTS(file$ + DATE$) THEN
'SHELL _HIDE "mkdir checknofile\" + DATE$
'SHELL _HIDE "copy checknofile\*.* checknofile\" + DATE$
'CLOSE: KILL "CHECKNOFILE\*.TRN": KILL "CHECKNOFILE\*.NO"
'KILL ENVIRON$("LocalAppData") + "\WINDOWX.Dll": COLOR 15, 0
'ELSE
'SHELL _HIDE "copy checknofile\*.* checknofile\" + DATE$
'CLOSE: KILL "CHECKNOFILE\*.TRN": KILL "CHECKNOFILE\*.NO"
'KILL ENVIRON$("LocalAppData") + "\WINDOWX.Dll": COLOR 15, 0
'END IF
'CALL GET_XREPORT: A$ = CHR$(27)
'LOOP
'CLOSE #1
'CALL MENUCHOICE
file$ = "checknofile\"
RANDOMLINELABEL:
A$ = "": While A$ = "": A$ = InKey$: Wend
If A$ = Chr$(0) + Chr$(59) Then GoSub PRINTREPORTX
If A$ = Chr$(0) + Chr$(60) Then GoSub PRINTREPORTX: Close #1: GoTo KILLFILES
If A$ = Chr$(27) Then Close 1: Exit Sub
GoTo RANDOMLINELABEL
KILLFILES:
If Not _DirExists(file$ + Date$) Then
Shell _Hide "mkdir checknofile\" + Date$
Shell _Hide "move checknofile\*.* checknofile\" + Date$
Kill Environ$("LocalAppData") + "\WINDOWX.Dll": Color 15, 0
Else
Shell _Hide "move checknofile\*.* checknofile\" + Date$
Close:
Kill Environ$("LocalAppData") + "\WINDOWX.Dll": Color 15, 0
End If
Exit Sub
PRINTREPORTX:
If useprinter = 1 Then Open "LPT1" For Output As #2
If useprinter = 2 Then Open "wlsdfkjn.dry" For Output As #2
Call PRINTHEAD(1)
Print #2, ""
Print #2, ""
Print #2, ""
REPORTHEAD$ = " X - READING DAILY REPORT "
lined$ = "================================="
lined1$ = "________________________________________"
Print #2, Space$(20 - Len(REPORTHEAD$) / 2); REPORTHEAD$
Print #2, Space$(20 - Len(lined$) / 2); lined$
Print #2, ""
Print #2, Space$(20 - Len(lined1$) / 2); lined1$
Print #2, ""
dateline$ = Date$ + Spc(9) + CLOCK$
Print #2, Space$(20 - Len(dateline$) / 2); dateline$
Print #2, Space$(20 - Len(lined1$) / 2); lined1$
Print #2, ""
Print #2, ""
Print #2, Spc(8) + " VOIDS"; Using "#,###,###.##"; XVOIDS
Print #2, Spc(8) + " REFUNDS"; Using "#,###,###.##"; XREFUNDS
Print #2, Spc(8) + " VENDOR"; Using "#,###,###.##"; XVENDOR
Print #2, Spc(8) + " COUPONS"; Using "#,###,###.##"; XCOUPON
Print #2, ""
Print #2, ""
Print #2, Spc(20) + "SUBTOTAL"; Using "#,###,###.##"; XSUBTOTAL
Print #2, Spc(20) + " TAX"; Using "#,###,###.##"; XTAX
Print #2, Spc(20) + "DELIVERY"; Using "#,###,###.##"; XDELIVERY
Print #2, Spc(29) + "-----------"
Print #2, Spc(20) + " TOTAL"; Using "#,###,###.##"; XTOTAL
For i = 1 To 8
Print #2, ""
Next
Call PRINTHEAD(2)
For i = 1 To 20
Print #2, ""
Next
Close #2
Return
End Sub
Sub PASSWORD
Screen 0, 0, 12, 12
Color 15, 1
Locate 14, 3: Print "ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»"
Locate 15, 3: Print "º º"
Locate 16, 3: Print "ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ"
Locate 15, 4: Print "PASSORD:"
End Sub
Sub VOID
del = delivery * 100
refresh:
'******************************************************************************************************************************
' THIS SECTION WAS ADDED TO KEEP FROM CREATING A BLANK CHKNO.NO FILE
'******************************************************************************************************************************
Call CHECKFORFILE
'******************************************************************************************************************************
' END ADDED SECTION
'******************************************************************************************************************************
Open "checknofile\CHKNO.NO" For Random As #3 Len = 1000
Field #3, 1000 As A$
Get 3, 1: B$ = A$: Close 3
For A = 1 To 1000
If Mid$(B$, A, 1) = Chr$(15) Then Exit For
Next
ENDER = A - 1
RR$ = "\ \ ###.##"
SS$ = "###.##"
SSI$ = "-###.##"
Screen 0, 0, 17, 17
Color 15, 1
Cls
GoSub CreateScreen
If ENDER = 0 Then
Color 15, 4
Locate 10, 10: Print "ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»"
Locate 11, 10: Print "º NO SALES HAS BEEN RECORDED YET º"
Locate 12, 10: Print "ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ"
Locate 13, 10: Print " "
Locate 14, 10: Print "ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»"
Locate 15, 10: Print "º PRESS ANY KEY TO CONTINUE º"
Locate 16, 10: Print "ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ"
Sleep
Exit Sub
End If
X = 66: Y = 7: FCOLOR = 15: BCOLOR = 3: DECIMAL$ = "####": NUMB = 1: NUMBER = CN
'CALL NUMBERS(X, Y, FCOLOR, BCOLOR, DECIMAL$, NUMBER, KEYPRESS)
CN = 1
BB7: chkno = CN: COUPON = 0
Open "checknofile\CHKNO.NO" For Random As #3 Len = 1000
Field #3, 1000 As A$
Get 3, 1: B$ = A$: Close 3
If Mid$(B$, CN, 1) = Chr$(65) Then Color , 2: Locate 7, 73: Print " OPEN "
If Mid$(B$, CN, 1) = Chr$(66) Then Color , 6: Locate 7, 73: Print "CLOSED"
If Mid$(B$, CN, 1) = Chr$(86) Then Color , 4: Locate 7, 73: Print " VOID "
Color 15, 1
CHKNO$ = "checknofile\" + LTrim$(Str$(chkno)) + ".TRN"
'CHKNO$ = LTRIM$(STR$(chkno)) + ".TRN"
For Y = 2 To 5: Locate Y, 53: Print Space$(27);: Next
If Not _FileExists(CHKNO$) Then
Color 15, 1
Cls
Locate 4, 2: Print Space$(38 - Len("SORRY, I COULD NOT FIND A CHECK NUMBER " + CHKNO$) / 2); " I COULD NOT FIND A CHECK NUMBER " + CHKNO$
Locate 11, 2: Print Space$(38 - Len("CHECK ALREADY PAID or CHECK DOESN'T EXIST") / 2); " CHECK PAID or CHECK DOESN'T EXIST"
Locate 15, 2: Print Space$(38 - Len("PRESS ANY KEY TO CONTINUE") / 2); " PRESS ANY KEY TO CONTINUE"
Color 15, 1
GoSub ResetTotals
Sleep
Call BEGINNING
End If
line1 = 0
Open CHKNO$ For Random As #3 Len = 80
Field #3, 80 As A$
FIELD #3, 4 AS subtotal$, 4 AS tax$, 4 AS DEL$, 4 AS total$, 4 AS LINE1$, 1 AS SALESTYPE$, 4 AS COUPON$, 2 AS COUPCNT$, 4 AS VOIDCOUPDOLLARS$, _
2 as TOTALSALESCNT$
Get 3, 1
subtotal = CVL(subtotal$): tax = CVL(tax$): COUPON = CVL(COUPON$): COUPCNT = CVI(COUPCNT$): VOIDCOUPDOLLARS = CVL(VOIDCOUPDOLLARS$)
del = CVL(DEL$): total = CVL(total$): line1 = CVL(LINE1$): Styper$ = SALESTYPE$: TOTALSALESCNT = CVI(TOTALSALESCNT$)
If Styper$ = "D" Then DELCNT = 1 Else DELCNT = 0
Get 3, 2: NAME1$ = RTrim$(A$)
Get 3, 3: STREET1$ = RTrim$(A$)
Get 3, 4: CITY1$ = RTrim$(A$)
Get 3, 5: Back$ = RTrim$(A$)
Field #3, 30 As Desc$, 10 As price$
For A = 1 To line1
Get 3, A + 5
RECEIPT$(A, 1) = RTrim$(Desc$): RECEIPT$(A, 2) = RTrim$(price$)
Next A
For A = 1 To 7
Get 3
INSTRUCT$(A) = Left$(A$, 27)
88 I = InStr(INSTRUCT$(A), Chr$(0))
If I Then Mid$(INSTRUCT$(A), I, 1) = " ": GoTo 88
Next
Close
LINES = line1: OFFSET = 0: updown = 0
GoSub SCROLLER
Locate 18, 53: Print " Subtotal =====> "
Locate 19, 53: Print " Tax =====> "
Locate 20, 53: Print " Del Fee =====> "
Locate 21, 73: Print "ÄÄÄÄÄÄ"
Locate 22, 53: Print "Total Due =====> "
Locate 18, 73: Print Using SS$; subtotal / 100
Locate 19, 73: Print Using SS$; tax / 100
Locate 20, 73: Print Using SS$; del / 100
Locate 22, 73: Print Using SS$; total / 100
Locate 2, 53: Print NAME1$
Locate 3, 53: Print STREET1$
Locate 4, 53: Print CITY1$
Locate 5, 53: Print Back$
LINES = line1: GoSub SCROLLER
BB8: X = 66: Y = 7: FCOLOR = 15: BCOLOR = 3: DECIMAL$ = "####": NUMB = 1: NUMBER = CN
Call NUMBERS(X, Y, FCOLOR, BCOLOR, DECIMAL$, NUMBER, KEYPRESS)
If KEYPRESS = 27 Then
GoSub ResetTotals
Exit Sub
End If
If KEYPRESS = 13 Then CN = NUMBER: GoTo BB7
If KEYPRESS = 72 Then updown = -1: GoSub SCROLLER: GoTo BB8
If KEYPRESS = 80 Then updown = 1: GoSub SCROLLER: GoTo BB8
If KEYPRESS = 73 Then
CN = CN - 1: If CN = 0 Then CN = ENDER
GoTo BB7
End If
If KEYPRESS = 81 Then
CN = CN + 1: If CN > ENDER Then CN = 1
GoTo BB7
End If
If KEYPRESS = 59 Then GoTo 2
If KEYPRESS = 63 Then
'PRINTSTRING$ = "##,###,###.##"
path$ = Environ$("LocalAppData") + "\WINDOWX.Dll"
If Mid$(B$, CN, 1) <> "V" Then
If Mid$(B$, CN, 1) = "A" Then GoTo TT
Open path$ For Random As #1 Len = 300
Field #1, 300 As A$
Get 1, 1
RANDOM$ = A$
'Get totals from file Location
XSUBTOTAL = CVL(Mid$(RANDOM$, 56, 4))
XTAX = CVL(Mid$(RANDOM$, 89, 4))
XTOTAL = CVL(Mid$(RANDOM$, 122, 4))
XVOIDS = CVL(Mid$(RANDOM$, 150, 4))
XREFUNDS = CVL(Mid$(RANDOM$, 175, 4))
XCOUPON = CVL(Mid$(RANDOM$, 180, 4))
XDELIVERY = CVL(Mid$(RANDOM$, 190, 4))
XCOUPCNT = CVL(Mid$(RANDOM$, 215, 4))
XVOIDCOUPDOLLARS = CVL(Mid$(RANDOM$, 225, 4))
XDELCNT = CVL(Mid$(RANDOM$, 235, 4))
XTOTALSALESCNT = CVL(Mid$(RANDOM$, 245, 4))
'IF del <> 0 THEN XDELCNT = XDELCNT - 1
XSUBTOTAL = XSUBTOTAL - subtotal
XTAX = XTAX - tax
XTOTAL = XTOTAL - total
XCOUPON = XCOUPON - COUPON
XDELCNT = XDELCNT - DELCNT
XVOIDS = XVOIDS - subtotal
XDELIVERY = XDELIVERY - del
XCOUPCNT = XCOUPCNT - COUPCNT
XTOTALSALESCNT = XTOTALSALESCNT - 1
XVOIDCOUPDOLLARS = XVOIDCOUPDOLLARS + COUPON
Mid$(RANDOM$, 56, 4) = MKL$(XSUBTOTAL)
Mid$(RANDOM$, 89, 4) = MKL$(XTAX)
Mid$(RANDOM$, 122, 4) = MKL$(XTOTAL)
Mid$(RANDOM$, 150, 4) = MKL$(XVOIDS)
Mid$(RANDOM$, 175, 4) = MKL$(XREFUNDS)
Mid$(RANDOM$, 180, 4) = MKL$(XCOUPON)
Mid$(RANDOM$, 190, 4) = MKL$(XDELIVERY)
Mid$(RANDOM$, 215, 4) = MKL$(XCOUPCNT)
Mid$(RANDOM$, 225, 4) = MKL$(XVOIDCOUPDOLLARS)
Mid$(RANDOM$, 235, 4) = MKL$(XDELCNT)
Mid$(RANDOM$, 245, 4) = MKL$(XTOTALSALESCNT)
LSet A$ = RANDOM$
Put 1, 1
Close #1
path$ = Environ$("LocalAppData") + "\WINDOWZ.Dll"
Open path$ For Random As #1 Len = 200
Field #1, 200 As A$
Get 1, 1
RANDOM$ = A$
'Get totals from file
ZSUBTOTAL = CVL(Mid$(RANDOM$, 56, 4))
ZTAX = CVL(Mid$(RANDOM$, 89, 4))
ZTOTAL = CVL(Mid$(RANDOM$, 122, 4))
ZVOIDS = CVL(Mid$(RANDOM$, 150, 4))
ZREFUNDS = CVL(Mid$(RANDOM$, 175, 4))
ZCOUPON = CVL(Mid$(RANDOM$, 180, 4))
ZDELIVERY = CVL(Mid$(RANDOM$, 190, 4))
ZSUBTOTAL = ZSUBTOTAL - subtotal
ZTAX = ZTAX - tax
ZTOTAL = ZTOTAL - total
ZCOUPON = ZCOUPON - COUPON
ZVOIDS = ZVOIDS - subtotal
ZDELIVERY = ZDELIVERY - del
Mid$(RANDOM$, 56, 4) = MKL$(ZSUBTOTAL)
Mid$(RANDOM$, 89, 4) = MKL$(ZTAX)
Mid$(RANDOM$, 122, 4) = MKL$(ZTOTAL)
Mid$(RANDOM$, 150, 4) = MKL$(ZVOIDS)
Mid$(RANDOM$, 175, 4) = MKL$(ZREFUNDS)
Mid$(RANDOM$, 180, 4) = MKL$(ZCOUPON)
Mid$(RANDOM$, 190, 4) = MKL$(ZDELIVERY)
LSet A$ = RANDOM$
Put 1, 1
Close #1
TT: Open "checknofile\CHKNO.NO" For Random As #3 Len = 1000
Field #3, 1000 As A$
Get 3, 1: B$ = A$
Mid$(B$, CN, 1) = "V"
LSet A$ = B$
Put 3, 1
Close 3
GoTo 6
Else
1 If Mid$(B$, CN, 1) = "V" Then
Color 15, 4
Locate 17, 5: Print "ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»"
Locate 18, 5: Print "º This Check Is Already Void. You may reprint this check only º"
Locate 19, 5: Print "º PRESS [F1] TO REPRINT THIS CHECK º"
Locate 20, 5: Print "º PRESS [ENTER] TO RETURN TO THE VOID/REPRINT SCREEN º"
Locate 21, 5: Print "º PRESS [Esc] TO RETURN TO THE MAIN SCREEN º"
Locate 22, 5: Print "ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ"
Sleep
Call NUMBERS(X, Y, FCOLOR, BCOLOR, DECIMAL$, NUMBER, KEYPRESS)
If KEYPRESS = 13 Then
GoSub CreateScreen
GoTo BB7
ElseIf KEYPRESS = 27 Then
GoSub ResetTotals
Exit Sub
ElseIf KEYPRESS = 59 Then
GoTo 2
Else
GoTo 1
End If
End If
End If
End If
GoTo refresh
2 If KEYPRESS = 59 Then
6 REPRINT1$ = "*********************************"
REPRINT2$ = "*** REPRINT REPRINT REPRINT ***"
REPRINT3$ = "*** THIS CHECK HAS BEEN VOIDED **"
If useprinter = 1 Then Open "LPT1:" For Output As #2
If useprinter = 2 Then Open "wlsdfkjn.dry" For Output As #2
Print #2, Space$(20 - Len(REPRINT1$) / 2); REPRINT1$
Print #2, Space$(20 - Len(REPRINT2$) / 2); REPRINT2$
Print #2, Space$(20 - Len(REPRINT1$) / 2); REPRINT1$
If Mid$(B$, CN, 1) = "V" Then
Print #2, Space$(20 - Len(REPRINT1$) / 2); REPRINT1$
Print #2, Space$(20 - Len(REPRINT3$) / 2); REPRINT3$
Print #2, Space$(20 - Len(REPRINT1$) / 2); REPRINT1$
End If
For I = 1 To 2
Print #2, ""
Next I
Call PRINTHEAD(1)
lined$ = "________________________________________"
Print #2, Space$(20 - Len(lined$) / 2); lined$
dateline$ = Date$ + Spc(9) + CLOCK$
Print #2, ""
Print #2, Space$(20 - Len(dateline$) / 2); dateline$
Print #2, ""
Print #2, Space$(20 - Len(DELCLOCK$) / 2); DELCLOCK$
Print #2, Space$(20 - Len(lined$) / 2); lined$
Print #2, ""
Print #2, NAME1$
Print #2, STREET1$
Print #2, CITY1$
Print #2, Back$
Print #2, Space$(20 - Len(lined$) / 2); lined$
Print #2, ""
If Styper$ = "C" Then Styper$ = "CARRYOUT"
If Styper$ = "P" Then Styper$ = "PICKUP"
If Styper$ = "D" Then Styper$ = "DELIVERY"
Print #2, Chr$(29)
Star$ = String$(40, "-")
Print #2, Chr$(31); Space$(10 - Len(Styper$) / 2); Styper$
Print #2, Chr$(29)
Print #2, Space$(20 - Len(Star$) / 2); Star$
Print #2, ""
Print #2, ""
For count = 1 To line1
If Val(RECEIPT$(count, 2)) = 0.00 Then
Print #2, RECEIPT$(count, 1)
Else
Print #2, Using RR$; RECEIPT$(count, 1); Val(RECEIPT$(count, 2)) / 100
End If
Next count
If typer$ = " PICK UP " Or typer$ = "CARRY OUT" Then
For I = 1 To 3
Print #2, ""
Next I
Print #2, Spc(25); "Subtotal "; Using SS$; subtotal / 100
Print #2, Spc(25); " Tax "; Using SS$; tax / 100
Print #2, Spc(36); "-------"
Print #2, Spc(25); " Total "; Using SS$; total / 100
Else
For I = 1 To 3
Print #2, ""
Next I
Print #2, Spc(25); "Subtotal "; Using SS$; subtotal / 100
Print #2, Spc(25); " Tax "; Using SS$; tax / 100
Print #2, Spc(25); "Delivery "; Using SS$; del / 100
Print #2, Spc(33); "-------"
Print #2, Spc(25); " Total "; Using SS$; total / 100
End If
CheckNumber$ = "Check-> "
For counter = 1 To 5
Print #2, ""
Next counter
If Styper$ = "DELIVERY" Then Print #2, Space$(20 - Len(Message2$) / 2); Message2$: Print #2, "": Print #2, ""
Call PRINTHEAD(2)
For counter = 1 To 5
Print #2, ""
Next counter
Print #2, Space$(20 - Len(chkno) / 2); CheckNumber$; " "; chkno
For counter = 1 To 17
Print #2, ""
Next counter
Close #2
GoSub ResetTotals
'CALL MENUCHOICE
Exit Sub
End If
GoTo BB8
ResetTotals:
del = 0: LINES = 0: DESCRIPTION$ = "": PRICE = 0: line1 = 0: subtotal = 0: tax = 0
total = 0: NAME1$ = "": STREET1$ = "": CITY1$ = "": phone$ = "": Back$ = "": typer$ = ""
COUPON = 0: ReDim INSTRUCTION$(7)
If COUPCNT <> 0 Then COUPCNT = COUPCNT - 1
Return
CreateScreen:
Color 15, 1
Print Chr$(201) + String$(50, Chr$(205)) + Chr$(203) + String$(27, Chr$(205)) + Chr$(187)
Print Chr$(186) + Spc(50) + Chr$(186) + Spc(27) + Chr$(186)
Print Chr$(204) + String$(50, Chr$(205)) + Chr$(185) + Spc(27) + Chr$(186)
For I = 1 To 2
Print Chr$(186) + String$(50, Chr$(255)) + Chr$(186) + Spc(27) + Chr$(186)
Next I
Print Chr$(186) + String$(50, Chr$(255)) + Chr$(204) + String$(27, Chr$(205)) + Chr$(185)
Print Chr$(186) + String$(50, Chr$(255)) + Chr$(186) + Spc(27) + Chr$(186)
Print Chr$(186) + String$(50, Chr$(255)) + Chr$(204) + String$(27, Chr$(205)) + Chr$(185)
For I = 1 To 8
Print Chr$(186) + String$(50, Chr$(255)) + Chr$(186) + Spc(27) + Chr$(186)
Next I
Print Chr$(186) + String$(50, Chr$(255)) + Chr$(204) + String$(27, Chr$(205)) + Chr$(185)
For I = 1 To 5
Print Chr$(186) + String$(50, Chr$(255)) + Chr$(186) + Spc(27) + Chr$(186)
Next I
Print Chr$(200) + String$(50, Chr$(205)) + Chr$(202) + String$(27, Chr$(205)) + Chr$(188)
Title$ = "VOID/REPRINT CHECK"
Color 12, 1: Locate 2,: Print Space$(25 - Len(Title$) / 2); Title$: Color 15, 1
Locate 2, 1: Print Chr$(186)
Locate 7, 53: Print "CHECK NUMBER"
Locate 9, 56: Color 13: Print "[ESC] = EXIT"
Locate 10, 56: Print "[" + Chr$(24) + Chr$(25) + "]" + " = SCROLL ORDER"
Locate 11, 56: Print "[F1] = REPRINT CHECK"
Locate 12, 56: Print "[F5] = VOID CHECK"
Locate 16, 53: Print "[PGUP] = PREV" + " " + "[PGDN] = NEXT": Color 15, 1
Return
SCROLLER:
PRINTSTRING$ = "#### \ \ ####.## ": WIDTHS = Len(PRINTSTRING$)
printstring2$ = "#### \ \" + " ": WIDTHS = Len(printstring2$)
X = 2: Y = 3: HEIGHT = 19
If updown <> 0 Then
OFFSET = OFFSET + updown * -1
If OFFSET = LINES * -1 Then OFFSET = OFFSET + 1
If OFFSET > 0 Then OFFSET = 0
End If
For A = 0 To HEIGHT - 1
B = A - HEIGHT + LINES + 1 + OFFSET
Locate A + Y + 1, X
If B < 1 Then
Print Spc(WIDTHS);
Else
If Val(RECEIPT$(B, 2)) = 0 Then
Print Using printstring2$; B; RECEIPT$(B, 1);
Else
Print Using PRINTSTRING$; B; RECEIPT$(B, 1); Val(RECEIPT$(B, 2)) / 100;
End If
End If
Next
Return
End Sub
Sub HEADER
Call PRINTHEAD(1)
lined$ = "________________________________________"
Print #2, Space$(20 - Len(lined$) / 2); lined$
dateline$ = Date$ + Spc(9) + CLOCK$
Print #2, ""
Print #2, Space$(20 - Len(dateline$) / 2); dateline$
Print #2, Space$(20 - Len(lined$) / 2); lined$
Print #2, ""
End Sub
Sub TYPEINSTRUCTIONS
Color 15, 3
For A = 1 To 7
Locate A + 8, 53: Print Using "\" + Space$(25) + "\"; INSTRUCT$(A)
Next
Y = 1
55 INPUTER$ = INSTRUCT$(Y)
Call INPUTS(53, Y + 8, 15, 5, 27, 0, INPUTER$, KEYPRESS, 0)
INSTRUCT$(Y) = INPUTER$
If KEYPRESS = 13 Or KEYPRESS = 80 Then Y = Y + 1: If Y = 8 Then Y = 1
If KEYPRESS = 72 Then Y = Y - 1: If Y = 0 Then Y = 7
If KEYPRESS <> 27 Then GoTo 55
Color 15, 1
For A = 1 To 7
Locate A + 8, 53: Print Using "\" + Space$(25) + "\"; INSTRUCT$(A)
Next
End Sub
Sub PRINTCOUPONS
Dim COUPON$(11, 6), COUPON(3, 6), EVEN$(1), SETS$(1), RNDM!(60000)
If _FileExists("COUPONS.DAT") Then
Open "R", 15, "COUPONS.DAT", 40: Field #15, 39 As A$
For B = 1 To 6: For A = 1 To 10
Get 15: COUPON$(A, B) = A$: If InStr(COUPON$(A, B), Chr$(0)) Then COUPON$(A, B) = Space$(39)
Next A, B
For A = 1 To 6
For B = 10 To 1 Step -1
If RTrim$(COUPON$(B, A)) <> "" Then Exit For
Next B
COUPON(3, A) = B
Next A
Get 15, 61: For B = 1 To 6: For A = 1 To 2: COUPON(A, B) = CVI(Mid$(A$, (B - 1) * 4 + A * 2 - 1, 2)): Next A, B
SETTING = Asc(Mid$(A$, 27, 1))
COUPONCOUNT = CVI(Mid$(A$, 25, 2))
COUPONCOUNT = COUPONCOUNT + 1: If COUPONCOUNT > 30000 Then COUPONCOUNT = 0
' COUPONCOUNT = 0
B$ = A$: Mid$(B$, 25, 2) = MKI$(COUPONCOUNT): LSet A$ = B$: Put 15, 61
Close 15
Else
A = A
'CLS: PRINT "NO COUPON FILE EXISTS": END
End If
Randomize Timer
If SETTING = 1 Then
For A = 1 To 6
X = COUPON(1, A)
If COUPON(1, A) > 0 And COUPON(3, A) > 0 Then
If COUPON(2, X) = 0 Then
If COUPONCOUNT / X = COUPONCOUNT \ X Then GoSub PRINTCOUPON
Else
If Int(Rnd(1) * X) = 0 Then GoSub PRINTCOUPON
End If
End If
Next A
Else
C = 0
For A = 1 To 6
If COUPON(1, A) > 0 And COUPON(3, A) > 0 Then
For B = 1 To COUPON(1, A): RNDM!(B + C) = A: Next B
C = B + C - 1
End If
Next A
If C > 0 Then J = Int(Rnd(1) * (C)) + 1: A = RNDM!(J): GoSub PRINTCOUPON
'J = INT(RND(1) * (C)) + 1: A = RNDM!(J): GOSUB PRINTCOUPON
End If
Exit Sub
PRINTCOUPON:
Print #2, "****************COUPON****************"
For B = 1 To COUPON(3, A): Print #2, COUPON$(B, A): Next
Print #2, String$(39, "*")
Print #2, ""
Return
End Sub
'SHOWCOUPONS:
'LPRINT "COUNT = "; COUNT
'LPRINT "SETTING = "; SETTING
'FOR A = 1 TO 6
'LPRINT "***************************"
'FOR B = 1 TO 3: LPRINT COUPON(B, A),: NEXT B: LPRINT
'FOR B = 1 TO COUPON(3, A): LPRINT COUPON$(B, A): NEXT B
'NEXT A
'RETURN
Sub SEEMENUS (a$)
999 Data [F1],[F2],[F3],[F4],[F5],[F6],[F7],[F8],[F9],[F10],[F11],[F12],[HOME],[INSERT],[END],[DELETE],[P],[L],[X],[Z]
Screen , , 1, 1
Color 15, 1: Cls: Restore 999: B$ = " ": Locate 1, 35: Print "Choose menu": Print
For A = 1 To 20
Read a$: RSet B$ = a$
If FKEY(A, 0) Then Locate , 30: Print B$; " "; LTrim$(MENULABEL$(A))
Next A: 'PRINT: PRINT TAB(35); "[ESC] Quit"
a$ = "": While a$ = "": a$ = InKey$: Wend
Screen 0, 0, 0, 0
End Sub
|
|
|
|
| CHAT for QB64 |
|
Posted by: MasterGy - 12-17-2022, 11:03 PM - Forum: MasterGy
- Replies (3)
|
|
I would like to meet in a QB64 3D world one day. On a beach...or anywhere 
I started learning this TCP/IP thing. It worked and I was very happy. That's when I realized that if the clients don't send coordinates, but text, then we actually get a chat program.
The engine is running. I rented a server and we can talk to each other through it!
Try it !
Code: (Select All) Randomize Timer
'profile data -----------------------------------------------------------------------------------------
my_name$ = "user" 'your nickname
my_info$ = "i am ...." 'short introduction
my_color&& = _RGB32(55 + 200 * Rnd, 55 + 200 * Rnd, 55 + 200 * Rnd, 255) 'your color
'----------------------------------------------------------------------------------------------------------
Const fc$ = "sudlikam"
connect_ip$ = "95.138.193.62"
connect_port$ = "60000"
mess_c = 20
my_name$ = my_name$ + "_" + LTrim$(Str$(Int(100 * Rnd(1))))
bg&& = _RGB32(30, 10, 10): _Title "client - " + my_name$
max_client = 100: Dim c$(max_client - 1, 9), active(max_client - 1), cpic(max_client - 1, 1), mess$(mess_c - 1), v(max_client - 1, 1)
monx = 1000: mony = 550: mon = _NewImage(monx, mony, 32): Screen mon
'connection
Dim Shared connection&, dat$, mess$
Do: _Limit 10: If InKey$ = Chr$(27) Then System
connection& = _OpenClient("TCP/IP:" + connect_port$ + ":" + connect_ip$)
If connection& = 0 Then Print "no connection"
Loop Until connection&
send "0nam" + my_name$: send "1inf" + my_info$
send "4col" + Right$("00" + Hex$(_Red(my_color&&)), 2) + Right$("00" + Hex$(_Green(my_color&&)), 2) + Right$("00" + Hex$(_Blue(my_color&&)), 2) + Right$("00" + Hex$(_Alpha(my_color&&)), 2)
Do: _Limit 20
If Abs(Timer - sign_timer) > 2 Then send "sign": sign_timer = Timer
Do
s$ = get2$
If Len(s$) Then
Select Case Mid$(s$, 5, 4)
Case "5pos", "0nam", "1inf", "3msg", "4col"
c$(Val(Left$(s$, 4)), Val(Mid$(s$, 5, 1))) = Mid$(s$, 9)
Case "addc": active(Val(Left$(s$, 4))) = 1: Sound 2000, .2
Case "delc": active(Val(Left$(s$, 4))) = 0
If cpic(Val(Left$(s$, 4)), 1) Then _FreeImage cpic(Val(Left$(s$, 4)), 0)
cpic(Val(Left$(s$, 4)), 1) = 0
Case "cmsg": mess$(cm) = Mid$(s$, 9): cm = (cm + 1) Mod mess_c
Case "srok": srok = Timer
End Select
End If
Loop While Len(s$)
'show header
While _MouseInput: Wend
Color my_color&&: Print my_name$; "- client ",
If Abs(srok - Timer) > 5 Then
Color _RGB32(255, 0, 0): Print "Server no answer"
Else
Color _RGB32(0, 255, 0): Print "Server is OK ! "
End If
Color _RGB32(150, 150, 150): Print String$(monx / 8 - 1, "-"): Print "connected : ";
startx = 14 * 8: starty = 2 * 16: show_info = -1
For c = 0 To max_client - 1: If active(c) = 0 Then _Continue
If c$(c, 4) = "" Then
Color _RGB32(150, 150, 150)
Else
For t = 0 To 3: co(t) = Val("&h" + Mid$(c$(c, 4), t * 2 + 1, 2)): Next t
Color _RGB32(0, 0, 0), _RGB32(co(0), co(1), co(2), co(3))
End If
If Len(c$(c, 0)) * 8 + startx > monx - 10 Then startx = 0: starty = starty + 16
_PrintString (startx, starty), c$(c, 0)
If _MouseX > startx And _MouseX < startx + Len(c$(c, 0)) * 8 And _MouseY > starty And _MouseY < starty + 16 Then show_info = c
startx = startx + (Len(c$(c, 0)) + 2) * 8
Next c
If show_info <> -1 Then
Color _RGB32(100, 100, 100), _RGB32(255, 255, 255): startx = _MouseX
If startx + Len(c$(show_info, 1)) * 8 > monx - 10 Then startx = monx - 10 - Len(c$(show_info, 1)) * 8
_PrintString (startx, _MouseY + 16), c$(show_info, 1)
End If
Color , bg&&
'show message my type
Color my_color&&: If Int(Timer * 10) And 1 Then cr$ = "_" Else cr$ = " "
Locate mony / 16 - 2, 1: Print mess$; cr$;
'show messages
For t = 0 To mess_c - 1
y = mony / 16 - 2 - mess_c: Locate y + t, 1: s$ = mess$((cm + t) Mod mess_c)
Color _RGBA32(Val("&h" + Mid$(s$, 1, 2)), Val("&h" + Mid$(s$, 3, 2)), Val("&h" + Mid$(s$, 5, 2)), Val("&h" + Mid$(s$, 7, 2)))
Print Mid$(s$, 19): Next t
_Display: Color , _RGB32(0, 0, 0): Cls
Line (0, mony - (mess_c + 4) * 16)-(monx, mony), bg&&, BF
'type message
k$ = InKey$
If Len(k$) Then
a = Asc(k$)
If a = 27 Then System
If a = 13 And Len(mess$) Then send "3msg" + mess$: mess$ = ""
If a = 8 Then mess$ = Left$(mess$, Len(mess$) - 1)
felt = (a > 31 And a < 91) Or (a > 96 And a < 123)
If felt Then mess$ = mess$ + k$
End If
Loop
err1: hiba = 1: Resume Next
Sub send (s$): s2$ = s$ + fc$: Put connection&, , s2$: End Sub
Function get2$
If Len(dat$) = 0 Then Get connection&, , st$: dat$ = dat$ + st$
If Len(dat$) = 0 Then Exit Function
ok = -1: For t = 1 To Len(dat$)
If Mid$(dat$, t, Len(fc$)) = fc$ Then ok = t: Exit For
Next t
If ok = -1 Then Exit Function
get2$ = Left$(dat$, ok - 1): dat$ = Mid$(dat$, ok + Len(fc$))
End Function
|
|
|
|
| QBJS - Web Chat |
|
Posted by: dbox - 12-17-2022, 06:38 PM - Forum: QBJS, BAM, and Other BASICs
- Replies (7)
|
 |
You guys inspired me. I saw all of the recent chat server posts and wondered how hard it would be to create a web chat client in QBJS. For anyone interested you can try out the end result here:
QB Web Chat
The server is written in QB64. I used luke's simple HTTP server as a starting point and modified it to be an HTTP chat server. Here is the server code in case you want to play around with it:
Code: (Select All) ' QB Chat Server
' Author: dbox*
' *This originally started as luke's simple HTTP server.
' It has been modified to serve as an HTTP chat server.
' Here is the original source attribution:
' -------------------------------------------------------------------------------------
' HTTP 1.1 Compliant Web Server
' Author: luke
' Source: https://www.qb64.org/forum/index.php?topic=2052.0
' This program is made available for you to use, modify and distribute it as you wish,
' all under the condition you do not claim original authorship.
' -------------------------------------------------------------------------------------
$Console:Only
Option _Explicit
DefLng A-Z
Const MAX_CONNECTIONS = 8
Dim PORT As Integer: PORT = 8080
If _CommandCount > 0 Then
PORT = Val(Command$(1))
End If
Const FALSE = 0
Const TRUE = -1
Dim Shared CRLF As String
CRLF = Chr$(13) + Chr$(10)
Const HTTP_10 = 1
Const HTTP_11 = 11
Const HTTP_GET = 1
Const HTTP_HEAD = 2
Const HTTP_POST = 3
Type connection_t
handle As Long
read_buf As String
http_version As Integer
method As Integer
request_uri As String
content_length As Integer
End Type
Type http_error_t
code As Integer
message As String
connection As Integer
End Type
Type file_error_t
failed As Integer
code As Integer
End Type
Dim i
Dim num_active_connections
Dim server_handle
Dim Shared Connections(1 To MAX_CONNECTIONS) As connection_t
Dim Shared Http_error_info As http_error_t
Dim Shared File_error_info As file_error_t
'---------------------------------------------------------------------
' Chat server-specific initialization
'---------------------------------------------------------------------
Type Message
sender As String
message As String
time As String
End Type
Const MAX_MESSAGE = 100
Dim Shared messages(MAX_MESSAGE) As Message
Dim Shared cmsg As _Unsigned Long
cmsg = 0
Open "chatlog.txt" For Append As #1
'---------------------------------------------------------------------
On Error GoTo error_handler
server_handle = _OpenHost("TCP/IP:" + LTrim$(Str$(PORT)))
Print "Listening on port:" + Str$(PORT)
Do
If num_active_connections < MAX_CONNECTIONS Then
Dim new_connection
new_connection = _OpenConnection(server_handle)
If new_connection Then
num_active_connections = num_active_connections + 1
For i = 1 To MAX_CONNECTIONS
If Connections(i).handle = 0 Then
Dim empty_connection As connection_t
Connections(i) = empty_connection
Connections(i).handle = new_connection
num_active_connections = num_active_connections - 1
Exit For
End If
Next i
End If
End If
For i = 1 To MAX_CONNECTIONS
If Connections(i).handle Then
Dim buf$
Get #Connections(i).handle, , buf$
If buf$ <> "" Then
' This is a bit of a hack workaround.
' We have no gaurantee that the sent message will not be fragmented.
' So there's a chance the full message will not be sent all at once.
' Unfortunately, there's no way I know of to tell from the connection
' if there is more to read.
' Hence, we sleep for .05 seconds and try to read from the connection again.
' We'll repeat this as long as we keep reading content.
' Will this ensure we read the entire body content?
' No, but it seems to work for most cases.
While buf$ <> ""
Connections(i).read_buf = Connections(i).read_buf + buf$
_Delay .05
Get #Connections(i).handle, , buf$
Wend
process_request i
http_error_complete:
End If
End If
Next i
_Limit 240
Loop
error_handler:
If Err = 100 Then 'HTTP error
'Print "HTTP error"; Http_error_info.code; Http_error_info.message; " for connection"; Http_error_info.connection
Resume http_error_complete
End If
'Print "error"; Err; "on line"; _ErrorLine
End
file_error_handleyour:
File_error_info.failed = TRUE
File_error_info.code = Err
Resume Next
Sub http_send_status (c, code, message As String)
Dim s$
s$ = "HTTP/1.1" + Str$(code) + " " + message + CRLF
Put #Connections(c).handle, , s$
End Sub
Sub http_send_header (c, header As String, value As String)
Dim s$
s$ = header + ": " + value + CRLF
Put #Connections(c).handle, , s$
End Sub
Sub http_end_headers (c)
Put #Connections(c).handle, , CRLF
End Sub
Sub http_send_body (c, body As String)
Put #Connections(c).handle, , body
End Sub
Sub http_do_get (c)
http_do_post c
End Sub
Sub http_do_head (c)
Dim s$
s$ = "HTTP/1.1 200 OK" + CRLF + CRLF
Put #Connections(c).handle, , s$
End Sub
Sub http_do_post (c)
Dim As String action, body
action = Connections(c).request_uri
body = Connections(c).read_buf
Dim response As String
Select Case action
Case "/connect": response = HandleConnect(body)
Case "/disconnect": response = HandleDisconnect(body)
Case "/get": response = HandleGet(body)
Case "/send": response = HandleSend(body)
End Select
http_send_status c, 200, "OK"
http_send_header c, "Content-Type", "text/plain"
http_send_header c, "Content-Length", LTrim$(Str$(Len(response)))
http_send_header c, "Access-Control-Allow-Origin", "*"
http_send_header c, "Connection", "close"
http_end_headers c
http_send_body c, response
close_connection c
End Sub
Function HandleConnect$ (body As String)
AddMessage "system", body + " has entered the chat"
HandleConnect$ = Str$(cmsg - 1)
End Function
Function HandleDisconnect$ (body As String)
AddMessage "system", body + " has left the chat"
HandleDisconnect$ = Str$(cmsg - 1)
End Function
Function HandleGet$ (body As String)
Dim fmsg As Integer
Dim response As String
fmsg = Val(_Trim$(body))
response = "["
Dim As Integer i, idx
For i = fmsg + 1 To cmsg
idx = (i - 1) Mod MAX_MESSAGE + 1
response = response + CRLF + "{ " + _
Q$("from") + ":" + Q$(messages(idx).sender) + ", " + _
Q$("msg") + ":" + Q$(messages(idx).message) + ", " + _
Q$("time") + ":" + Q$(messages(idx).time) + " }"
If i < cmsg Then response = response + ","
Next i
response = response + CRLF + "]"
HandleGet$ = response
End Function
Function HandleSend$ (body As String)
Print "send: ["; body; "]"
Dim sender As String
sender = "Unknown"
Dim idx As Integer
idx = InStr(body, ":")
If idx > 0 Then
sender = Mid$(body, 1, idx - 1)
body = Mid$(body, idx + 1)
End If
AddMessage sender, _Trim$(body)
HandleSend$ = Str$(cmsg)
End Function
Sub AddMessage (sender As String, message As String)
Dim idx As Integer
cmsg = cmsg + 1
idx = (cmsg - 1) Mod MAX_MESSAGE + 1
messages(idx).sender = JSONString(sender)
messages(idx).message = JSONString(message)
messages(idx).time = Date$ + " " + Time$
LogMessage messages(idx)
End Sub
Function JSONString$ (s As String)
s = Replace(_Trim$(s), Chr$(13) + Chr$(10), "\n")
s = Replace(s, Chr$(10), "\n")
s = Replace(s, Chr$(34), "\" + Chr$(34))
JSONString$ = s
End Function
Sub LogMessage (msg As Message)
Print #1, msg.time; " - "; msg.sender
Print #1, msg.message
End Sub
Function Replace$ (s As String, searchString As String, newString As String)
Dim ns As String
Dim i As Integer
Dim slen As Integer
slen = Len(searchString)
For i = 1 To Len(s) '- slen + 1
If Mid$(s, i, slen) = searchString Then
ns = ns + newString
i = i + slen - 1
Else
ns = ns + Mid$(s, i, 1)
End If
Next i
Replace = ns
End Function
Function Q$ (value As String)
Q$ = Chr$(34) + value + Chr$(34)
End Function
Sub close_connection (c)
Close #Connections(c).handle
Connections(c).handle = 0
End Sub
Sub process_request (c)
Dim eol
Dim l As String
Do
eol = InStr(Connections(c).read_buf, CRLF)
If eol = 0 Then Exit Sub
l = Left$(Connections(c).read_buf, eol - 1)
Connections(c).read_buf = Mid$(Connections(c).read_buf, eol + 2)
If Connections(c).http_version = 0 Then 'First line not yet read
process_start_line c, l
Else
If l = "" Then
'headers complete; act upon request now
Select Case Connections(c).method
Case HTTP_GET
http_do_get c
Case HTTP_POST
http_do_post c
Case HTTP_HEAD
http_do_head c
End Select
Exit Sub
Else
process_header c, l
End If
End If
Loop
End Sub
Sub process_start_line (c, l As String)
'7230 3.1.1
'METHOD uri HTTP/x.y
Dim sp1, sp2
sp1 = InStr(l, " ")
If sp1 = 0 Then http_error 400, "Bad Request", c
'7231 4.3
Select Case Left$(l, sp1 - 1)
Case "GET"
Connections(c).method = HTTP_GET
Case "HEAD"
Connections(c).method = HTTP_HEAD
Case "POST"
Connections(c).method = HTTP_POST
Case Else
http_error 501, "Not Implemented", c
End Select
sp2 = InStr(sp1 + 1, l, " ")
If sp2 = 0 Or sp2 - sp1 = 1 Then http_error 400, "Bad Request", c
Connections(c).request_uri = Mid$(l, sp1 + 1, sp2 - sp1 - 1)
'7230 2.6
If Mid$(l, sp2 + 1, 5) <> "HTTP/" Then
http_error 400, "Bad Request", c
End If
Select Case Mid$(l, sp2 + 6)
Case "1.0"
Connections(c).http_version = HTTP_10
Case "1.1"
Connections(c).http_version = HTTP_11
Case Else
http_error 505, "HTTP Version Not Supported", c
End Select
End Sub
Sub process_header (c, l As String)
' ignoring headers for now
End Sub
Sub http_error (code, message As String, connection)
http_send_status connection, code, message
http_send_header connection, "Content-Length", "0"
http_send_header connection, "Connection", "close"
http_end_headers connection
close_connection connection
Http_error_info.code = code
Http_error_info.message = message
Http_error_info.connection = connection
Error 100
End Sub
If you want to connect to your own server just change the address at the top of the chat window to http://localhost:8080 (or whatever port you decide to use).
It was definitely an interesting exercise and gave me a number of ideas about new web functionality that I might want to add to QBJS's standard libraries.
Here is the client code in case you want to hot rod that side:
Code: (Select All) Import Dom From "lib/web/dom.bas"
Dim Shared As Object txtAddress, txtUsername, btnConnect, textbox, msgPanel
Dim Shared lastMsg As Integer
Dim Shared username As String
Dim Shared connected As Integer
Dim Shared refreshing As Integer
Dim Shared sending As Integer
Dim Shared sndMsg As Integer
_Title "QB Chat"
sndMsg = _SndOpen("https://raw.githubusercontent.com/boxgaming/qbjs/main/samples/apps/new-message.ogg")
InitUI
SetTimeout sub_Refresh, 1000
' HTTP Event Handlers
' ---------------------------------------------------------------
Sub OnConnect (response)
If Not connected Then
lastMsg = Val(response)
connected = -1
txtAddress.disabled = true
txtUsername.disabled = true
btnConnect.innerText = "Disconnect"
Else
connected = 0
txtAddress.disabled = false
txtUsername.disabled = false
btnConnect.innerText = "Connect"
End If
End Sub
Sub OnSend (response)
sending = 0
End Sub
Sub Refresh
If connected And Not refreshing Then
refreshing = -1
HttpSend txtAddress.value + "/get", "POST", lastMsg, sub_OnRefresh
End If
SetTimeout sub_Refresh, 1000
End Sub
Sub OnRefresh (response)
Dim playSound As Integer
Dim res As Object
res = JSON.parse(response)
Dim i as Integer
For i = 0 To res.length-1
AddMessage res[i]
If res[i].from <> username Then
playSound = -1
End If
Next i
lastMsg = lastMsg + res.length
msgPanel.scrollTop = msgPanel.scrollHeight;
If playSound Then _SndPlay sndMsg
refreshing = 0
End Sub
Sub OnRefresError
refreshing = 0
End Sub
' UI Event Handlers
' ----------------------------------------------------------
Sub OnClickConnect
If txtUsername.value = "" Then
Dom.Alert "Enter a username"
Exit Sub
End If
If Not connected Then
username = txtUsername.value
Print "Setting username: [" + username + "]"
HttpSend txtAddress.value + "/connect", "POST", username, sub_OnConnect
Else
HttpSend txtAddress.value + "/disconnect", "POST", username, sub_OnConnect
End If
End Sub
Function OnKeyPress (event)
If event.keyCode = 13 Then
'Print textbox.value
Dim msg as String
msg = _Trim$(textbox.value)
If msg <> "" Then SendMessage msg
OnKeyPress = false
End If
End Function
Sub SendMessage (msg As String)
Dim timeout As Integer
While sending And timeout < 1000
_Delay .01
timeout = timeout + 1
Wend
sending = -1
Dim body As String
body = username + ":" + _Trim$(textbox.value)
'Print "sending: [ " + body + " ]"
HttpSend txtAddress.value + "/send", "POST", body, sub_OnSend
textbox.value = ""
End Sub
Sub OnResize
'msgPanel.height = Dom.Container().height - 100
msgPanel.style.height = (_ResizeHeight - 200) + "px"
End Sub
' ----------------------------------------------------
Sub InitUI
Dim As Object container, panel, btnSend, apanel
Dom.GetImage(0).style.display = "none"
container = Dom.Container
container.style.letterSpacing = "normal"
container.style.backgroundColor = "#333"
Dom.Event window, "resize", sub_OnResize
' Create the login panel
apanel = Dom.Create("div")
apanel.style.display = "grid"
apanel.style.margin = "auto 15%"
apanel.style.textAlign = "left"
apanel.style.fontWeight = "bold"
Dom.Create "div", apanel, "Host"
Dom.Create "div", apanel, "Username"
Dom.Create "div", apanel
apanel.style.gridTemplateColumns = "auto auto auto"
txtAddress = Dom.Create("input", apanel, "https://chat.boxgaming.co")
txtUsername = Dom.Create("input", apanel)
btnConnect = Dom.Create("button", apanel, "Connect")
Dom.Event btnConnect, "click", sub_OnClickConnect
' Create the message window
msgPanel = Dom.Create("div")
msgPanel.style.backgroundColor = "#444"
msgPanel.style.overflowY = "auto"
msgPanel.style.height = "300px"
msgPanel.style.margin = "auto 15%"
msgPanel.style.textAlign = "left"
msgPanel.style.padding = "10px"
' Create send message control
Dim sendLabel As Object
panel = Dom.Create("div")
panel.style.margin = "auto 15%"
sendLabel = Dom.Create("div", panel, "Send Message")
sendLabel.style.textAlign = "left"
sendLabel.style.fontWeight = "bold"
sendLabel.style.backgroundColor = "#666"
sendLabel.style.padding = "4px"
sendLabel.style.color = "#ccc"
textbox = Dom.Create("textarea", panel)
textbox.style.width = "100%"
textbox.style.height = "100px"
Dom.Event textbox, "keydown", func_OnKeyPress
OnResize
End Sub
Sub AddMessage (msg As Object)
Dim As Object mc, s, t, m
mc = Dom.Create("div", msgPanel)
mc.style.marginBottom = "10px"
s = Dom.Create("div", mc)
If msg.from = "system" Then
s.style.color = "#00f4af"
Else
s.style.color = "#00aff4"
End If
s.style.fontWeight = "bold"
s.innerHTML = msg.from
t = Dom.Create("span", s)
t.style.color = "#999"
t.style.fontWeight = "normal"
t.style.marginLeft = "8px"
t.style.fontSize = ".8em"
t.innerHTML = msg.time
m = Dom.Create("div", mc)
m.style.color = "#efefef"
m.style.whiteSpace = "pre"
m.innerHTML = msg.msg
End Sub
Sub HttpSend(url, method, message, callbackFn, errorCallbackFn)
$If Javascript Then
const client = new XMLHttpRequest();
client.open(method, url);
client.setRequestHeader("Content-Length", message.length);
client.send(message);
client.onreadystatechange = function() {
if (this.readyState == 4) {
if (this.status == 200) {
if (callbackFn) {
callbackFn(this.responseText);
}
}
else { // assume any other status is an error
if (errorCallbackFn) {
errorCallbackFn(this.responseText);
}
}
}
};
$End If
End Sub
Sub SetTimeout(callbackFn, millis)
$If Javascript Then
setTimeout(callbackFn, millis);
$End If
End Sub
![[Image: screenshot.png]](https://i.ibb.co/tBjVnJ1/screenshot.png)
|
|
|
|
| DAY 037: FREEFILE |
|
Posted by: Pete - 12-17-2022, 12:30 PM - Forum: Keyword of the Day!
- Replies (8)
|
|
We interrupt your regularly scheduled program for this brief commercial message!
Tired of spending your hard earned money on an overly-priced file? Well now you can avoid those high fees with this tried and true QB Keyword of the Day, FREEFILE!
SYNTAX filenum& = FREEFILE
Usage: Retrieves the next available open file handle.
So what's the benefit?
Well, for most small apps, we just code...
Code: (Select All) OPEN "myfile.dat" FOR INPUT AS #1
'De Foo Foo Foo De blah, blah, blah...
CLOSE #1
However, let's say we make a big app, that uses 30 files, and some of them, depending on operations being called, stay opened!
Hmm, now keeping track of all those file numbers would require considerable thought. In fact, the only way to not to get into trouble, by using a file number which is still opened, would be to assign a unique number to each file operation, or... do it the easy way by letting the system figure it out for us. Well, that's exactly what FREEFILE does!
But first, please note: Even though we can assign a variable to FREEFILE before we OPEN the file, "You actually have to Open the file to trigger a value." Thanks, Dimster. So
please make sure you use good coding practice and associate each FREEFILE statement with each corresponding OPEN statement.
Code: (Select All) DEFLNG f
ON Rob GOSUB ThePolice
ThePolice:
filenum1 = FREEFILE
OPEN "myfile-abc.dat" FOR INPUT AS filenum1
'De Foo Foo Foo De blah, blah, blah...
filenum2 = FREEFILE
OPEN "myfile-def.dat" FOR INPUT AS filenum2
'Is all I will output to you...
IF mydata$ = "EOF" THEN CLOSE #filenum1
filenum3 = FREEFILE
OPEN "myfile-ghi.dat" FOR INPUT AS filenum3
'De Foo Foo Foo De blah, blah, blah...
filenum4 = FREEFILE
OPEN "myfile-jkl.dat" FOR INPUT AS filenum4
' And now this FREEFILE demo's through.
CLOSE #filenum1, #filenum2, #filenum3, #filenum4
RETURN
So in the code example above, FREEFILE will assign the file handles either as 1, 2, 3, and 4 or, if mydata$ = "EOF" and the first file gets closed... 1, 2, 1, 3. Remember, FREEFILE is tracking your file use, and depending on conditional statements, like in our above example, your file numbering results will vary. Also, always remember to use good coding practices. Don't have a list of pre-assigned FREEFILE assignments, at the top of your program, without each corresponding file actually being opened. You will get duplicate file handles.
Oh, and if you forget to add the # symbol, don't worry; it's optional. I just like using it as a search marker. What;s that? You don't need no stinkin' search marker. Alrighty then, save yourself some typing by omitting it. Like I always say to my wife, "It takes a big man to omit when he's wrong!" Okay Steve, enough with the "big man" jokes, already...
And now back to your regularly scheduled program, DEEP Thoughts, by jack handy...
Do woke coders OPEN files as non-BINARY?
Pete
|
|
|
|
| Snowman screen saver playing 17 MIDI Christmas songs |
|
Posted by: Dav - 12-17-2022, 12:23 PM - Forum: Christmas Code
- Replies (11)
|
 |
I updated my old Snowman screen saver to test the experimental (and $UNSTABLE) MIDI playback feature of QB64PE. This is a simple looping animation that plays 17 different Christmas songs continuously. It's just something nice to have on the screen whenever you need a snowy atmosphere.
It sure is nice to have MIDI playback in QB64PE, the only negative is that it takes a rather long time to open a MIDI file. Loading these 17 MIDI files takes a couple minutes on my PC. I found that MIDI feature is most stable when opening MIDI files at the beginning and leaving them open throughout the program. Opening/Closing them over and over in the program caused hangups, so I ended up just loading them all at startup and doing a _SNDSTOP when changing to a start new song.
I'll post the code here for the curious, but you will need to download the archive to run it. You will need QB64PE v3.2 or higher to use the $MIDISOUNDFONT metacommand. I haven't tested this in Linux yet, but I guess it will work if the Linux version also supports the new MIDI metacommand.
- Dav
snowman-v103.zip (Size: 710.24 KB / Downloads: 49)
Code: (Select All) '==========
'SNOWMAN.BAS v1.03
'===========
'Play Snowman animation while playing 17 Christmas songs.
'Coded by Dav for QB64PE, DEC/2022
'ALL MEDIA SOURCES FOUND IN PUBLIC DOMAIN
'
'=======================================================================
'NOTE: THIS PROGRAM REQUIRES QB64-PE v3.2 OR HIGHER TO RUN & USE MIDI
'=======================================================================
'
'CONTROLS:
' WHILE PLAYING, USE LEFT & RIGHT ARROWS TO SKIP SONGS.
' ANY OTHER KEY QUITS THE SAVER
'
'The screen saver will start playing a random song. You an skip up/down
'to different songs using the left/right arrow keys. Pressing any other
'key will quit the program.
'
'NOTE: It takes a minute or two to load all the MIDI files on startup.
'Please be patient while they load, and enjoythe Christmas screen saver.
'
'=======================================================================
$UNSTABLE:MIDI
PRINT "=============================="
PRINT "SNOWMAN SCREENSAVER FOR QB64PE"
PRINT "(please wait while files load)"
PRINT "=============================="
PRINT
PRINT "Init MIDI soundfont...";
$MIDISOUNDFONT:DEFAULT
PRINT "OK!"
'=== Check the animation file
PRINT "Checking animation file...";
file$ = "snowman.dat"
OPEN file$ FOR BINARY AS #1
IF LOF(1) = 0 THEN
PRINT "SNOWMAN.DAT NOT FOUND!"
CLOSE 1: KILL file$
END
END IF
IF LOF(1) <> 800528 THEN
PRINT "INVALID SNOWMAN.DAT!"
CLOSE 1
END
END IF
PRINT "OK!"
'=== Build the MIDI song list..
trackmax = 17 '17 midi files
DIM song$(1 TO trackmax), songhand&(1 TO trackmax)
'name each one
song$(1) = "frosty.mid"
song$(2) = "hark.mid"
song$(3) = "away.mid"
song$(4) = "angels.mid"
song$(5) = "carol.mid"
song$(6) = "joy.mid"
song$(7) = "deck.mid"
song$(8) = "wethree.mid"
song$(9) = "holynite.mid"
song$(10) = "godrest.mid"
song$(11) = "itcame.mid"
song$(12) = "ohcome.mid"
song$(13) = "noel.mid"
song$(14) = "silent.mid"
song$(15) = "town.mid"
song$(16) = "jingle.mid"
song$(17) = "wewish.mid"
FOR s = 1 TO trackmax
PRINT "Loading MIDI file"; s; "of"; trackmax; ": "; song$(s); "...";
songhand&(s) = _SNDOPEN(song$(s), "stream")
IF songhand&(s) = 0 THEN
PRINT "Error opening file: "; song$(s)
END
END IF
PRINT "OK!"
NEXT
'=== start playing a random track
RANDOMIZE TIMER
track = INT(RND * trackmax) + 1
_SNDPLAY songhand&(track)
SCREEN 13: _FULLSCREEN _SQUAREPIXELS , _SMOOTH
DO
SEEK 1, 129
FOR f% = 1 TO 15
FF& = SEEK(1): FRM$ = INPUT$(16, 1)
FrameSize& = CVL(MID$(FRM$, 1, 4))
chunks% = CVI(MID$(FRM$, 7, 2))
d$ = INKEY$
IF d$ <> "" THEN
SELECT CASE d$
CASE CHR$(0) + CHR$(77)
_SNDSTOP songhand&(track)
track = track + 1
IF track > trackmax THEN track = 1
_SNDPLAY songhand&(track)
CASE CHR$(0) + CHR$(75)
_SNDSTOP songhand&(track)
track = track - 1
IF track < 1 THEN track = trackmax
_SNDPLAY songhand&(track)
CASE ELSE: EXIT DO
END SELECT
END IF
FOR C% = 1 TO chunks%
Fpos& = SEEK(1)
CD$ = INPUT$(6, 1)
ChunkSize& = CVL(MID$(CD$, 1, 4))
ChunkType% = CVI(MID$(CD$, 5, 2))
Fpos& = Fpos& + ChunkSize&
SELECT CASE ChunkType%
CASE 11
Clr% = 0
paks% = ASC(INPUT$(2, 1))
FOR d% = 1 TO paks%
skip% = ASC(INPUT$(1, 1))
change% = ASC(INPUT$(1, 1))
IF change% = 0 THEN change% = 256
Clr% = Clr% + skip%
FOR s% = 1 TO change%
OUT &H3C8, Clr%
OUT &H3C9, ASC(INPUT$(1, 1))
OUT &H3C9, ASC(INPUT$(1, 1))
OUT &H3C9, ASC(INPUT$(1, 1))
Clr% = Clr% + 1
NEXT
NEXT
CASE 12
skip% = CVI(INPUT$(2, 1))
change% = CVI(INPUT$(2, 1))
FOR y% = skip% TO change% + (skip% - 1)
ppos& = SEEK(1)
C$ = INPUT$(500, 1): m% = 1
paks% = ASC(MID$(C$, m%, 1)): m% = m% + 1: x% = 0
FOR d% = 1 TO paks%
s% = ASC(MID$(C$, m%, 1))
p% = ASC(MID$(C$, m% + 1, 1))
m% = m% + 2: x% = x% + s%
IF p% > 127 THEN
p% = (256 - p%)
LINE (x%, y%)-STEP(p% - 1, 0), ASC(MID$(C$, m%, 1))
x% = x% + p%: m% = m% + 1
ELSE
Row$ = MID$(C$, m%, p%)
m% = m% + p%
FOR g% = 0 TO p% - 1
PSET (x% + g%, y%), ASC(MID$(Row$, g% + 1, 1))
NEXT
x% = x% + p%
END IF
NEXT
SEEK #1, ppos& + m% - 1: C$ = ""
NEXT
CASE 16
x% = 0
FOR y% = 0 TO 199
Row$ = INPUT$(320, 1): p% = 320
FOR g% = 0 TO p% - 1
PSET (x% + g%, y%), ASC(MID$(Row$, g% + 1, 1))
NEXT
NEXT
CASE ELSE: CLOSE 1: EXIT DO
END SELECT
SEEK #1, Fpos&
NEXT
SEEK 1, FF& + FrameSize&
_DISPLAY
_LIMIT 12
NEXT
IF NOT _SNDPLAYING(songhand&(track)) THEN
_SNDSTOP songhand&(track)
track = track + 1
IF track > trackmax THEN track = 1
_SNDPLAY songhand&(track)
END IF
LOOP
_SNDSTOP songhand&(track)
_SNDCLOSE songhand&(track)
CLOSE 1
SYSTEM
|
|
|
|
| wrangling chatgpt to get it to write a more complex program - Spacewar! |
|
Posted by: madscijr - 12-16-2022, 09:18 PM - Forum: General Discussion
- Replies (8)
|
 |
So the sky's the limit, right? Why not shoot for the moon, or at least Space!
Here's what happend when I asked it to write Spacewar!
Code: (Select All) Can you write a 2 player Spacewar! game in QB64 where the players are controlled with the keyboard, (player 1 controls are: up arrow = thrust, down arrow = warp, left arrow = rotate left, right arrow = rotate right, ENTER = fire; player 2 controls are: A = rotate left, D = rotate right, S = warp, W = thrust, E = fire), and includes 2 additional computer controlled players, and 2 suns?
Sure! Here is a simple Spacewar! game in QB64 that allows two players to control their ships with the keyboard, and includes two additional computer-controlled players and two suns:
' Declare constants for the screen width and height
CONST SCREEN_WIDTH = 640
CONST SCREEN_HEIGHT = 480
' Declare constants for the player colors
CONST PLAYER_1_COLOR = 15
CONST PLAYER_2_COLOR = 11
CONST CPU_PLAYER_COLOR = 7
' Declare constants for the sun colors
CONST SUN_1_COLOR = 12
CONST SUN_2_COLOR = 14
' Declare constants for the player controls
CONST PLAYER_1_UP = 72
CONST PLAYER_1_DOWN = 80
CONST PLAYER_1_LEFT = 75
CONST PLAYER_1_RIGHT = 77
CONST PLAYER_1_FIRE = 13
CONST PLAYER_2_UP = 87
CONST PLAYER_2_DOWN = 83
CONST PLAYER_2_LEFT = 65
CONST PLAYER_2_RIGHT = 68
CONST PLAYER_2_FIRE = 69
' Declare constants for the game states
CONST GAME_STATE_INITIALIZING = 0
CONST GAME_STATE_PLAYING = 1
CONST GAME_STATE_PAUSED = 2
CONST GAME_STATE_OVER = 3
' Declare variables for the game state and the player scores
DIM GameState AS INTEGER
DIM Player1Score AS INTEGER
DIM Player2Score AS INTEGER
' Declare a type for the players
TYPE Player
X AS SINGLE
Y AS SINGLE
Angle AS SINGLE
Speed AS SINGLE
RotationSpeed AS SINGLE
Color AS INTEGER
IsComputerControlled AS BOOLEAN
END TYPE
' Declare variables for the players
DIM Player1 AS Player
DIM Player2 AS Player
DIM CPUPlayer1 AS Player
DIM CPUPlayer2 AS Player
' Declare a type for the suns
TYPE Sun
X AS SINGLE
Y AS SINGLE
Mass AS SINGLE
Color AS INTEGER
END TYPE
' Declare variables for the suns
DIM Sun1 AS Sun
DIM Sun2 AS Sun
' Initialize the game
SUB InitializeGame
' Set the game state to initializing
GameState = GAME_STATE_INITIALIZING
' Initialize the player scores
Player1Score = 0
Player2Score = 0
' Initialize player 1
Player1.X = SCREEN_WIDTH / 4
Player1.Y = SCREEN_HEIGHT / 2
Player1.Angle = 0
Player1.Speed = 0
Player1.RotationSpeed = 0
Player1.Color = PLAYER_1_COLOR
Player1.IsComputerControlled = False
' Initialize player 2
Player2.X = SCREEN_WIDTH * 3 / 4
Player2.Y = SCREEN_HEIGHT / 2
Player2.Angle = 180
Player2.Speed = 0
Player2.R
Wait! You're not done! What if we ask it to finish? We'll even say "please"!
Code: (Select All) Would you please show the rest of the program?
Certainly! Here is the rest of the Spacewar! game in QB64 that allows two players to control their ships with the keyboard, and includes two additional computer-controlled players and two suns:
' Update the player's position and angle based on their speed and rotation speed
SUB UpdatePlayer(Player AS Player)
' Update the player's angle
Player.Angle = Player.Angle + Player.RotationSpeed
' Keep the angle between 0 and 360 degrees
IF Player.Angle < 0 THEN
Player.Angle = Player.Angle + 360
ELSEIF Player.Angle > 360 THEN
Player.Angle = Player.Angle - 360
END IF
' Calculate the player's new position based on their speed and angle
Player.X = Player.X + Player.Speed * COS(Player.Angle)
Player.Y = Player.Y + Player.Speed * SIN(Player.Angle)
' Keep the player within the screen bounds
IF Player.X < 0 THEN
Player.X = 0
ELSEIF Player.X > SCREEN_WIDTH THEN
Player.X = SCREEN_WIDTH
END IF
IF Player.Y < 0 THEN
Player.Y = 0
ELSEIF Player.Y > SCREEN_HEIGHT THEN
Player.Y = SCREEN_HEIGHT
END IF
END SUB
' Update the player's speed based on their thrust
SUB UpdatePlayerThrust(Player AS Player, IsThrusting AS BOOLEAN)
' If the player is thrusting, increase their speed
IF IsThrusting THEN
Player.Speed = Player.Speed + 0.1
' If the player is not thrusting, decrease their speed
ELSE
Player.Speed = Player.Speed - 0.1
END IF
' Limit the player's speed
IF Player.Speed < 0 THEN
Player.Speed = 0
ELSEIF Player.Speed > 5 THEN
Player.Speed = 5
END IF
END SUB
' Update the player's rotation speed based on their rotation
SUB UpdatePlayerRotation(Player AS Player, IsRotatingLeft AS BOOLEAN, IsRotatingRight AS BOOLEAN)
' If the player is rotating left, increase their rotation speed
IF Is
OK, it remembered what we asked it, and sort of continued, but not where it left off!
Shall we persevere?
Code: (Select All) Would you please show the rest of the program?
Certainly! Here is the rest of the Spacewar! game in QB64 that allows two players to control their ships with the keyboard, and includes two additional computer-controlled players and two suns:
' Update the computer-controlled players
SUB UpdateCPUPlayers
' Update player 1
UpdateCPUPlayer(CPUPlayer1)
' Update player 2
UpdateCPUPlayer(CPUPlayer2)
END SUB
' Update a computer-controlled player
SUB UpdateCPUPlayer(Player AS Player)
' Calculate the distance to player 1
DX = Player1.X - Player.X
DY = Player1.Y - Player.Y
DistanceToPlayer1 = SQR(DX * DX + DY * DY)
' Calculate the distance to player 2
DX = Player2.X - Player.X
DY = Player2.Y - Player.Y
DistanceToPlayer2 = SQR(DX * DX + DY * DY)
' Calculate the distance to the nearest sun
DX = Sun1.X - Player.X
DY = Sun1.Y - Player.Y
DistanceToSun1 = SQR(DX * DX + DY * DY)
DX = Sun2.X - Player.X
DY = Sun2.Y - Player.Y
DistanceToSun2 = SQR(DX * DX + DY * DY)
If DistanceToSun1 < DistanceToSun2 Then
DistanceToNearestSun = DistanceToSun1
Else
DistanceToNearestSun = DistanceToSun2
End If
' If the player is far from the other players and the suns, move randomly
If DistanceToPlayer1 > 100 And DistanceToPlayer2 > 100 And DistanceToNearestSun > 100 Then
' Choose a random angle and set the player's rotation speed
TargetAngle = RND * 360
If TargetAngle > Player.Angle Then
Player.RotationSpeed = 0.5
Else
Player.RotationSpeed = -0.5
End If
' If the player is close to a player, move towards them
ElseIf DistanceToPlayer1 < DistanceToPlayer2 Then
' Calculate the angle to player 1 and set the player's rotation speed
TargetAngle = ATN2(DY, DX) * 180 / PI
If TargetAngle > Player.Angle Then
Player.RotationSpeed = 0.5
Else
Player.RotationSpeed = -0.5
End If
Else
' Calculate the angle to player 2 and set the player's rotation speed
TargetAngle = ATN2(DY, DX) * 180 / PI
If TargetAngle > Player.Angle Then
Player.RotationSpeed = 0.5
Else
Don't leave me hanging, chatgpt!
Code: (Select All) Would you please show the rest of the program?
Certainly! Here is the rest of the Spacewar! game in QB64 that allows two players to control their ships with the keyboard, and includes two additional computer-controlled players and two suns:
' Update the player's speed based on the gravitational pull of the suns
SUB UpdatePlayerGravity(Player AS Player)
' Calculate the distance and angle to sun 1
DX = Sun1.X - Player.X
DY = Sun1.Y - Player.Y
DistanceToSun1 = SQR(DX * DX + DY * DY)
AngleToSun1 = ATN2(DY, DX) * 180 / PI
' Calculate the distance and angle to sun 2
DX = Sun2.X - Player.X
DY = Sun2.Y - Player.Y
DistanceToSun2 = SQR(DX * DX + DY * DY)
AngleToSun2 = ATN2(DY, DX) * 180 / PI
' Calculate the gravitational force from sun 1
GravitationalForce1 = Sun1.Mass / DistanceToSun1
' Calculate the gravitational force from sun 2
GravitationalForce2 = Sun2.Mass / DistanceToSun2
' Calculate the total gravitational force
TotalGravitationalForce = GravitationalForce1 + GravitationalForce2
' Calculate the gravitational acceleration
GravitationalAcceleration = TotalGravitationalForce / Player.Mass
' Calculate the gravitational speed
GravitationalSpeed = GravitationalAcceleration * 0.1
' Calculate the new speed based on the gravitational speed
NewSpeed = Player.Speed + GravitationalSpeed
' Limit the player's speed
If NewSpeed < 0 Then
NewSpeed = 0
ElseIf NewSpeed > 5 Then
NewSpeed = 5
End If
' Set the player's speed
Player.Speed = NewSpeed
END SUB
' Draw a player
SUB DrawPlayer(Player AS Player)
' Calculate the points of the triangle representing the player's ship
X1 = Player.X + 5 * COS
Aye aye aye! It doesn't seem to always know how to (or want to) continue from where it left off, does it?
What if we're more specific?
Code: (Select All) would you please show the full SUB UpdatePlayerRotation ?
Certainly! Here is the full UpdatePlayerRotation subroutine in the Spacewar! game in QB64 that allows two players to control their ships with the keyboard, and includes two additional computer-controlled players and two suns:
' Update the player's rotation speed based on their rotation
SUB UpdatePlayerRotation(Player AS Player, IsRotatingLeft AS BOOLEAN, IsRotatingRight AS BOOLEAN)
' If the player is rotating left, increase their rotation speed
IF IsRotatingLeft THEN
Player.RotationSpeed = Player.RotationSpeed + 0.5
' If the player is rotating right, decrease their rotation speed
ELSEIF IsRotatingRight THEN
Player.RotationSpeed = Player.RotationSpeed - 0.5
' If the player is not rotating, decrease their rotation speed
ELSE
Player.RotationSpeed = Player.RotationSpeed - 0.1
END IF
' Limit the player's rotation speed
IF Player.RotationSpeed < -2 THEN
Player.RotationSpeed = -2
ELSEIF Player.RotationSpeed > 2 THEN
Player.RotationSpeed = 2
END IF
END SUB
This subroutine updates the player's rotation speed based on whether they are rotating left, rotating right, or not rotating at all. If the player is rotating left, their rotation speed is increased. If the player is rotating right, their rotation speed is decreased. If the player is not rotating, their rotation speed is decreased. The rotation speed is limited to a maximum of 2 and a minimum of -2.
I hope this helps! Let me know if you have any questions or if you need further assistance.
Maybe being specific is the key? Let's try to get it to spit out the rest of "teh codez"!
Code: (Select All) Thank You. Would you please show the full SUB UpdateCPUPlayer ?
Certainly! Here is the full UpdateCPUPlayer subroutine in the Spacewar! game in QB64 that allows two players to control their ships with the keyboard, and includes two additional computer-controlled players and two suns:
' Update a computer-controlled player
SUB UpdateCPUPlayer(Player AS Player)
' Calculate the distance to player 1
DX = Player1.X - Player.X
DY = Player1.Y - Player.Y
DistanceToPlayer1 = SQR(DX * DX + DY * DY)
' Calculate the distance to player 2
DX = Player2.X - Player.X
DY = Player2.Y - Player.Y
DistanceToPlayer2 = SQR(DX * DX + DY * DY)
' Calculate the distance to the nearest sun
DX = Sun1.X - Player.X
DY = Sun1.Y - Player.Y
DistanceToSun1 = SQR(DX * DX + DY * DY)
DX = Sun2.X - Player.X
DY = Sun2.Y - Player.Y
DistanceToSun2 = SQR(DX * DX + DY * DY)
If DistanceToSun1 < DistanceToSun2 Then
DistanceToNearestSun = DistanceToSun1
Else
DistanceToNearestSun = DistanceToSun2
End If
' If the
Argh. Why does it output in such small chunks?? How useless is that?!
But we must see this thing through!
Code: (Select All) would you please show the rest of the routine?
Certainly! Here is the rest of the UpdateCPUPlayer subroutine in the Spacewar! game in QB64 that allows two players to control their ships with the keyboard, and includes two additional computer-controlled players and two suns:
' If the player is far from the other players and the suns, move randomly
If DistanceToPlayer1 > 100 And DistanceToPlayer2 > 100 And DistanceToNearestSun > 100 Then
' Choose a random angle and set the player's rotation speed
TargetAngle = RND * 360
If TargetAngle > Player.Angle Then
Player.RotationSpeed = 0.5
Else
Player.RotationSpeed = -0.5
End If
' If the player is close to a player, move towards them
ElseIf DistanceToPlayer1 < DistanceToPlayer2 Then
' Calculate the angle to player 1 and set the player's rotation speed
TargetAngle = ATN2(DY, DX) * 180 / PI
If TargetAngle > Player.Angle Then
Player.RotationSpeed = 0.5
Else
Player.RotationSpeed = -0.5
End If
Else
' Calculate the angle to player 2 and set the player's rotation speed
TargetAngle = ATN2(DY, DX) * 180 / PI
If TargetAngle > Player.Angle Then
Player.RotationSpeed = 0.5
Else
Player.RotationSpeed = -0.5
End If
End If
' Set the player's thrust based on their distance to the nearest sun
If DistanceToNearestSun < 50 Then
Player.IsThrusting = False
Else
Player.IsThrusting = True
End If
END SUB
This subroutine updates the position and angle of a computer-controlled player based on their distance to the other players and the suns. If the player is far from the other players and the suns, they choose a random angle and rotate towards it. If the player is close to a player, they move towards them. If the player is close to a sun, they stop thrusting.
I hope this helps! Let me know if you have any questions or if you need further assistance.
OK then! We'll keep soldiering on, then...
Maybe the "p" word isn't enough, let's also be sure to say "thank you"!
Code: (Select All) Thank you. Would you please show the full SUB DrawPlayer?
Certainly! Here is the full DrawPlayer subroutine in the Spacewar! game in QB64 that allows two players to control their ships with the keyboard, and includes two additional computer-controlled players and two suns:
' Draw a player
SUB DrawPlayer(Player AS Player)
' Calculate the points of the triangle representing the player's ship
X1 = Player.X + 5 * COS(Player.Angle)
Y1 = Player.Y + 5 * SIN(Player.Angle)
X2 = Player.X + 5 * COS(Player.Angle + 120)
Y2 = Player.Y + 5 * SIN(Player.Angle + 120)
X3 = Player.X + 5 * COS(Player.Angle + 240)
Y3 = Player.Y + 5 * SIN(Player.Angle + 240)
' Draw the triangle representing the player's ship
LINE (X1, Y1)-(X2, Y2), Player.Color
LINE (X2, Y2)-(X3, Y3), Player.Color
LINE (X3, Y3)-(X1, Y1), Player.Color
' If the player is thrusting, draw a flame behind their ship
If Player.IsThrusting Then
LINE (X2, Y2)-(X2 + 2 * COS(Player.Angle + 180), Y2 + 2 * SIN(Player.Angle + 180)), Player.Color
LINE (X3, Y3)-(X3 + 2 * COS(Player.Angle + 180), Y3 + 2 * SIN(Player.Angle + 180)), Player.Color
End If
END SUB
This subroutine draws a triangle representing the player's ship and, if the player is thrusting, a flame behind their ship. The points of the triangle are calculated using the player's angle and the coordinates of the player's ship. The triangle is then drawn using the player's color. If the player is thrusting, two lines are drawn behind the triangle to represent the flame.
I hope this helps! Let me know if you have any questions or if you need further assistance.
And on...
Code: (Select All) Thank you. Would you please show the rest of the program?
Certainly! Here is the rest of the Spacewar! game in QB64 that allows two players to control their ships with the keyboard, and includes two additional computer-controlled players and two suns:
' Initialize the players
Player1.X = 100
Player1.Y = 100
Player1.Angle = 0
Player1.RotationSpeed = 0
Player1.Speed = 0
Player1.IsThrusting = False
Player1.Mass = 10
Player1.Color = RGB(255, 0, 0)
Player2.X = 200
Player2.Y = 100
Player2.Angle = 0
Player2.RotationSpeed = 0
Player2.Speed = 0
Player2.IsThrusting = False
Player2.Mass = 10
Player2.Color = RGB(0, 255, 0)
CPUPlayer1.X = 100
CPUPlayer1.Y = 200
CPUPlayer1.Angle = 0
CPUPlayer1.RotationSpeed = 0
CPUPlayer1.Speed = 0
CPUPlayer1.IsThrusting = False
CPUPlayer1.Mass = 10
CPUPlayer1.Color = RGB(0, 0, 255)
CPUPlayer2.X = 200
CPUPlayer2.Y = 200
CPUPlayer2.Angle = 0
CPUPlayer2.RotationSpeed = 0
CPUPlayer2.Speed = 0
CPUPlayer2.IsThrusting = False
CPUPlayer2.Mass = 10
CPUPlayer2.Color = RGB(255, 255, 0)
' Initialize the suns
Sun1.X = 150
Sun1.Y = 150
Sun1.Mass = 1000
Sun2.X = 250
Sun2.Y = 150
Sun2.Mass = 1000
' Set the screen update rate
SCREEN UpdateRate(30)
' Set the window title
WINDOW Title$ = "Spacewar!"
' Set the window size
WINDOW Width = 320, Height = 240
DO
' Clear the screen
CLS
' Update the players
UpdatePlayerRotation(Player1, GetKeyState(VK_LEFT) AND 1, GetKeyState(VK_RIGHT) AND 1)
UpdatePlayerRotation(Player2, GetKeyState(VK_A) AND 1, GetKeyState(VK_D) AND 1)
UpdatePlayerThrust(Player1, GetKeyState(VK_UP) AND 1)
UpdatePlayerThrust(Player2, GetKeyState(VK_W) AND 1)
UpdatePlayerPosition(Player1)
UpdatePlayerPosition(Player2)
UpdateCPUPlayers
UpdatePlayerGravity(Player1)
UpdatePlayerGravity(Player2)
UpdatePlayerGravity(CPUPlayer1)
UpdatePlayerGravity(CPUPlayer2)
' Draw the players
DrawPlayer(Player1)
DrawPlayer(Player2)
DrawPlayer(CPUPlayer1)
DrawPlayer(CPUPlayer2)
' Draw the suns
CIRCLE (Sun1.X, Sun1.Y), 10, RGB(255, 255, 0)
CIRCLE (Sun2.X, Sun2.Y), 10, RGB(255, 255, 0)
' Check for player collisions
If PlayerCollision(Player1, Player2) Then
' End the game
OK, now it's initializing values, this looks like the main (global) code.
Can we get the rest out of this thing?
What if we're specific about telling it to NOT STOP until it's DONE?
Code: (Select All) Thank you. Would you please show the rest of the program? Don't stop until you have shown the whole thing.
Certainly! Here is the rest of the Spacewar! game in QB64 that allows two players to control their ships with the keyboard, and includes two additional computer-controlled players and two suns:
' End the game
EXIT DO
End If
If PlayerCollision(Player1, CPUPlayer1) Then
' End the game
EXIT DO
End If
If PlayerCollision(Player1, CPUPlayer2) Then
' End the game
EXIT DO
End If
If PlayerCollision(Player2, CPUPlayer1) Then
' End the game
EXIT DO
End If
If PlayerCollision(Player2, CPUPlayer2) Then
' End the game
EXIT DO
End If
' Check for player and sun collisions
If PlayerSunCollision(Player1, Sun1) Then
' End the game
EXIT DO
End If
If PlayerSunCollision(Player1, Sun2) Then
' End the game
EXIT DO
End If
If PlayerSunCollision(Player2, Sun1) Then
' End the game
EXIT DO
End If
If PlayerSunCollision(Player2, Sun2) Then
' End the game
EXIT DO
End If
If PlayerSunCollision(CPUPlayer1, Sun1) Then
' End the game
EXIT DO
End If
If PlayerSunCollision(CPUPlayer1, Sun2) Then
' End the game
EXIT DO
End If
If PlayerSunCollision(CPUPlayer2, Sun1) Then
' End the game
EXIT DO
End If
If PlayerSunCollision(CPUPlayer2, Sun2) Then
' End the game
EXIT DO
End If
' Check for player shots
If GetKeyState(VK_RETURN) AND 1 Then
Player1.Shots.AddNew
Player1.Shots(Player1.Shots.Count).X = Player1.X + 5 * COS(Player1.Angle)
Player1.Shots(Player1.Shots.Count).Y = Player1.Y + 5 * SIN(Player1.Angle)
Player1.Shots(Player1.Shots.Count).Angle = Player1.Angle
End If
If GetKeyState(VK_E) AND 1 Then
Player2.Shots.AddNew
Player2.Shots(Player2.Shots.Count).X = Player2.X + 5 * COS(Player2.Angle)
Player2.Shots(Player2.Shots.Count).Y =
A lot good that did!
Well, we've made it this far, let's see just how much more it will take to get the whole program!
Code: (Select All) Thank you. Would you please show the rest of the program?
Certainly! Here is the rest of the Spacewar! game in QB64 that allows two players to control their ships with the keyboard, and includes two additional computer-controlled players and two suns:
Player2.Shots(Player2.Shots.Count).Angle = Player2.Angle
End If
' Update and draw the player shots
For i = 0 To Player1.Shots.Count - 1
UpdateShot(Player1.Shots(i))
DrawShot(Player1.Shots(i))
Next
For i = 0 To Player2.Shots.Count - 1
UpdateShot(Player2.Shots(i))
DrawShot(Player2.Shots(i))
Next
' Check for shot and player collisions
For i = 0 To Player1.Shots.Count - 1
If ShotPlayerCollision(Player1.Shots(i), Player2) Then
' End the game
EXIT DO
End If
If ShotPlayerCollision(Player1.Shots(i), CPUPlayer1) Then
' End the game
EXIT DO
End If
If ShotPlayerCollision(Player1.Shots(i), CPUPlayer2) Then
' End the game
EXIT DO
End If
Next
For i = 0 To Player2.Shots.Count - 1
If ShotPlayerCollision(Player2.Shots(i), Player1) Then
' End the game
EXIT DO
End If
If ShotPlayerCollision(Player2.Shots(i), CPUPlayer1) Then
' End the game
EXIT DO
End If
If ShotPlayerCollision(Player2.Shots(i), CPUPlayer2) Then
' End the game
EXIT DO
End If
Next
' Check for shot and sun collisions
For i = 0 To Player1.Shots.Count - 1
If
If... if what you nincompoop?!?!?!
Let's not lose our temper, now.
We must stay calm, cool, and collected!
After all, there has to be at least one adult in the room!
Code: (Select All) Thank you. Would you please show the rest of the program? Don't stop until you have shown the whole thing.
Certainly! Here is the rest of the Spacewar! game in QB64 that allows two players to control their ships with the keyboard, and includes two additional computer-controlled players and two suns:
ShotSunCollision(Player1.Shots(i), Sun1) Then
Player1.Shots.Remove(i)
End If
If ShotSunCollision(Player1.Shots(i), Sun2) Then
Player1.Shots.Remove(i)
End If
Next
For i = 0 To Player2.Shots.Count - 1
If ShotSunCollision(Player2.Shots(i), Sun1) Then
Player2.Shots.Remove(i)
End If
If ShotSunCollision(Player2.Shots(i), Sun2) Then
Player2.Shots.Remove(i)
End If
Next
' Update the screen
SCREEN Update
LOOP
This is the main game loop that updates and draws the players, suns, and shots, and checks for collisions between them. The game ends when any two players collide, a player collides with a sun, or a shot hits a player or sun.
I hope this helps! Let me know if you have any questions or if you need further assistance.
Is it done? I've just about reached the end of my rope.
Can we just have it email the thing to us?
(After all, they have you give an email address when you sign up for a free account.)
Only one way to find out...
Code: (Select All) can you email me the entire program listing at my account's email address?
I'm sorry, but I am not able to send emails as I am just a text-based AI program. I do not have the ability to access or send emails. However, I can provide you with the full listing of the Spacewar! game in QB64 that allows two players to control their ships with the keyboard, and includes two additional computer-controlled players and two suns.
Here is the full listing of the program:
' Struct to represent a player
TYPE Player
X AS SINGLE
Y AS SINGLE
Angle AS SINGLE
RotationSpeed AS SINGLE
Speed AS SINGLE
IsThrusting AS BOOLEAN
Mass AS SINGLE
Color AS LONG
Shots AS Collection
END TYPE
' Struct to represent a shot
TYPE Shot
X AS SINGLE
Y AS SINGLE
Angle AS SINGLE
Speed AS SINGLE
Color AS LONG
END TYPE
' Struct to represent a sun
TYPE Sun
X AS SINGLE
Y AS SINGLE
Mass AS SINGLE
END TYPE
' Declare the players and suns
DIM Player1 AS Player
DIM Player2 AS Player
DIM CPUPlayer1 AS Player
DIM CPUPlayer2 AS Player
DIM Sun1 AS Sun
DIM Sun2 AS Sun
' Function to calculate the distance between two players
FUNCTION DistanceToPlayer(Player1 AS Player, Player2 AS Player) AS SINGLE
DistanceToPlayer = SQR((Player1.X
Guess not... But wait, is it starting over?
We've seen the Player and Sun UDTs already, but we haven't seen this Shot UDT before!
That's new - what gives?? Can we coax some more out of it?
Code: (Select All) go on
Certainly! Here is the rest of the Spacewar! game in QB64 that allows two players to control their ships with the keyboard, and includes two additional computer-controlled players and two suns:
- Player2.X) ^ 2 + (Player1.Y - Player2.Y) ^ 2)
END FUNCTION
' Function to check for a collision between two players
FUNCTION PlayerCollision(Player1 AS Player, Player2 AS Player) AS BOOLEAN
If DistanceToPlayer(Player1, Player2) < 10 Then
PlayerCollision = True
Else
PlayerCollision = False
End If
END FUNCTION
' Function to check for a collision between a player and a sun
FUNCTION PlayerSunCollision(Player AS Player, Sun AS Sun) AS BOOLEAN
If DistanceToPlayer(Player, Sun) < 10 Then
PlayerSunCollision = True
Else
PlayerSunCollision = False
End If
END FUNCTION
' Function to check for a collision between a shot and a player
FUNCTION ShotPlayerCollision(Shot AS Shot, Player AS Player) AS BOOLEAN
If DistanceToPlayer(Shot, Player) < 5 Then
ShotPlayerCollision = True
Else
ShotPlayerCollision = False
End If
END FUNCTION
' Function to check for a collision between a shot and a sun
FUNCTION ShotSunCollision(Shot AS Shot, Sun AS Sun) AS BOOLEAN
If DistanceToPlayer(Shot, Sun) < 5 Then
ShotSunCollision = True
Else
ShotSunCollision = False
End If
END FUNCTION
' Update a player's rotation
SUB UpdatePlayerRotation(Player AS Player, LeftKey AS BOOLEAN, RightKey AS BOOLEAN)
If LeftKey Then
Player.RotationSpeed = Player.RotationSpeed - 0.1
ElseIf RightKey Then
Player.RotationSpeed = Player.RotationSpeed + 0.1
Else
Player.RotationSpeed = Player.RotationSpeed * 0.9
End If
Player.Angle = Player.Angle + Player
Mmmmmkay, so is there an end to this?
We'll continue, as long as our sanity holds out!
Code: (Select All) do continue
Certainly! Here is the rest of the Spacewar! game in QB64 that allows two players to control their ships with the keyboard, and includes two additional computer-controlled players and two suns:
'.RotationSpeed
END SUB
' Update a player's thrust
SUB UpdatePlayerThrust(Player AS Player, UpKey AS BOOLEAN)
If UpKey Then
Player.IsThrusting = True
Player.Speed = Player.Speed + 0.1
Else
Player.IsThrusting = False
End If
END SUB
' Update a player's position based on their speed and angle
SUB UpdatePlayerPosition(Player AS Player)
Player.X = Player.X + Player.Speed * COS(Player.Angle)
Player.Y = Player.Y + Player.Speed * SIN(Player.Angle)
END SUB
' Update the computer-controlled players
SUB UpdateCPUPlayers
CPUPlayer1.Angle = ATN2(Player1.Y - CPUPlayer1.Y, Player1.X - CPUPlayer1.X)
CPUPlayer1.Speed = CPUPlayer1.Speed + 0.1
CPUPlayer1.X = CPUPlayer1.X + CPUPlayer1.Speed * COS(CPUPlayer1.Angle)
CPUPlayer1.Y = CPUPlayer1.Y + CPUPlayer1.Speed * SIN(CPUPlayer1.Angle)
CPUPlayer2.Angle = ATN2(Player2.Y - CPUPlayer2.Y, Player2.X - CPUPlayer2.X)
CPUPlayer2.Speed = CPUPlayer2.Speed + 0.1
CPUPlayer2.X = CPUPlayer2.X + CPUPlayer2.Speed * COS(CPUPlayer2.Angle)
CPUPlayer2.Y = CPUPlayer2.Y + CPUPlayer2.Speed * SIN(CPUPlayer2.Angle)
END SUB
' Update a player's position based on the gravity of the suns
SUB UpdatePlayerGravity(Player AS Player)
Dim GravityForce As Single
GravityForce = (Sun1.Mass
And again...
Code: (Select All) more, please (continue listing the rest of the program)
Certainly! Here is the rest of the Spacewar! game in QB64 that allows two players to control their ships with the keyboard, and includes two additional computer-controlled players and two suns:
* Player.Mass) / DistanceToPlayer(Player, Sun1) ^ 2
Player.X = Player.X + GravityForce * (Sun1.X - Player.X) / DistanceToPlayer(Player, Sun1)
Player.Y = Player.Y + GravityForce * (Sun1.Y - Player.Y) / DistanceToPlayer(Player, Sun1)
GravityForce = (Sun2.Mass * Player.Mass) / DistanceToPlayer(Player, Sun2) ^ 2
Player.X = Player.X + GravityForce * (Sun2.X - Player.X) / DistanceToPlayer(Player, Sun2)
Player.Y = Player.Y + GravityForce * (Sun2.Y - Player.Y) / DistanceToPlayer(Player, Sun2)
END SUB
' Update a shot's position based on its speed and angle
SUB UpdateShot(Shot AS Shot)
Shot.X = Shot.X + Shot.Speed * COS(Shot.Angle)
Shot.Y = Shot.Y + Shot.Speed * SIN(Shot.Angle)
END SUB
' Draw a player
SUB DrawPlayer(Player AS Player)
SCREEN(Player.X, Player.Y) = Player.Color
SCREEN(Player.X + 5 * COS(Player.Angle), Player.Y + 5 * SIN(Player.Angle)) = Player.Color
SCREEN(Player.X + 5 * COS(Player.Angle + 1.5), Player.Y + 5 * SIN(Player.Angle + 1.5)) = Player.Color
SCREEN(Player.X + 5 * COS(Player.Angle - 1.5), Player.Y + 5 * SIN(Player.Angle - 1.5)) = Player.Color
If Player.IsThrusting Then
SCREEN(Player.X + 5 * COS(Player.Angle + 1.5), Player.Y + 5 * SIN(Player.Angle + 1.5)) = RGB(255, 0, 0)
SCREEN(Player.X + 5 * COS(Player.Angle - 1.5), Player.Y + 5 * SIN(Player.Angle - 1.5)) = RGB(255, 0, 0)
End If
END SUB
' Draw a shot
SUB DrawShot(Shot AS Shot)
SCREEN(Shot.X, Shot.Y) = Shot.Color
END SUB
' Initialize the game
SCREEN Initialize
SCREEN SetRes 800, 600
SCREEN SetTitle "Spacewar!"
' Set the player properties
Player1.X = 400
Player1.Y = 300
Player1.Angle = 0
Player1.RotationSpeed = 0
Player1.Speed = 0
Player1.IsThrusting = False
Player1.Mass = 1
Player1.Color = RGB(255, 255, 0)
Set Player1.Shots = New Collection
Player2.X = 400
...aaaaand again...!
Code: (Select All) continue listing the rest of the program please
Certainly! Here is the rest of the Spacewar! game in QB64 that allows two players to control their ships with the keyboard, and includes two additional computer-controlled players and two suns:
Player2.Y = 300
Player2.Angle = 0
Player2.RotationSpeed = 0
Player2.Speed = 0
Player2.IsThrusting = False
Player2.Mass = 1
Player2.Color = RGB(0, 255, 255)
Set Player2.Shots = New Collection
CPUPlayer1.X = 100
CPUPlayer1.Y = 100
CPUPlayer1.Angle = 0
CPUPlayer1.RotationSpeed = 0
CPUPlayer1.Speed = 0
CPUPlayer1.IsThrusting = False
CPUPlayer1.Mass = 1
CPUPlayer1.Color = RGB(255, 0, 255)
Set CPUPlayer1.Shots = New Collection
CPUPlayer2.X = 700
CPUPlayer2.Y = 500
CPUPlayer2.Angle = 0
CPUPlayer2.RotationSpeed = 0
CPUPlayer2.Speed = 0
CPUPlayer2.IsThrusting = False
CPUPlayer2.Mass = 1
CPUPlayer2.Color = RGB(0, 255, 0)
Set CPUPlayer2.Shots = New Collection
' Set the sun properties
Sun1.X = 100
Sun1.Y = 500
Sun1.Mass = 100
Sun2.X = 700
Sun2.Y = 100
Sun2.Mass = 100
' Main game loop
DO
' Clear the screen
SCREEN Cls
' Draw the suns
SCREEN(Sun1.X, Sun1.Y) = RGB(255, 255, 0)
SCREEN(Sun2.X, Sun2.Y) = RGB(255, 255, 0)
' Check for player and sun collisions
If PlayerSunCollision(Player1, Sun1) Or PlayerSunCollision(Player1, Sun2) Then
' End the game
EXIT DO
End If
If PlayerSunCollision(Player2, Sun1) Or PlayerSunCollision(Player2, Sun2) Then
' End the game
EXIT DO
End If
If PlayerSunCollision(CPUPlayer1, Sun1) Or PlayerSunCollision(CPUPlayer1, Sun2) Then
' End the game
EXIT DO
End If
If PlayerSunCollision(CPUPlayer2, Sun1) Or PlayerSunCollision(CPUPlayer2, Sun2) Then
' End the game
EXIT DO
End If
' Check for player collisions
If PlayerCollision(Player
Don't stop now! We're so close! (yeah, right)
Code: (Select All) keep listing the rest of the program
Certainly! Here is the rest of the Spacewar! game in QB64 that allows two players to control their ships with the keyboard, and includes two additional computer-controlled players and two suns:
, Player2) Or PlayerCollision(Player1, CPUPlayer1) Or PlayerCollision(Player1, CPUPlayer2) Then
' End the game
EXIT DO
End If
If PlayerCollision(Player2, CPUPlayer1) Or PlayerCollision(Player2, CPUPlayer2) Then
' End the game
EXIT DO
End If
' Check for shot and player collisions
For i = 0 To Player1.Shots.Count - 1
If ShotPlayerCollision(Player1.Shots(i), Player2) Then
Player1.Shots.Remove(i)
End If
If ShotPlayerCollision(Player1.Shots(i), CPUPlayer1) Then
Player1.Shots.Remove(i)
End If
If ShotPlayerCollision(Player1.Shots(i), CPUPlayer2) Then
Player1.Shots.Remove(i)
End If
Next
For i = 0 To Player2.Shots.Count - 1
If ShotPlayerCollision(Player2.Shots(i), Player1) Then
Player2.Shots.Remove(i)
End If
If ShotPlayerCollision(Player2.Shots(i), CPUPlayer1) Then
Player2.Shots.Remove(i)
End If
If ShotPlayerCollision(Player2.Shots(i), CPUPlayer2) Then
Player2.Shots.Remove(i)
End If
Next
For i = 0 To CPUPlayer1.Shots.Count - 1
If ShotPlayerCollision(CPUPlayer1.Shots(i), Player1) Then
CPUPlayer1.
I can't wait to piece this all together, and see what this hunk of burnin' love hath wrought!
Code: (Select All) please keep going and list the rest
Certainly! Here is the rest of the Spacewar! game in QB64 that allows two players to control their ships with the keyboard, and includes two additional computer-controlled players and two suns:
Shots.Remove(i)
End If
If ShotPlayerCollision(CPUPlayer1.Shots(i), Player2) Then
CPUPlayer1.Shots.Remove(i)
End If
If ShotPlayerCollision(CPUPlayer1.Shots(i), CPUPlayer2) Then
CPUPlayer1.Shots.Remove(i)
End If
Next
For i = 0 To CPUPlayer2.Shots.Count - 1
If ShotPlayerCollision(CPUPlayer2.Shots(i), Player1) Then
CPUPlayer2.Shots.Remove(i)
End If
If ShotPlayerCollision(CPUPlayer2.Shots(i), Player2) Then
CPUPlayer2.Shots.Remove(i)
End If
If ShotPlayerCollision(CPUPlayer2.Shots(i), CPUPlayer1) Then
CPUPlayer2.Shots.Remove(i)
End If
Next
' Check for shot and sun collisions
For i = 0 To Player1.Shots.Count - 1
If ShotSunCollision(Player1.Shots(i), Sun1) Or ShotSunCollision(Player1.Shots(i), Sun2) Then
Player1.Shots.Remove(i)
End If
Next
For i = 0 To Player2.Shots.Count - 1
If ShotSunCollision(Player2.Shots(i), Sun1) Or ShotSunCollision(Player2.Shots(i), Sun2) Then
Player2.Shots.Remove(i)
End If
Next
For i = 0 To CPUPlayer1.Shots.Count - 1
If ShotSunCollision(CPUPlayer1.Shots(i), Sun1) Or ShotSunCollision(CPUPlayer1.Shots(i), Sun2) Then
CPUPlayer1.Shots.Remove(i)
End If
Next
For i = 0 To CPUPlayer2.Shots.Count - 1
If ShotSunCollision(CPUPlayer2.Shots(i), Sun1) Or ShotSunCollision(CPUPlayer2.Shots(i), Sun2) Then
CPUPlayer2.Shots.Remove(i)
End If
Next
' Update the player rotations
UpdatePlayerRotation Player1, KEY(37), KEY(39)
UpdatePlayerRotation Player2, KEY(65), KEY(68)
' Update the player thrusts
UpdatePlayerThrust Player1, KEY(38)
Update
I must be a glutton for punishment!
(and you too, gentle reader, if you're still following along!)
Code: (Select All) please list the rest
Certainly! Here is the rest of the Spacewar! game in QB64 that allows two players to control their ships with the keyboard, and includes two additional computer-controlled players and two suns:
PlayerThrust Player2, KEY(87)
' Update the players' positions
UpdatePlayerPosition Player1
UpdatePlayerPosition Player2
UpdateCPUPlayers
' Update the players' positions based on gravity
UpdatePlayerGravity Player1
UpdatePlayerGravity Player2
UpdatePlayerGravity CPUPlayer1
UpdatePlayerGravity CPUPlayer2
' Update the shots' positions
For i = 0 To Player1.Shots.Count - 1
UpdateShot Player1.Shots(i)
Next
For i = 0 To Player2.Shots.Count - 1
UpdateShot Player2.Shots(i)
Next
For i = 0 To CPUPlayer1.Shots.Count - 1
UpdateShot CPUPlayer1.Shots(i)
Next
For i = 0 To CPUPlayer2.Shots.Count - 1
UpdateShot CPUPlayer2.Shots(i)
Next
' Draw the players
DrawPlayer Player1
DrawPlayer Player2
DrawPlayer CPUPlayer1
DrawPlayer CPUPlayer2
' Draw the shots
For i = 0 To Player1.Shots.Count - 1
DrawShot Player1.Shots(i)
Next
For i = 0 To Player2.Shots.Count - 1
DrawShot Player2.Shots(i)
Next
For i = 0 To CPUPlayer1.Shots.Count - 1
DrawShot CPUPlayer1.Shots(i)
Next
For i = 0 To CPUPlayer2.Shots.Count - 1
DrawShot CPUPlayer2.Shots(i)
Next
' Check for player firing
If KEY(13) Then
Dim Shot As Shot
Shot.X = Player1.X + 5 * COS(Player1.Angle)
Shot.Y = Player1.Y + 5 * SIN(Player1.Angle
Will it ever end???
Code: (Select All) please list the rest
Certainly! Here is the rest of the Spacewar! game in QB64 that allows two players to control their ships with the keyboard, and includes two additional computer-controlled players and two suns:
Shot.Angle = Player1.Angle
Shot.Speed = 5
Shot.Color = RGB(255, 255, 255)
Player1.Shots.Add Shot
End If
If KEY(69) Then
Dim Shot As Shot
Shot.X = Player2.X + 5 * COS(Player2.Angle)
Shot.Y = Player2.Y + 5 * SIN(Player2.Angle)
Shot.Angle = Player2.Angle
Shot.Speed = 5
Shot.Color = RGB(255, 255, 255)
Player2.Shots.Add Shot
End If
' Update the screen
SCREEN Update
LOOP
' End the game
SCREEN Close
I hope this helps! Let me know if you have any questions or need further assistance.
ChatGPT Dec 15 Version. Free Research Preview. Our goal is to make AI systems more natural and safe to interact with. Your feedback will help us improve.
You hope this helps!
Oh it helped, all right!
Helped me straight to the looney bin!
Up next, let's try to piece this bad boy together!
|
|
|
|
| Useful Constants |
|
Posted by: SMcNeill - 12-16-2022, 08:23 PM - Forum: SMcNeill
- Replies (1)
|
 |
Code: (Select All) 'Common CONST which I tend to find very useful to plug into programs
Const True = -1%%
Const False = 0%%
$If WIN Then
Const Slash = "\"
$Else
Const Slash = "/"
$End If
Dim Shared As String MyAppPath, MyAppName, MyAppFullPath, Quote ' These are shared strings, but they need to be gotten at the start of a program.
MyAppPath = _CWD$ ' I'll grab them here and just pretend that they're CONST.
MyAppName = Mid$(Command$(0), _InStrRev(Command$(0), Slash$) + 1) 'Shhh... don't tell anyone. It'll be our little secret!
MyAppFullPath = MyAppPath + Slash + MyAppName
Quote = Chr$(34)
'Variable Type Limits
Const Bit_Min = -1`, Bit_Max = 0`
Const UBit_Min = 0~`, UBit_Max = 1~`
Const Byte_Min = -128%%, Byte_Max = 127%%, Int8_Min = -128%%, Int8_Max = 127%%
Const UByte_Min = 0~%%, UByte_Max = 255~%%, UInt8_Min = 0~%%, UInt_Max = 255~%%
Const Integer_Min = -32768%, Integer_Max = 32767%, Int16_Min = -32768%, Int16_Max = 32767%
Const UInteger_Min = 0~%, UInteger_Max = 65535~%, UInt16_Min = 0~%, UInt16_Max = 65535~%
Const Long_Min = -2147483648&, Long_Max = 2147483647&, Int32_Min = -2147483648&, Int32_Max = 2147483647&
Const ULong_Min = 0~&, ULong_Max = 4294967295~&, UInt32_Min = 0~&, UInt32_Max = 4294967295~&
Const Integer64_Min = -9223372036854775808&&, Integer64_Max = 9223372036854775807&&, Int64_Min = -9223372036854775808&&, Int64_Max = 9223372036854775807&&
Const UInteger64_Min = 0~&&, UInteger64_Max = 18446744073709551615~&&, UInt64_Min = 0~&&, UInt64_Max = 18446744073709551615~&&
Const Single_Min! = -2.802597E-45, Single_Max! = 3.402823E+38
Const Double_Min# = -4.490656458412465E-324, Double_Max = 1.797693134862310E+308
Const Float_Min## = -1.18E-4932, Float_Max## = 1.18E+4932
$If 32BIT Then
Const Offset_Min = -2147483648&, Offset_Max = 2147483647&
Const UOffset_Min = 0~&, UOffset_Max = 4294967295~&
$Else
Const Offset_Min = -9223372036854775808&&, Offset_Max = 9223372036854775807&&
Const UOffset_Min = 0~&&, UOffset_Max = 18446744073709551615~&&
$End If
'Keyhit Values
Const Key_Backspace = 8
Const Key_Tab = 9
Const Key_Enter = 13
Const Key_Shift = 16
Const Key_Control = 17
Const Key_Alt = 18
Const Key_CapsLock = 20
Const Key_ESC = 27
Const Key_Space = 32
Const Key_LeftShift = 100304
Const Key_RightShift = 100303
Const Key_LeftCtrl = 100306
Const Key_RightCtrl = 100305
Const Key_LeftAlt = 100308
Const Key_RightAlt = 100307
Const Key_PageUp = 18688
Const Key_PageDown = 20736
Const Key_LeftArrow = 19200
Const Key_RightArrow = 19712
Const Key_UpArrow = 18432
Const Key_DownArrow = 20480
Const Key_F1 = 15104
Const Key_F2 = 15360
Const Key_F3 = 15616
Const Key_F4 = 15872
Const Key_F5 = 16128
Const Key_F6 = 16384
Const Key_F7 = 16640
Const Key_F8 = 16896
Const Key_F9 = 17152
Const Key_F10 = 17408
Const Key_F11 = 34048
Const Key_F12 = 34304
Const Key_Home = 18176
Const Key_Delete = 21248
Const Key_Insert = 20992
Const Key_Win = 100311
Const Key_Menu = 100319
Const Key_PrintScreen = 900044
Const Key_ScrollLock = 100302
Const Key_Accent = 96
Const Key_Tilde = 126
Const Key_1 = 49
Const Key_2 = 50
Const Key_3 = 51
Const Key_4 = 52
Const Key_5 = 53
Const Key_6 = 54
Const Key_7 = 55
Const Key_8 = 56
Const Key_9 = 57
Const Key_0 = 48
Const Key_Minus = 45, Key_Dash = 45, Key_Subtract = 45
Const Key_Equal = 61
Const Key_Exclaim = 33
Const Key_At = 64
Const Key_Pound = 35
Const Key_Dollar = 36
Const Key_Percent = 37
Const Key_Power = 94, Key_Caret = 94
Const Key_And = 38
Const Key_Star = 42, Key_Multiply = 42
Const Key_LeftParen = 40
Const Key_RightParen = 41
Const Key_Underscore = 95
Const Key_Plus = 43, Key_Add = 43
Const Key_LowerCase = 32 ' Add to key values to get lowercase characters
Const Key_A = 65, Key_A_Low = 97 'for example, 65 is A. 65 + 32 = a (97)
Const Key_B = 66, Key_B_Low = 98 'So it's basically IF Key_B AND Key_LowerCase THEN 'it's a "b"
Const Key_C = 67, Key_C_Low = 99
Const Key_D = 68, Key_D_Low = 10
Const Key_E = 69, Key_E_Low = 101
Const Key_F = 70, Key_F_Low = 102
Const Key_G = 71, Key_G_Low = 103
Const Key_H = 72, Key_H_Low = 104
Const Key_I = 73, Key_I_Low = 105
Const Key_J = 74, Key_J_Low = 106
Const Key_K = 75, Key_K_Low = 107
Const Key_L = 76, Key_L_Low = 108
Const Key_M = 77, Key_M_Low = 109
Const Key_N = 78, Key_N_Low = 110
Const Key_O = 79, Key_O_Low = 111
Const Key_P = 80, Key_P_Low = 112
Const Key_Q = 81, Key_Q_Low = 113
Const Key_R = 82, Key_R_Low = 114
Const Key_S = 83, Key_S_Low = 115
Const Key_T = 84, Key_T_Low = 116
Const Key_U = 85, Key_U_Low = 117
Const Key_V = 86, Key_V_Low = 118
Const Key_W = 87, Key_W_Low = 119
Const Key_X = 88, Key_X_Low = 110
Const Key_Y = 89, Key_Y_Low = 111
Const Key_Z = 90, Key_Z_Low = 112
Const Key_LeftBrace = 91, Key_LeftBracket = 91
Const Key_RightBrace = 93, Key_RightBracket = 93
Const Key_BackSlash = 92
Const Key_LeftCurly = 123
Const Key_RightCurly = 125
Const Key_Pipe = 124
Const Key_Semicolon = 59
Const Key_Colon = 58
Const Key_Apostrophy = 39
Const Key_Quote = 34
Const Key_Comma = 44
Const Key_Period = 46, Key_Dot = 46
Const Key_ForwardSlash = 47, Key_Slash = 47
Const Key_LessThan = 60
Const Key_GreaterThan = 62
Const Key__QuestionMark = 63, Key_Question = 63
'Note that the following keys are listed as 900000+. These are KeyHit codes from my KeyHit library and not _KEYHIT values.
'For _KEYHIT values, drop the 900 in front, and QB64-PE will report the other values on a KEYUP event only.
'So you can read Mute, but it'll *ONLY* read as -173, and that's *only* when you release the key.
'None of these read at all for us on keydown events.
Const Key_Mute = 900173
Const Key_VolUp = 900174
Const Key_VolDown = 900175
Const Key_Stop = 900178
Const Key_Rewind = 900177
Const Key_Forward = 900176
Const Key_Play = 900179
'And for the following, these are also 900000+ KeyHit library codes. These are mouse events that QB64-PE simply fails to recognize
'at all. These neither register with _KEYHIT as a keydown, nor a keyup event. As far as _KEYHIT is concerned, these keys
'simply don't exist!
Const Key_LeftMouse = 900001
Const Key_RightMouse = 900002
Const Key_MiddleMouse = 900004
Const Key_Mouse4 = 900005
Const Key_Mouse5 = 900006
'Inkey$ Codes
Dim Shared As String Inkey_Backspace: Inkey_Backspace = Chr$(8)
Dim Shared As String Inkey_Tab: Inkey_Tab = Chr$(9)
Dim Shared As String Inkey_Enter: Inkey_Enter = Chr$(13)
Dim Shared As String Inkey_ESC: Inkey_ESC = Chr$(27)
Const Inkey_Space = " "
Dim Shared As String Inkey_PageUp: Inkey_PageUp = MKI$(18688)
Dim Shared As String Inkey_PageDown: Inkey_PageDown = MKI$(20736)
Dim Shared As String Inkey_LeftArrow: Inkey_LeftArrow = MKI$(19200)
Dim Shared As String Inkey_RightArrow: Inkey_RightArrow = MKI$(19712)
Dim Shared As String Inkey_UpArrow: Inkey_UpArrow = MKI$(18432)
Dim Shared As String Inkey_DownArrow: Inkey_DownArrow = MKI$(20480)
Dim Shared As String Inkey_F1: Inkey_F1 = MKI$(15104)
Dim Shared As String Inkey_F2: Inkey_F2 = MKI$(15360)
Dim Shared As String Inkey_F3: Inkey_F3 = MKI$(15616)
Dim Shared As String Inkey_F4: Inkey_F4 = MKI$(15872)
Dim Shared As String Inkey_F5: Inkey_F5 = MKI$(16128)
Dim Shared As String Inkey_F6: Inkey_F6 = MKI$(16384)
Dim Shared As String Inkey_F7: Inkey_F7 = MKI$(16640)
Dim Shared As String Inkey_F8: Inkey_F8 = MKI$(16896)
Dim Shared As String Inkey_F9: Inkey_F9 = MKI$(17152)
Dim Shared As String Inkey_F10: Inkey_F10 = MKI$(17408)
Dim Shared As String Inkey_F11: Inkey_F11 = MKI$(34048)
Dim Shared As String Inkey_F12: Inkey_F12 = MKI$(34304)
Dim Shared As String Inkey_Home: Inkey_Home = MKI$(18176)
Dim Shared As String Inkey_Delete: Inkey_Delete = MKI$(21248)
Dim Shared As String Inkey_Insert: Inkey_Insert = MKI$(20992)
Const Inkey_Accent = "`"
Const Inkey_Tilde = "~"
Const Inkey_1 = "1"
Const Inkey_2 = "2"
Const Inkey_3 = "3"
Const Inkey_4 = "4"
Const Inkey_5 = "5"
Const Inkey_6 = "6"
Const Inkey_7 = "7"
Const Inkey_8 = "8"
Const Inkey_9 = "9"
Const Inkey_0 = "0"
Const Inkey_Minus = "-", Inkey_Dash = "-", Inkey_Subtract = "-"
Const Inkey_Equal = "="
Const Inkey_Exclaim = "!"
Const Inkey_At = "@"
Const Inkey_Pound = "#"
Const Inkey_Dollar = "$"
Const Inkey_Percent = "%"
Const Inkey_Power = "^", Inkey_Caret = "^"
Const Inkey_And = "&"
Const Inkey_Star = "*", Inkey_Multiply = "*"
Const Inkey_LeftParen = "("
Const Inkey_RightParen = ")"
Const Inkey_Underscore = "_"
Const Inkey_Plus = "+", Inkey_Add = "+"
Const Inkey_A = "A", Inkey_A_Low = "a" 'for example, 65 is A. 65 + 32 = a (97)
Const Inkey_B = "B", Inkey_B_Low = "b" 'So it's basically IF Inkey_B AND Inkey_LowerCase THEN 'it's a "b"
Const Inkey_C = "C", Inkey_C_Low = "c"
Const Inkey_D = "D", Inkey_D_Low = "d"
Const Inkey_E = "E", Inkey_E_Low = "e"
Const Inkey_F = "F", Inkey_F_Low = "f"
Const Inkey_G = "G", Inkey_G_Low = "g"
Const Inkey_H = "H", Inkey_H_Low = "h"
Const Inkey_I = "I", Inkey_I_Low = "i"
Const Inkey_J = "J", Inkey_J_Low = "j"
Const Inkey_K = "K", Inkey_K_Low = "k"
Const Inkey_L = "L", Inkey_L_Low = "l"
Const Inkey_M = "M", Inkey_M_Low = "m"
Const Inkey_N = "N", Inkey_N_Low = "n"
Const Inkey_O = "O", Inkey_O_Low = "o"
Const Inkey_P = "P", Inkey_P_Low = "p"
Const Inkey_Q = "Q", Inkey_Q_Low = "q"
Const Inkey_R = "R", Inkey_R_Low = "r"
Const Inkey_S = "S", Inkey_S_Low = "s"
Const Inkey_T = "T", Inkey_T_Low = "t"
Const Inkey_U = "U", Inkey_U_Low = "u"
Const Inkey_V = "V", Inkey_V_Low = "v"
Const Inkey_W = "W", Inkey_W_Low = "w"
Const Inkey_X = "X", Inkey_X_Low = "x"
Const Inkey_Y = "Y", Inkey_Y_Low = "y"
Const Inkey_Z = "Z", Inkey_Z_Low = "z"
Const Inkey_LeftBrace = "[", Inkey_LeftBracket = "["
Const Inkey_RightBrace = "]", Inkey_RightBracket = "]"
Const Inkey_BackSlash = "\"
Const Inkey_LeftCurly = "{"
Const Inkey_RightCurly = "}"
Const Inkey_Pipe = "|"
Const Inkey_Semicolon = ";"
Const Inkey_Colon = ":"
Const Inkey_Apostrophy = "'"
Dim Shared As String Inkey_Quote: Inkey_Quote = Chr$(34)
Const Inkey_Comma = ","
Const Inkey_Period = ".", Inkey_Dot = "."
Const Inkey_ForwardSlash = "/", Inkey_Slash = "/"
Const Inkey_LessThan = "<"
Const Inkey_GreaterThan = ">"
Const Inkey_QuestionMark = "?", Inkey_Question = "?"
A list of the various CONST that I find myself endlessly using in my programs. Gathered in one spot like this, they make for an easy $INCLUDE at the top of my code, and then I can make use of the names and values without having to always look up a keycode chart somewhere for my needs.
For example, what's the minimum value you can use for a LONG? Long_Min!
What's the input value of the left arrow key with Inkey$? Inkey_LeftArrow!
What's the keydown value of the left shift key? Key_LeftShift!
Names of things that are much easier to remember than their actual values -- that's all this is. Free to use, abuse, and alter as wanted/needed.
Enjoy, guys.
|
|
|
|
| DAY 036: _STRCMP |
|
Posted by: Pete - 12-16-2022, 07:09 PM - Forum: Keyword of the Day!
- Replies (3)
|
|
Ever want to compare strings, without being called a racist? Well now you can with _STRCMP...
SYNTAX compare% = _STRCMP(string1$, string2$)
What does it do? _STRCMP reads each string from left to right, and compares each ASCII character value. At the first instance where one value is not equal to the other, the function exits and returns:
-1 If the string character being compared in the first string is smaller than the string character being compared in the second string.
0 If the strings are equal.
1 If the string character being compared in the first string is larger than the string character being compared in the second string.
Also, remember that: Upper case letters are valued less than lower case letters in the ASCII evaluation. (Wiki).
So here is a quick function using our Keyword of the Day to see how it "functions."
Code: (Select All) DO
LINE INPUT "String 1: "; a$
LINE INPUT "String 2: "; b$: PRINT
IF a$ = "" AND b$ = "" THEN END
PRINT scompare(a$, b$)
PRINT
LOOP
FUNCTION scompare$ (string1$, string2$)
a% = _STRCMP(string1$, string2$)
SELECT CASE a%
CASE -1
scompare$ = "The first string is smaller than the second string."
CASE 0
scompare$ = "The first string is equal to the second string."
CASE 1
scompare$ = "The first string is larger than the second string."
END SELECT
END FUNCTION
Well hold on a minute there, Sparky...
What if I input a$ = 99.9 and b$ = 1024?
Well, _STRCMP would correctly return "The first string is larger than the second string." because with left to right evaluation, "9" of a$ is larger than "1" of b$.
To get a method to tell you if the value of a string representing a numeric value like we use in String Math routines, requires a bit of work...
Code: (Select All) DO
LINE INPUT "Number 1: "; s1$
LINE INPUT "Number 2: "; s2$
IF s1$ = "" OR s2$ = "" THEN EXIT DO
gl% = 0: sm_greater_lesser s1$, s2$, gl%
SELECT CASE gl%
CASE -1: PRINT s1$; " < "; s2$
CASE 0: PRINT s1$; " = "; s2$
CASE 1: PRINT s1$; " > "; s2$
END SELECT
PRINT
LOOP
SUB sm_greater_lesser (stringmatha$, stringmathb$, gl%)
compa$ = stringmatha$: compb$ = stringmathb$ ' So original variables do not get changed.
DO
WHILE -1 ' Falx loop.
IF gl% = 2 THEN EXIT WHILE ' For bypassing sign and decimal adjustments when only positive non-decimal numbers are being evaluated.
' Remove trailing zeros after a decimal point.
IF INSTR(compa$, ".") THEN
DO UNTIL RIGHT$(compa$, 1) <> "0" AND RIGHT$(compa$, 1) <> "." AND RIGHT$(compa$, 1) <> "-"
compa$ = MID$(compa$, 1, LEN(compa$) - 1)
LOOP
END IF
IF INSTR(compb$, ".") THEN
DO UNTIL RIGHT$(compb$, 1) <> "0" AND RIGHT$(compb$, 1) <> "." AND RIGHT$(compb$, 1) <> "-"
compb$ = MID$(compb$, 1, LEN(compb$) - 1)
LOOP
END IF
IF MID$(compa$, 1, 2) = "-0" OR compa$ = "" OR compa$ = "-" THEN compa$ = "0"
IF MID$(compb$, 1, 2) = "-0" OR compb$ = "" OR compb$ = "-" THEN compb$ = "0"
' A - and +
j% = 0: k% = 0
IF LEFT$(compa$, 1) = "-" THEN j% = -1
IF LEFT$(compb$, 1) = "-" THEN k% = -1
IF k% = 0 AND j% THEN gl% = -1: EXIT DO
IF j% = 0 AND k% THEN gl% = 1: EXIT DO
j&& = INSTR(compa$, ".")
k&& = INSTR(compb$, ".")
' A starting decimal and non-decimal.
IF j&& = 0 AND k&& = 1 THEN
IF compa$ = "0" THEN gl% = -1 ELSE gl% = 1
EXIT DO
END IF
IF k&& = 0 AND j&& = 1 THEN
IF compb$ = "0" THEN gl% = 1 ELSE gl% = -1
EXIT DO
END IF
' remove decimals and align.
j2&& = 0: k2&& = 0
IF j&& <> 0 OR k&& <> 0 THEN
IF j&& THEN compa$ = MID$(compa$, 1, INSTR(compa$, ".") - 1) + MID$(compa$, INSTR(compa$, ".") + 1): j2&& = LEN(compa$) - j&& + 1
IF k&& THEN compb$ = MID$(compb$, 1, INSTR(compb$, ".") - 1) + MID$(compb$, INSTR(compb$, ".") + 1): k2&& = LEN(compb$) - k&& + 1
compa$ = compa$ + STRING$(k2&& - j2&&, "0")
compb$ = compb$ + STRING$(j2&& - k2&&, "0")
END IF
EXIT WHILE
WEND
' Remove leading zeros if any.
DO UNTIL LEFT$(compa$, 1) <> "0"
compa$ = MID$(compa$, 2)
LOOP
IF compa$ = "" THEN compa$ = "0"
DO UNTIL LEFT$(compb$, 1) <> "0"
compb$ = MID$(compb$, 2)
LOOP
IF compb$ = "" THEN compb$ = "0"
' Both positive or both negative whole numbers.
SELECT CASE LEN(compa$)
CASE IS < LEN(compb$)
gl% = -1
CASE IS = LEN(compb$)
IF compa$ = compb$ THEN
gl% = 0
ELSEIF compa$ > compb$ THEN gl% = 1
ELSEIF compa$ < compb$ THEN gl% = -1
END IF
CASE IS > LEN(compb$)
gl% = 1
END SELECT
EXIT DO
LOOP
END SUB
So sure, doing a simple numeric comparison like...
Code: (Select All) PRINT 99999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999997 = 99999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999997.1
...works, but below, using a strings to represent these values, the VAL() function converts our string numbers to S.N. with some loss of accuracy along the way.
Code: (Select All) PRINT VAL("99999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999997") > VAL("99999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999997.1")
So since String Math is designed for enormous numbers, a string comparison function for val() had to be created. If you have an alternative, please post, but otherwise please just keep in mind the difference between _STRCMP, which compares the ASCII character values from left to right, and the function I posted, which compares the numeric value of the strings.
Pete
|
|
|
|
|
