This is a listing of various examples using small code snippets. If you would prefer to view project examples, you will have to open KBasic's IDE and run the project examples from the menu bar under Examples ⇒ KBasic Projects, as they are not listed here.
Class lordoftherings
Sub test()
Print "h"
End Sub
Sub gandalf()
Dim s As String
test()
Dim l As Label
If __IsClass__ Then
s = __Class__
Else
s = ""
End If
Print "Gandalf is inside the class " + s
End Sub
End Class
' main part
CLS
Dim c As lordoftherings
c = New lordoftherings
c.gandalf()
If __IsClass__ Then
Print "inside a class"
Else
Print "is not inside a class!"
EndIf
Print
Print "Should print something with ../examples/kbasic/builtin/__file__.kbasic" Print __file__
Class lordoftherings
Sub gandalf()
Dim s As String
If __IsClass__ Then
s = "class"
Else
s = ""
End If
Print "Gandalf is inside a " + s
End Sub
End Class
' main part
Dim c As lordoftherings
c = New lordoftherings
c.gandalf()
If __IsClass__ Then
Print "inside a class" ' should not be printed
Else
Print "is not inside a class"
EndIf
Print "Is KBasic running on a linux machine?" If __IsLinux__ Then Print "Yes" Else print "No" End If
Print "Is KBasic running on a mac machine?" If __IsMacOS__ Then Print "Yes" Else print "No" End If
Module lordoftherings
Sub frodo()
Dim s As String
If __IsModule__ Then
s = "module"
Else
s = ""
End If
Print "Frodo is inside a " + s
End Sub
End Module
' main part
frodo()
If __IsModule__ Then
Print "inside a module" ' should not be printed
Else
Print "is not inside a module"
EndIf
Class lordoftherings
Sub gandalf()
Dim s As String
If __IsSub__ Then
s = "sub or method"
Else
s = ""
End If
Print "Gandalf is inside a " + s
End Sub
End Class
' main part
Dim c As lordoftherings
c = New lordoftherings
c.gandalf()
If __IsSub__ Then
Print "inside a sub or method" ' should not be printed
Else
Print "is not inside a sub or method"
EndIf
Print "Is KBasic running on a windows machine?" If __IsWindows__ Then Print "Yes" Else print "No" End If
Print "Should print 3" Print "This is line " + __Line__
Module starwars
Sub luke()
Print "Luke lives in the " + __Module__ + "-universe."
End Sub
Sub lea()
Print __Sub__ + " lives in the " + __Module__ + "-universe as well."
End Sub
End Module
' main part
luke()
lea()
Class scope1
Static Sub undersea
Print "Is class scope?: " + __Scope__
End Sub
End Class
Module scope2
Sub oversea
Print "Is module scope?: " + __Scope__
End Sub
End Module
Print "Is global scope?: " + __Scope__
scope1.undersea
scope2.oversea()
Sub funnySub Print "Hi! I was printed inside the sub " + __Sub__ End Sub funnySub()
Dim value1 As Integer Dim value2 As Integer 'Print Abs ( 35.5 - 100 ) 'use ABS to find the difference 'between 2 values value1 = 112 value2 = 178 Print "The difference is "; Abs(value1 - value2)
'
Print Asc("Bernd")
PRINT BIN$(128)
Print CBool(8.8) Print CBool(0)
Print CByte(8.8)
Print CDbl(8.8)
CLS 'PRINT CHR(34) Print "My name is " + Chr(34) + "Bernd" + Chr(32 + 2)
Print CInt(30.05)
Print CLng(8.8)
Print Cos(232)
Print CSng(8.8)
Print Exp(2)
FILECOPY "c:\kbasic\examples\test\test.dat", "c:\kbasic\examples\test\test2.dat" 'FILECOPY "c:\kbasic\examples\test\test2.dat", "c:\kbasic\examples\test\test.dat"
Print FileLen("c:\kbasic\parser.cpp")
Print Fix(33.78)
Print Hex(255)
Dim Msg, Titel, default2, val1
Msg = "Input value between 1 and 3"
Titel = "InputBox-Demo"
default2 = "1"
val1 = InputBox(Msg /*, Titel , default2*/ )
MsgBox("You have inputted: " + val1)
DIM s$ s$ = "Bernd Noetscher's KBasic" PRINT "string position = "& INSTR(1, s$, "KBasic")
Dim x As String, y As String x = "This is a string" y = "s" Print InStRev(x, y)
PRINT LCASE$("KBASIC")
DIM src AS STRING src = "What a nice day" PRINT LEFT$(src, 4)
Dim s As String s = "Bernd Noetscher's KBasic" Print Len(s) ''Print s.Len() ''? "hi".Len()
PRINT LOG(675)
PRINT LTRIM$(" bedazzeled ")
PRINT MAX(44, 3)
OPTION OLDBASIC text$ = "The dog bites the cat" text$ = MID$(text$, 10, 1) PRINT text$
PRINT MIN(45, 4)
Dim n
' text in richtext is possible as well
'n = MsgBox("<b>message</b> or <i>not</i>", kbOKOnly, "title text")
'n = MsgBox("message", kbOKOnly, "title text")
'n = MsgBox("message", kbOKCancel, "title text")
'n = MsgBox("message", kbAbortRetryIgnore, "title text")
'n = MsgBox("message", kbYesNoCancel, "title text")
'n = MsgBox("message", kbYesNo, "title text")
'n = MsgBox("message", kbRetryCancel, "title text")
'
'n = MsgBox("message", kbOKOnly Or kbCritical, "title text")
'n = MsgBox("message", kbOKOnly Or kbQuestion, "title text")
'n = MsgBox("message", kbOKCancel Or kbExclamation, "title text")
'n = MsgBox("message", kbOKOnly Or kbInformation, "title text")
'
'n = MsgBox("message", kbYesNoCancel Or kbDefaultButton1, "title text")
'n = MsgBox("message", kbYesNoCancel Or kbDefaultButton2, "title text")
'n = MsgBox("message", kbAbortRetryIgnore Or kbDefaultButton3, "title text")
'
n = MsgBox(" to save succeeding generations from the scourge of war, which twice in our lifetime has brought untold sorrow to mankind, and", kbOKOnly, "WE THE PEOPLES OF THE UNITED NATIONS DETERMINED")
PRINT NOW()
Function test() Return Null End Function Print "'_" + Nz(test) + "_'" ' --> ""
'PRINT #1, USING "##.### "; 12.12345 PRINT "Hello baby!"; ":-)", "----" DIM s AS STRING = "1" DIM s2 AS STRING = "2" DIM s3 AS STRING = "3" PRINT s, s2, s3
OPTION OLDBASIC
TYPE TestRecord
Student AS STRING * 20
Result AS SINGLE
END TYPE
DIM meineKlasse AS TestRecord
OPEN "c:\kbasic\examples\test\ENDRESULTS.DAT" FOR RANDOM AS #1 LEN = LEN(meineKlasse)
meineKlasse.Student = "Bernd Noetscher"
meineKlasse.Result = 99
PUT #1, 1, meineKlasse
CLOSE #1
OPEN "c:\kbasic\examples\test\ENDRESULTS.DAT" FOR RANDOM AS #1 LEN = LEN(meineKlasse)
GET #1, 1, meineKlasse
PRINT "STUDENT:", meineKlasse.Student
PRINT "SCORE:", meineKlasse.Result
CLOSE #1
OPTION OLDBASIC OPTION EXPLICIT OFF RANDOMIZE TIMER x% = INT(RND * 6) + 1 y% = INT(RND * 6) + 1 PRINT "2 throws with one dice: 1st throw ="; x%; "and 2nd throw ="; y%
DIM s = "Das ist alles was wir brauchen. Fang nochmal von vorne an." AS STRING DIM pattern AS STRING = "vorne" DIM replaceBy AS STRING = "hinten99999999999999999999999999" 'DIM replaceBy AS STRING = "vorne" s = REPLACE(s, pattern, replaceBy) PRINT s
PRINT RIGHT$("I'm living in Germany", 7)
'PRINT RIGHT$("I'm living in Germany", LEN("Germany"))
END
OPTION OLDBASIC OPTION EXPLICIT OFF RANDOMIZE TIMER x% = INT(RND * 6) + 1 y% = INT(RND * 6) + 1 PRINT "2 turns with one dice: turn 1 ="; x%; "and turn 2 ="; y%
PRINT RTRIM$(" bedazzeled ")
SHELL ("DIR")
'SHELL ("LS")
PRINT SIN(44)
PRINT SPACE$(4.3 + 2) PRINT "*" + SPACE(5) + "*"
' normally repeating endlessly, but we use stop!
DO WHILE TRUE
STOP
LOOP
Dim Text1 As String, Text2 As String, Vergl As Integer Text1 = "ABCD" : Text2 = "abcd" ' Vergl = StrComp(Text1, Text2, 1) ' result:0. Print Vergl Vergl = StrComp(Text1, Text2, 0) ' result:-1. Print Vergl Vergl = StrComp(Text2, Text1) ' result:1. Print Vergl
Dim v AS STRING = String$(23, "*") Print v
DIM s = "Mondscheinsonate von Beethoven" AS STRING PRINT STRREVERSE(s) ' --> nevohteeB nov etanosniehcsdnoM
PRINT TAN(333)
PRINT TRIM$(" bedazzeled ")
PRINT UCASE$("kbasic")
DIM s AS STRING s = "43.8" PRINT VAL(s) DIM d = VAL(s)
Dim TextLine As String, ff As Integer ff = FreeFile ' next availaible filehandle Open "c:\kbasic15\examples\test\test.txt" For Input Access Read As #ff ' open test file Do While Not EOF(ff) ' while end of file has not been reached Line Input #ff, TextLine ' store next line in string print TextLine Loop Close #ff ' close file
OPTION OLDBASIC
DIM Rec1$, Rec2$
CLS
OPEN "c:\kbasic15\examples\test\LISTEN.TXT" FOR APPEND AS #1
DO
INPUT " NAME: ", Name$
INPUT " AGE: ", Age$
WRITE #1, Name$, Age$
INPUT "More entries?"; R$
LOOP WHILE UCASE$(R$) = "Y"
CLOSE #1
'print file on screen
OPEN "c:\kbasic15\examples\test\LISTEN.TXT" FOR INPUT AS #1
CLS
PRINT "Entries of file:": PRINT
DO WHILE NOT EOF(1)
INPUT #1, Rec1$, Rec2$
PRINT Rec1$, Rec2$
LOOP
CLOSE #1
KILL "LIST"
/* Dim A As Variant A = Array(10,20,30) Dim B As Variant = A */ Dim A As Variant A = Array(10, 20, 30) Dim B As Variant = Array(10, 20, 30) B = A B = A(1) B(2) = A(2)
BEEP
OPTION OLDBASIC
DIM Name$, Age$, R$, Rec1$, Rec2$
CLS
OPEN "c:\kbasic15\examples\test\LISTEN2.txt" FOR BINARY AS #1
DO
INPUT " NAME: ", Name$
INPUT " AGE: ", Age$
WRITE #1, Name$, Age$
INPUT "More entries?"; R$
LOOP WHILE UCASE$(R$) = "Y"
CLOSE #1
'print file on screen
OPEN "c:\kbasic15\examples\test\LISTEN2.txt" FOR INPUT AS #1
CLS
PRINT "Entries of file:": PRINT
DO WHILE NOT EOF(1)
INPUT #1, Rec1$, Rec2$
PRINT Rec1$, Rec2$
LOOP
CLOSE #1
PRINT CCUR(8.8)
'PRINT CDATE(899999998) ' integer not allowed
PRINT CDATE("2006-12-12") ' must be like this format yyyy-mm-dd
CHDIR("/home/bernd")
CHDRIVE "C" ' change to D:
Dim Msg
On Error Resume Next
Err.Clear
Err.Raise(6)
If Err.Number <> 0 Then
Msg = "Error # " & Str(Err.Number) & " " _
& Err.Source & Chr(10) & Err.Description
Print Msg
End If
Dim I As Integer, filename As String For I = 1 To 3 ' repeat loop 3 times filename = "c:\kbasic\examples\test\TESTING" & I ' create filename Open filename For Output As #I ' open file Print #I, "Ein Test.", "Oder mehr?" ' write string into file Next I Close ' close all 3 opened files
Option OldBasic ' CLS clearing the terminal screen ' with a new background color Print "This is to show the CLS command" Input "To clear the screen, press [Return]", keypressed$ ' changes the background color: Color(2, 1) CLS Print "This is green text on a blue screen!"
Color(14) Print "Hi............" Color(14, 1) Print "Nadja......."
Dim s As String s = Command$ Print s
Option OldBasic Print Pos(0) Input s$ Print CsrLin Print s$
' Windows:
' current path of C: ist "C:\WINDOWS\SYSTEM32".
' current path of D: ist "D:\kbasic".
' C: is the active drive.
Dim path As String
path = CurDir' returns "C:\WINDOWS\SYSTEM32".
path = CurDir("C") ' returns "C:\WINDOWS\SYSTEM32".
path = CurDir("D") ' returns "D:\kbasic".
Option OldBasic
Function doubleit (ByVal no As Variant) As Variant
If IsNumeric(no) Then
doubleit = no * 2 ' return result
Else
doubleit = CVErr(2001) ' return user defined error
End If
End Function
Sub test()
Dim k = doubleit("395.45')bernd")
Print IsError(k) : Print k
End Sub
CLS
test()
PRINT DATE$
Dim Date1 As Date
Dim Interval As String
Dim Number As Integer
Dim Msg
Interval = "m"
Date1 = InputBox("Input the date") ' #yyyy-mm-dd#
Number = Val(InputBox("Input the number of months to add"))
Msg = "New date: " & DateAdd(Interval, Number, Date1)
MsgBox Msg
Dim Date1 As Date
Dim Msg
Date1 = InputBox("Input the date")
Msg = "Days till today: " & DateDiff("d", Now, Date1)
MsgBox Msg
$End
Dim a As Currency = 1.2
Dim b As Currency = 2.5
a = a + b
$End
Dim k As Date
Dim s As String
s = s + k
'Print k + s
'Print k + 99
Dim Date1 As Date
Dim Msg
Date1 = InputBox("Input a date:")
Msg = "quarter: " & DatePart("q", Date1)
MsgBox Msg
Dim Date1 Date1 = DateSerial(1969, 2, 12) ' return Date1
Dim Date1
Date1 = DateValue("1979-02-03")
Dim Date1, Day1
Date1 = #2006-12-12#
Day1 = Day(Date1) ' --> 12
Option OldBasic
CLS
'file1 = Dir("C:\WINDOWS\*.INI")
'file1 = Dir("/opt/kde/*.*") ' for linux
Dim Name1 As String
Name1 = Dir("c:\kbasic15\i*" /*, kbDirectory*/ )' first entry
Do While Name1 <> "" ' loop
' If Name1 <> "." And Name1 <> ".." Then
If (GetAttr(/*Path1 & */Name1) And kbDirectory) = kbDirectory Then
Print "Dir --> " + Name1
Else
Print "File " + Name1
End If
'End If
Name1 = Dir ' next entry
Loop
OPTION OLDBASIC
DIM a$
CLS
OPEN "c:\kbasic\examples\test\TEST2.DAT" FOR OUTPUT AS #1
FOR i% = 1 TO 10
WRITE #1, "" + i%, 2 * i%, 5 * i%
NEXT i%
CLOSE #1
OPEN "c:\kbasic\examples\test\TEST2.DAT" FOR INPUT AS #1
DO
LINE INPUT #1, a$
PRINT a$
LOOP UNTIL (EOF(1))
PRINT ERL
Dim Msg On Error Resume Next Err.Clear Err.Raise (65) If ERR.Number <> 0 Then Msg = "Error # " & Str(Err.Number) & " " _ & Err.Source & Chr(13) & Err.Description Print Msg, , "Error" End If
CLS
Dim Msg2
On Error GoTo myError
'On Error Resume Next
Print ""
Dim m = 0
Dim i As Integer = 3 / m
Print "yes"
End
/*
Err.Clear
Err.Raise(6, "cool-error?", "in sourcefile xyz")
If Err.Number <> 0 Then
Msg2 = "Error # " & Str(Err.Number) & " " & Err.Source & Chr(13) & Err.Description
Print Msg2
End If
End
*/
myError:
Msg2 = "myError # " & Str(Err.Number) & "(" & Err.Source & ") " & Err.Description
Print Msg2
Print Err
Print Erl
m = 1
Resume
End
/*
Dim Msg2
On Error Resume Next
Print ""
Err.Clear
Err.Raise(6, "cool-error?", "in sourcefile xyz")
Err.Clear
If Err.Number <> 0 Then
Msg2 = "Error # " & Str(Err.Number) & " " & Err.Source & Chr(13) & Err.Description
Print Msg2
End If
*/
Dim filehandle, Mode filehandle = 1 Open "c:\kbasic14\examples\test\liste.txt" For Append As filehandle Mode = FileAttr(filehandle, 1) ' returns 8 (Append). Close filehandle ' close file
Print FileDateTime("c:\kbasic14\examples\test\liste.txt")
FILES
PRINT FRE("")
Dim Index1, filehandle For Index1 = 1 To 5 filehandle = FreeFile ' next free available file handle Open "c:\kbasic\examples\test\TESTER" & Index1 & ".txt" For Output As #filehandle Write #filehandle, "example text." Close #filehandle Next
TYPE TestRecord
Student AS STRING * 20
Result AS SINGLE
END TYPE
DIM meineKlasse AS TestRecord
OPEN "c:\kbasic15\examples\test\ENDRESULTS2.DAT" FOR RANDOM AS #1 LEN = LEN(meineKlasse)
meineKlasse.Student = "Bernd Noetscher"
meineKlasse.Result = 99
PUT #1, 1, meineKlasse
CLOSE #1
meineKlasse.Student = ""
meineKlasse.Result = 0
OPEN "c:\kbasic15\examples\test\ENDRESULTS2.DAT" FOR RANDOM AS #1 LEN = LEN(meineKlasse)
GET #1, 1, meineKlasse
PRINT "STUDENT:", meineKlasse.Student
PRINT "SCORE:", meineKlasse.Result
CLOSE #1
Dim Attr1
Attr1 = GetAttr("c:\kbasic14\examples\test\liste.txt")
Dim dd As Date = "#2006-12-12 4:35:17" Dim Time1, Hour1 Time1 = #4:35:17 PM# Hour1 = Hour(Time1)
CLS Print "Press Esc, to stop ..." Do Loop Until Inkey = Chr(27) '27 is the ASCII-Code for Esc.
OPTION OLDBASIC
DIM REC$
CLS
OPEN "c:\kbasic\examples\test\LISTE.TXT" FOR OUTPUT AS #1
DO
INPUT " NAME: ", Name$ 'input from keyboard
INPUT " Age: ", Age$
WRITE #1, Name$, Age$
INPUT "Type a new entry"; R$
LOOP WHILE UCASE$(R$) = "Y"
CLOSE #1
'print content of file
OPEN "c:\kbasic\examples\test\LISTE.TXT" FOR INPUT AS #1
CLS
PRINT "entries of file:": PRINT
DO WHILE NOT EOF(1)
LINE INPUT #1, REC$
PRINT REC$
LOOP
CLOSE #1
Option OldBasic Type myRecordset ' define type id As Integer Name2 As String * 20 End Type Dim DSet1 As myRecordset, MaxSize, DSetNo ' file with random access Open "c:\kbasic\examples\test\file1.txt" For Random As #1 Len = Len(DSet1) MaxSize = LOF(1) \ Len(DSet1) ' define count of records in file For DSetNo = MaxSize To 1 Step - 1 Seek #1, DSetNo ' set position DSet1.id = DSetNo DSet1.Name2= "Bernd" + DSetNo * 1000 Put #1, , DSet1 ' read recordset Next Close #1 ' close file ' file with random access Open "c:\kbasic\examples\test\file1.txt" For Random As #1 Len = Len(DSet1) MaxSize = LOF(1) \ Len(DSet1) ' define count of records in file For DSetNo = MaxSize To 1 Step - 1 Seek #1, DSetNo ' set position Get #1, , DSet1 ' read recordset print DSet1.Name2 Next Close #1 ' close file /* Dim CharacterPos, Character1, Zeichen1 Open "c:\kbasic\examples\test\file1.txt" For Input As #1 ' open file for reading MaxSize = LOF(1) ' define file size For CharacterPos = MaxSize To 1 Step -1 Seek #1, CharacterPos ' set position Zeichen1 = Input(1, #1) ' read character Next Close #1 ' close file */
Dim i[8] As Integer Dim x As String Print IsArray(i) Print IsArray(x)
Dim x As Boolean Print IsBoolean(x)
Dim i As Byte Dim x As String Print IsByte(i) Print IsByte(x)
Dim c As Currency c = 23 Print IsCurrency(c)
PRINT ISDATE(34) PRINT ISDATE(#2006-12-12#)
Dim i As Double Dim x As String Print IsDouble(i) Print IsDouble(x)
Dim v As Variant Dim n As Integer v = Empty Print IsEmpty(v) Print IsEmpty(n) v = 99 Print IsEmpty(v)
Dim v As Variant 'Dim v As integer v = Error Print IsError(v)
Dim i As Integer Dim k As String Print IsInteger(i) Print IsInteger(k)
Dim i As Long Dim k As String Print IsLong(i) Print IsLong(k)
Sub test(Optional k As String)
If IsMissing(k) Then
Print "k is missing"
Else
Print "k: " + k
End If
End Sub
test()
test("hello here is k")
Dim o As Object o = Null Print IsNull(o) ' 'Dim f As New Form ' 'Print IsNull(f) '
Dim v As Variant
v = 12
v = "!"
Print IsNumeric(v)
Print IsNumeric(3343.678)
Print IsNumeric("hey")
Class t End Class Dim k As New t Dim o As New Object Dim z As Integer Print IsObject(k) Print IsObject(o) Print IsObject(z)
Dim i As Short Dim x As String Print IsShort(i) Print IsShort(x)
Dim i As Single Dim x As String Print IsSingle(i) Print IsSingle(x)
Dim i As Long Dim k As String Print IsString(i) Print IsString(k)
Dim i As Variant Dim x As String Print IsVariant(i) Print IsVariant(x)
ECHO "<HTML>"
ECHO "<HEAD>"
ECHO "<TITLE>Web pages on the fly</TITLE>"
ECHO "</HEAD>"
ECHO "<BODY>"
ECHO "<TABLE WIDTH=100% BORDER=0>"
ECHO "<TR>"
ECHO "<TD>"
ECHO "Hello World! Dynamically created HTML files...<br>"
FOR i AS INTEGER = 1 TO 100
ECHO "i=" + i + "<br>"
NEXT
ECHO "</TD>"
ECHO "</TR>"
ECHO "</TABLE>"
ECHO "</BODY>"
ECHO "</HTML>"
/*
ECHO "_
<HTML>_
"<HEAD>"_
"<TITLE>Web pages on the fly</TITLE>"_
"</HEAD>"_
"<BODY>"_
"<TABLE WIDTH=100% BORDER=0>"_
"<TR>"_
"<TD>"_
"Hello World! Dynamically created HTML files..."_
"</TD>"_
"</TR>"_
"</TABLE>"_
"</BODY>"_
"</HTML>"
*/
' This deletes the file "test.xml": KILL "c:\kbasic\examples\test\test.xml"
Dim text2 As String Open "c:\kbasic14\examples\test\test.txt" For Input As #1 ' open file Do While Not EOF(1) ' loop until end of file Line Input #1, text2 ' read line into variable Print text2 Loop Close #1
PRINT LN(33)
Dim Position1, Line1$, Line2$ Open "c:\kbasic\examples\test\LISTEN.TXT" For Input As #1 Do While Not EOF(1) Input(#1, Line2) Line1 = Line1 & Line2 Position1 = Loc(1) Print Line1; "-->"; Position1 Loop Close #1
OPTION OLDBASIC CLS LOCATE 5, 5 row% = CSRLIN column% = POS(0) PRINT "position 1 (press any key)" DO LOOP WHILE INKEY$ = "" LOCATE (row% + 2), (column% + 2) PRINT "position 2"
OPTION OLDBASIC INPUT "input filename: "; f$ 'f$ = "c:\capture.avi" OPEN f$ FOR BINARY AS #1 PRINT "file len is = "; LOF(1) CLOSE
Dim Time1, Minute1 Time1 = #4:35:17 PM# Minute1 = Minute(Time1) ' Minute1 contains 35.
MKDIR "C:\TEMP\TEST" CHDIR "C:\TEMP" FILES RMDIR "TEST"
Dim Date1, Month1 Date1 = #1979-02-02# Month1 = Month(Date1) ' Month1 contains 2. Print Month1
Dim strMonatsname strMonatsname = MonthName(1) ' January strMonatsname = MonthName(1, True) ' Jan
NAME "old.txt" AS "new.txt"
PRINT OCT$(8)
Dim TextLine As String, ff As Integer ff = FreeFile ' next availaible filehandle Open "c:\kbasic15\examples\test\test.txt" For Input As #ff ' open test file Do While Not EOF(ff) ' while end of file has not been reached Line Input #ff, TextLine ' store next line in string Print TextLine Loop Close #ff ' close file
Dim TextLine As String, ff As Integer ff = FreeFile ' next availaible filehandle ' SYNTAX: OPEN mode$,[#]fileno%,file$[,recordlen%] ' mode$ "O" or "o" for output, "I" or "i" for input, "A" or "a" for append Open "I", #ff, "c:\kbasic\examples\test\test.txt" ' open test file Do While Not EOF(ff) ' while end of file has not been reached Line Input #ff, TextLine ' store next line in string Print TextLine Loop Close #ff ' close file
OPTION OLDBASIC
CLS
OPEN "c:\kbasic\examples\test\LISTEN.TXT" FOR OUTPUT AS #1
DO
INPUT " NAME: ", Name$ 'input from keyboard
INPUT " Age: ", Age$
WRITE #1, Name$, Age$
INPUT "Type a new entry"; R$
LOOP WHILE UCASE$(R$) = "Y"
CLOSE #1
'print content of file
OPEN "c:\kbasic\examples\test\LISTEN.TXT" FOR INPUT AS #1
CLS
PRINT "entries of file:": PRINT
DO WHILE NOT EOF(1)
LINE INPUT #1, REC$
PRINT REC$
LOOP
CLOSE #1
OPTION OLDBASIC PRINT POS(0) INPUT s$ PRINT CSRLIN PRINT s$
OPTION OLDBASIC DIM Name$, Age$ CLS OPEN "c:\kbasic14\examples\test\LIST4.txt" FOR OUTPUT AS #1 DO INPUT " NAME: ", Name$ INPUT " AGE: ", Age$ PRINT #1, Name$, Age$ INPUT "More entries?"; R$ LOOP WHILE UCASE$(R$) = "Y" CLOSE #1
OPTION OLDBASIC
OPTION EXPLICIT OFF
FOR y% = 0 TO 200
FOR x% = 0 TO 320
PSET(x%, y%)
NEXT
NEXT
TYPE TestRecord
Student AS STRING * 20
Result AS SINGLE
END TYPE
DIM meineKlasse AS TestRecord
OPEN "ENDRESULTS.DAT" FOR RANDOM AS #1 LEN = LEN(meineKlasse)
meineKlasse.Student = "Bernd Noetscher"
meineKlasse.Result = 99
PUT #1, 1, meineKlasse
CLOSE #1
OPEN "ENDRESULTS.DAT" FOR RANDOM AS #1 LEN = LEN(meineKlasse)
GET #1, 1, meineKlasse
PRINT "STUDENT:", meineKlasse.Student
PRINT "SCORE:", meineKlasse.Result
CLOSE #1
KILL "ENDRESULTS.DAT"
RESET
Dim red As Integer red = RGB(255, 0, 0) Print Hex(red)
MKDIR "C:\TEMP\TEST" CHDIR "C:\TEMP" FILES RMDIR "TEST"
Dim Time1, Second1 Time1 = #4:35:47 PM# Second1 = Second(Time1) ' Second1 contains 47
Option OldBasic Type myRecordset ' define type id As Integer Name2 As String * 20 End Type Dim DSet1 As myRecordset, MaxSize, DSetNo ' file with random access Open "c:\kbasic\examples\test\file1.txt" For Random As #1 Len = Len(DSet1) MaxSize = 10 ' define count of records in file For DSetNo = MaxSize To 1 Step - 1 Seek #1, DSetNo ' set position DSet1.id = DSetNo DSet1.Name2 = "Bernd" + DSetNo * 1000 Put #1, , DSet1 ' write recordset Next Close #1 ' close file ' file with random access Open "c:\kbasic\examples\test\file1.txt" For Random As #1 Len = Len(DSet1) MaxSize = LOF(1) \ Len(DSet1) ' define count of records in file Print "MaxSize = " + MaxSize For DSetNo = MaxSize To 1 Step - 1 Seek #1, DSetNo ' set position Get #1, , DSet1 ' read recordset Print DSet1.id 'Print DSet1.Name2 Next Close #1 ' close file
PRINT SGN(77) PRINT SGN(1), SGN(-1), SGN(0) ' 1 -1 0
PRINT "Pausing 10 seconds..." SLEEP 10 PRINT "Continue..."
PRINT "Text1"; SPC(10) "Text2"
PRINT SQR(44)
CLS Print "1", Tab(25) "Hio" 'Print "Hi", "2"
PRINT TIME$
Dim Time1 Time1 = TimeSerial(16, 35, 17) ' in integer format --> 16:35:17
Dim Time1
Time1 = TimeValue("4:35:19") ' return time as date
Class k End Class Enum e o End Enum Type t o As Integer End Type Dim kk As k Dim ee As e Dim tt As t Dim ll As Label Dim NullVar, Type1, StrVar As String, IntVar As Integer, CurVar As Currency Dim ArrayVar(1 To 5) As Integer NullVar = Null ' Null zuweisen. 'NullVar = CVERR(2) 'NullVar = Empty Type1 = TypeName(StrVar) ' returns "String". Type1 = TypeName(IntVar) ' returns "Integer". Type1 = TypeName(CurVar) ' returns "Currency". Type1 = TypeName(NullVar) ' returns "Null". Type1 = TypeName(ArrayVar) ' returns "Integer()" Type1 = TypeName(kk) Type1 = TypeName(ee) ' returns the internal id only Type1 = TypeName(tt) ' returns the internal id only Type1 = TypeName(ll)
CLS ' numeric PRINT USING "###"; 1 'PRINT USING "#####"; 12.12545 'PRINT USING "###.##"; 12.12545 ' rounds automatically 'PRINT USING "+###"; +12.12345 'PRINT USING "+####"; -12.12345 'PRINT USING "x###x"; 12.12345 'PRINT USING "###.###"; 12.12345 'PRINT USING "$$####"; -12.12345 'PRINT USING "$$####"; -1234.12345 'PRINT USING "**####"; -12.12345 'PRINT USING "**$###"; -1.12345 'PRINT USING "$####"; -1.12345 'PRINT USING "*####"; - 1.12345 'PRINT USING "$$####"; -1.12345 'PRINT USING "####"; -12.12345 'PRINT USING "**$####-x"; -12.12345 'PRINT USING "####-x"; -12.12345 'PRINT USING "####-x"; 12.12345 'PRINT USING "+^^^^"; 12.12345 ' not allowed 'PRINT USING "**^^^^"; 290.12345 'PRINT USING "**^^^^^"; -999912.12345 'PRINT USING "##,.##"; 1.12345 'PRINT USING "##,.##"; 12.12345 'PRINT USING "##,.##"; 1234.12345 'PRINT USING "##,.##"; 123456.12345 'PRINT USING "##,.##"; 1234567.12345 ' string PRINT USING "x&x x&x"; "Hello World!", "Bernd" 'PRINT USING "x&x x&x"; "Hello World!" 'PRINT USING "x&x x&x"; "Hello World!", 'PRINT USING "x&x x&x"; "Hello World!"; 'PRINT USING "x&x"; "Hello World!" 'PRINT USING "&"; "Hello World!" 'PRINT USING "_!_"; "Hello World!" 'PRINT USING "_\ \_"; "Hello World!" 'PRINT "Hello World!" ' escape code 'PRINT USING "x_&x&x"; "Hello World!"
Dim s As String Print VarType(s)
Dim Date1, Weekday1 Date1 = #2006-05-10# Weekday1 = Weekday(Date1) ' Weekday1 contains 4
Dim sWDay As String Dim n As Integer = Weekday(#2006-05-10#) sWDay = WeekdayName(n) MsgBox sWDay
OPTION OLDBASIC DIM Name$, Age$ DIM Rec1$, Rec2$ CLS OPEN "c:\kbasic\examples\test\LIST.txt " FOR OUTPUT AS #1 DO INPUT " NAME: ", Name$ INPUT " AGE: ", Age$ WRITE #1, Name$, Age$ INPUT "More entries?"; R$ LOOP WHILE UCASE$(R$) = "Y" CLOSE #1 'print file on screen OPEN "c:\kbasic\examples\test\LIST.txt" FOR INPUT AS #1 CLS PRINT "Entries of file:" : PRINT DO WHILE NOT EOF(1) INPUT #1, Rec1$, Rec2$ PRINT Rec1$, Rec2$ LOOP CLOSE #1
Dim Date1, Year1 Date1 = #2006-12-12# Year1 = Year(Date1) ' Year1 contains 1969.
Class Salsa
Static
Print "Static part of class"
End Static
'
' Public Sub test()
' Print "test!!!"
' End Sub
/*
Private pvtFname As String
Public Property Nickname As String
Get
' return pvtFname
print "Hi"
End Get
Set ( ByVal Value As String )
print "Hi"
'pvtFname = Value
End Set
End Property
*/
End Class
Class rumba
Private latein As Integer
Public englisch As String
Dim k
'Public mySalsa As New Salsa
'PRIVATE CONST kbAccess = 0
Public Sub dance_rumba()
Print "rumba!!!"
'print mySalsa.var
END SUB
' CONSTRUCTOR rumba2()
' PRINT "constructor"
' END CONSTRUCTOR
'
' DESTRUCTOR rumba3()
' PRINT "destructor"
' END DESTRUCTOR
END CLASS
'Dim Emp As rumba = New rumba
DIM m AS NEW rumba
m.dance_rumba()
'Print m.latein
'Print m.mySalsa.var
END
$END
CLASS jive INHERITS rumba
PUBLIC SUB test() THROWS rumba
THROW NEW rumba
END SUB
PUBLIC SUB dance()
dance_rumba()
PRINT "dancing Bernd"
END SUB
FUNCTION monique(BYREF i, BYVAL h AS DOUBLE) AS INTEGER
DIM hh AS rumba
dance()
latein = 0
englisch = "Do you speak English?"
Me.dance()
Parent.latein = 99
Me.latein = 99
hh.latein = 10000
monique = i
END FUNCTION
END CLASS
DIM m AS NEW jive
m.dance()
m.dance_rumba()
TRY
m.test()
CATCH (b AS rumba)
PRINT "got you!"
END CATCH
m.test()
'm.latein = 0
'm.englisch = "Do you speak English?"
'PRINT m.monique( m, 12.2 )
CLASS ABSTRACT rumba
PUBLIC ABSTRACT SUB dance_rumba()
PRIVATE latein AS INTEGER
PUBLIC englisch AS STRING
PRIVATE CONST kbAccess = 0
CONSTRUCTOR rumba()
DIM p = 77777777
END CONSTRUCTOR
DESTRUCTOR rumba()
DIM a = 3333
END DESTRUCTOR
END CLASS
CLASS jive INHERITS rumba
CONSTRUCTOR jive()
DIM b = 99
FOR i AS INTEGER = 1 TO 10
PRINT i
NEXT
END CONSTRUCTOR
DESTRUCTOR jive()
DIM a = 888
END DESTRUCTOR
PUBLIC SUB dance_rumba()
PRINT "rumba!!!"
END SUB
END CLASS
DIM m AS VARIANT
m = NEW jive
' m = NEW rumba ' this line would cause an error, because the class is declared as abstract
'PRINT ISNULL(m)
'Dim o As New face
'Print o.mind2
' class example
Class body
Public mind2 As Integer
Static Public brain2 As Integer
Constructor body()
Print "body.Constructor!!!!"
mind2 = 1979
End Constructor
Destructor body()
Print "body.Destructor!!!!"
End Destructor
Constructor body(n As Integer)
Print "body22.Constructor!!!!"
mind2 = n
End Constructor
Sub cry()
Print "body.cry"
mind2 = 777
End Sub
Static Sub smile()
Print "body.smile"
End Sub
Static
Print "body::Class static code block!!!!"
'face.brain = 1 ' not accessable forwardly inside static code block of class
End Static
End Class
Class face Inherits body
Type class_type
a As Integer
b[10] As Integer
End Type
Public mind[10] As class_type
Static Public brain As Integer
Constructor face()
' Parent.body(99999) ' call directly parent constructor with other arguments
Print "Constructor!!!!"
End Constructor
Destructor face
Print "Destructor!!!!"
End Destructor
Static
Print "face::Class static code block!!!!"
Dim i As Integer
i = 99
brain = 123456789
brain2 = 66666666
End Static
Static Sub smile()
Print "smile"
' mind = 77 ' instance variable not accessable by static method
End Sub
Sub laugh()
Print "laugh"
End Sub
Sub cry()
Print "cry"
mind[3].b[5] = 99
Me.mind[3].b[5] = 88
mind2 = 11111
Parent.mind2 = 88
' body.smile() ' allowed: static method called inside instance method
' 'face.smile()' allowed: static method called inside instance method
'Me.laugh()
'Parent.cry()
End Sub
End Class
'body.smile()
face.smile()
'l.smile() ' variable name not allowed to access static method; use class name instead
'Dim l As face
'l = New face
Dim l As New face
l.laugh()
l.cry()
'Print "l.mind = " + l.mind
Print l.mind[3].b[5]
l.mind[3].b[5] = l.mind[3].b[5] + 1
Print l.mind[3].b[5]
'l = Null ' release object of l
'Dim o As New face
'Print o.mind2
' class example
Class body
Public mind2 As Integer
Static Public brain2 As Integer
Constructor body()
Print "body.Constructor!!!!"
mind2 = 1979
End Constructor
Destructor body()
Print "body.Destructor!!!!"
End Destructor
Constructor body(n As Integer)
Print "body22.Constructor!!!!"
mind2 = n
End Constructor
Sub cry()
Print "body.cry"
mind2 = 777
End Sub
Static Sub smile()
Print "body.smile"
End Sub
Static
Print "body::Class static code block!!!!"
'face.brain = 1 ' not accessable forwardly inside static code block of class
End Static
End Class
Class face Inherits body
Type class_type
a As Integer
b[10] As Integer
End Type
Public mind[10] As class_type
Static Public brain As Integer
Constructor face()
' Parent.body(99999) ' call directly parent constructor with other arguments
Print "Constructor!!!!"
End Constructor
Destructor face
Print "Destructor!!!!"
End Destructor
Static
Print "face::Class static code block!!!!"
Dim i As Integer
i = 99
brain = 123456789
brain2 = 66666666
End Static
Static Sub smile()
Print "smile"
' mind = 77 ' instance variable not accessable by static method
End Sub
Sub laugh()
Print "laugh"
End Sub
Sub cry()
Print "cry"
mind[3].b[5] = 99
Me.mind[3].b[5] = 88
mind2 = 11111
Parent.mind2 = 88
' body.smile() ' allowed: static method called inside instance method
' 'face.smile()' allowed: static method called inside instance method
'Me.laugh()
'Parent.cry()
End Sub
End Class
'body.smile()
face.smile()
'l.smile() ' variable name not allowed to access static method; use class name instead
'Dim l As face
'l = New face
Dim l As New face
l.laugh()
l.cry()
'Print "l.mind = " + l.mind
Print l.mind[3].b[5]
l.mind[3].b[5] = l.mind[3].b[5] + 1
Print l.mind[3].b[5]
'l = Null ' release object of l
'Dim o As New face
'Print o.mind2
' class example
Class body
Type class_type2
a As Integer
b[10] As Integer
End Type
Public mind3[10] As class_type2
Public mind2 As Integer
Static Public brain2 As Integer
Constructor body()
Print "body.Constructor!!!!"
mind2 = 1979
End Constructor
Destructor body()
Print "body.Destructor!!!!"
End Destructor
Constructor body(n As Integer)
Print "body22.Constructor!!!!"
mind2 = n
End Constructor
Sub cry()
Print "body.cry"
mind2 = 777
End Sub
Static Sub smile()
Print "body.smile"
End Sub
' Static
' Print "body::Class static code block!!!!"
' 'face.brain = 1 ' not accessable forwardly inside static code block of class
' End Static
End Class
Class face 'Inherits body
Type class_type
a As Integer
b[10] As Integer
End Type
'Public mind[10] As class_type
Public mind4[10] As body
'Static Public brain As Integer
Constructor face()
' Parent.body(99999) ' call directly parent constructor with other arguments
Print "Constructor!!!!"
End Constructor
Destructor face
Print "Destructor!!!!"
End Destructor
' Static
' Print "face::Class static code block!!!!"
' Dim i As Integer
' i = 99
' brain = 123456789
' 'brain2 = 66666666
' End Static
Static Sub smile()
Print "smile"
' mind = 77 ' instance variable not accessable by static method
End Sub
Sub laugh()
Print "laugh"
End Sub
Sub cry()
Print "cry"
mind4[1].mind3[4].b[3] = 9
'mind[3].a = 99
' mind[3].b[5] = 99
' Print mind[3].b[5]
'Me.mind[3].b[5] = 88
'mind2 = 11111
'Parent.mind2 = 88
' body.smile() ' allowed: static method called inside instance method
' 'face.smile()' allowed: static method called inside instance method
'Me.laugh()
'Parent.cry()
End Sub
End Class
'body.smile()
'face.smile()
'l.smile() ' variable name not allowed to access static method; use class name instead
'Dim l As face
'l = New face
Dim l[10] As face
l[4] = New face
'l[4].cry()
l[4].mind4[1] = New body
'l[4].mind4[1].cry()
l[4].cry()
l[4].mind4 [1].mind3 [4].b[3] = l[4].mind4 [1].mind3 [4].b[3] + 91
Print l[4].mind4[1].mind3[4].b[3]
/*
'l[4].laugh()
l[4].cry()
l[4].mind[3].b[5] = 88
Print l[4].mind[3].b[5]
l[4].mind[3].b[5] = l[4].mind[3].b[5] + 1
Print l[4].mind[3].b[5]
'l[4] = Null ' release object of l
*/
'Dim o As New face
'Print o.mind2
' class example
Class body
Type class_type2
a As Integer
b[10] As Integer
End Type
Public mind3[10] As class_type2
Public mind2 As Integer
Static Public brain2 As Integer
Constructor body()
Print "body.Constructor!!!!"
'mind2 = 1979
End Constructor
Destructor body()
Print "body.Destructor!!!!"
End Destructor
Constructor body(n As Integer)
Print "body22.Constructor!!!!"
' mind2 = n
End Constructor
Sub cry()
Print "body.cry"
' mind2 = 777
End Sub
Static Sub smile()
Print "body.smile"
End Sub
' Static
' Print "body::Class static code block!!!!"
' 'face.brain = 1 ' not accessable forwardly inside static code block of class
' End Static
End Class
Class face Inherits body
Type class_type
a As Integer
b[10] As Integer
End Type
'Public mind[10] As class_type
Public mind4[10] As body
'Static Public brain As Integer
Constructor face()
' Parent.body(99999) ' call directly parent constructor with other arguments
Print "Constructor!!!!"
End Constructor
Destructor face
Print "Destructor!!!!"
End Destructor
' Static
' Print "face::Class static code block!!!!"
' Dim i As Integer
' i = 99
' brain = 123456789
' 'brain2 = 66666666
' End Static
Static Sub smile()
Print "smile"
' mind = 77 ' instance variable not accessable by static method
End Sub
Sub laugh()
Print "laugh"
End Sub
Sub cry()
Print "cry"
mind4[1].mind3[4].b[3] = 69
'mind[3].a = 99
' mind[3].b[5] = 99
' Print mind[3].b[5]
'Me.mind[3].b[5] = 88
'mind2 = 11111
'Parent.mind2 = 88
' body.smile() ' allowed: static method called inside instance method
' 'face.smile()' allowed: static method called inside instance method
'Me.laugh()
'Parent.cry()
End Sub
End Class
'body.smile()
'face.smile()
'l.smile() ' variable name not allowed to access static method; use class name instead
'Dim l As face
'l = New face
Dim l[10] As face
l[4] = New face
l[4] = null
End
'Public mind4[10] As body
l[4].mind4[1] = New body
l[4].mind4[1] = Null
End
l[4].cry()
'l[4].mind4[1].cry()
l[3] = l[4]
l[4].mind4[1].mind3[4].b[3] = 9
Print l[4].mind4[1].mind3[4].b[3]
/*
'l[4].laugh()
l[4].cry()
l[4].mind[3].b[5] = 88
Print l[4].mind[3].b[5]
l[4].mind[3].b[5] = l[4].mind[3].b[5] + 1
Print l[4].mind[3].b[5]
'l[4] = Null ' release object of l
*/
' class example
Class being
Constructor being()
Print "being.Constructor!!!!"
End Constructor
Sub cry()
Print "being.cry"
End Sub
End Class
Class body Inherits being
Constructor body()
Print "body.Constructor!!!!"
End Constructor
Sub cry()
Print "body.cry"
End Sub
End Class
Class face Inherits being
Constructor face()
Print "face.Constructor!!!!"
End Constructor
Sub cry()
Print "face.cry"
End Sub
End Class
Dim l[10] As being
l[3] = New being
l[4] = New face
l[5] = New body
' polymorphism
l[3].cry()
l[4].cry()
l[5].cry()
/*
If l[3] Is l[4] Then
Print "H"
End If
*/
' class example
Class body
Type class_type2
a As Integer
b[10] As Integer
End Type
Public mind3[10] As class_type2
Public mind2 As Integer
Static Public brain2 As Integer
Constructor body()
Print "body.Constructor!!!!"
'mind2 = 1979
End Constructor
Destructor body()
Print "body.Destructor!!!!"
End Destructor
Constructor body(n As Integer)
Print "body22.Constructor!!!!"
' mind2 = n
End Constructor
Sub cry()
Print "body.cry"
' mind2 = 777
End Sub
Static Sub smile()
Print "body.smile"
End Sub
' Static
' Print "body::Class static code block!!!!"
' 'face.brain = 1 ' not accessable forwardly inside static code block of class
' End Static
End Class
Class face 'Inherits body
Type class_type
a As Integer
b[10] As Integer
End Type
'Public mind[10] As class_type
Public mind4[10] As body
'Static Public brain As Integer
Constructor face()
' Parent.body(99999) ' call directly parent constructor with other arguments
Print "Constructor!!!!"
End Constructor
Destructor face
Print "Destructor!!!!"
End Destructor
' Static
' Print "face::Class static code block!!!!"
' Dim i As Integer
' i = 99
' brain = 123456789
' 'brain2 = 66666666
' End Static
Static Sub smile()
Print "smile"
' mind = 77 ' instance variable not accessable by static method
End Sub
Sub laugh()
Print "laugh"
End Sub
Sub cry()
Print "cry"
mind4[1].mind3[4].b[3] = 69
'mind[3].a = 99
' mind[3].b[5] = 99
' Print mind[3].b[5]
'Me.mind[3].b[5] = 88
'mind2 = 11111
'Parent.mind2 = 88
' body.smile() ' allowed: static method called inside instance method
' 'face.smile()' allowed: static method called inside instance method
'Me.laugh()
'Parent.cry()
End Sub
End Class
'body.smile()
'face.smile()
'l.smile() ' variable name not allowed to access static method; use class name instead
'Dim l As face
'l = New face
Dim l[10] As face
l[4] = New face
'Public mind4[10] As body
l[4].mind4[1] = New body
l[4].mind4[1] = Null
End
l[4].cry()
'l[4].mind4[1].cry()
l[3] = l[4]
l[4].mind4[1].mind3[4].b[3] = 9
Print l[4].mind4[1].mind3[4].b[3]
/*
'l[4].laugh()
l[4].cry()
l[4].mind[3].b[5] = 88
Print l[4].mind[3].b[5]
l[4].mind[3].b[5] = l[4].mind[3].b[5] + 1
Print l[4].mind[3].b[5]
'l[4] = Null ' release object of l
*/
Class movies
Protected sMovieName As String
Sub printName
print sMovieName
End Sub
Constructor movies(s As String)
sMovieName = s
End Constructor
End Class
Class movies2 Inherits movies
Constructor movies2(ByRef s As String)
Parent.movies(s + "2")
End Constructor
End Class
Dim k As Integer = 9
Dim m As New movies2("final fantasy")
m.printName()
Class movies
Protected sMovieName As String
Sub printName
print sMovieName
End Sub
Constructor movies(ByRef s As String)
sMovieName = s
End Constructor
End Class
Class movies2 Inherits movies
Constructor movies2(ByRef s As String)
sMovieName = "?"
End Constructor
End Class
Dim k As Integer = 9
Dim m As New movies2("final fantasy")
m.printName()
Class movies
Protected sMovieName As String
Protected Sub printName
print sMovieName
End Sub
Constructor movies(ByRef s As String)
sMovieName = s
End Constructor
End Class
Class movies2 Inherits movies
Public h As Integer
Constructor movies2(ByRef s As String)
End Constructor
Sub test
printName()
End Sub
End Class
Dim k As Integer = 9
Dim m As New movies2("final fantasy")
'Print m.h
m.test()
'm.printName() ' would cause an error
' class example
Class being
Constructor being()
Print "being.Constructor!!!!"
End Constructor
Sub cry()
Print "being.cry"
End Sub
End Class
Class body Inherits being
Constructor body()
Print "body.Constructor!!!!"
End Constructor
Sub cry()
Print "body.cry"
End Sub
End Class
Class face Inherits being
Constructor face()
Print "face.Constructor!!!!"
End Constructor
Sub cry()
Print "face.cry"
End Sub
End Class
Dim l[10] As being
l[3] = New being
l[4] = New face
l[5] = New body
' polymorphism
l[3].cry()
l[4].cry()
l[5].cry()
' @filepic kde.jpg
' BTW demonstrates loading docu pic...
Class Salsa
Static
Print "Static part of class"
End Static
Public Sub test ( )
Print "test!!!"
End Sub
Private pvtFname As String
End Class
' class example
Class face Inherits body
Public mind As Integer
Static Public brain As Integer
Constructor face()
Print "Constructor!!!!"
End Constructor
Destructor face
Print "Destructor!!!!"
End Destructor
Static
Print "face::Class static code block!!!!"
Dim i As Integer
i = 99
brain = 123456789
End Static
Static Sub smile()
Print "smile"
' mind = 77 ' instance variable not accessable by static method
End Sub
Sub laugh()
Print "laugh"
' Me.mind = 88
End Sub
Sub cry()
Print "cry"
mind = 99
mind2 = 11111
brain2 = 66666666
End Sub
End Class
Class body
Public mind2 As Integer
Static Public brain2 As Integer
Constructor body()
Print "body.Constructor!!!!"
End Constructor
Sub cry()
Print "body.cry"
mind2 = 777
End Sub
Static
Print "body::Class static code block!!!!"
End Static
End Class
'CLS
face.smile()
'End
'Dim l As face
'l = New face
Dim l As New face
l.laugh()
l.cry()
'l.smile() ' not allowed use class name instead
Class b
Dim v As Integer
End Class
Class a Inherits b
Sub t()
Dim k As Integer = Parent.v
End Sub
End Class
Class a Inherits b
Sub t()
Dim k As Integer = Parent.v
Print k
End Sub
'
End Class
Class b
Public v As Integer
End Class
Dim aa As New a
aa.v = 99
aa.t
Class Dict
Type node
item As Integer
info As Integer
End Type
Public a As node
Constructor Dict()
a.item = 1234
a.info = 6789
End Constructor
Destructor Dict()
Print "Dict destructor"
End Destructor
End Class
Dim d As New Dict
CLS
Print d.a.item; d.a.info
End
Type book bkname As String * 100 isbn(1000) As Integer End Type Type address books(10) AS book age(100) As Integer Names As String * 1000 a As book End Type Dim j(1 To 10) As address j(5).age(99) = 123 Print j[5].age[99] j(6).a.isbn(10) = 1000 Print j(6).a.isbn(10) j[5].books[3].bkname = "isn't it funny" Print j(5).books(3).bkname print j(5).Names 'j(8).nn(99) + j(1).a.isbn(10) 'PRINT LBOUND(j, 1)
TYPE aa 'v AS VARIANT bkname AS STRING * 100 isbn(1000) AS INTEGER END TYPE TYPE book nn(100) AS INTEGER a AS aa END TYPE DIM j(10) AS book DIM m(100) AS INTEGER DIM n AS INTEGER m(11) = 44 'j(3).nn(99) = 123 'j(1).a.isbn(10) = 1000 'j(2).nn(1) = j(3).nn(99) + j(1).a.isbn(10) 'm = m 'm(1) = m 'm = m(1) 'm(1) = m(1) 'm = 111 j(5) = j(5) 'j = j(5) 'j(5) = j 'j = j 'j = 111 j(3).nn(5) = 77 j(3).nn(99) = 5 n = j(3).nn( j(3).nn(99) ) j(6).nn(88) = 10 'j = j(3) 'DIM j(10, 5, 7), m(100, 20) AS book '$END 'DIM n = 4 AS INTEGER n = 4 j(n).a.isbn(6) = 888 j( j(5).a.isbn(66) ).a.isbn(99) = 99 'j(n).a.isbn(99) = 99 'j(n).a.isbn(3) 'PRINT j(n).a.isbn(6) DIM g AS book g.a.bkname = "Bernd Noetscher" g.a.isbn(5) = 12
Type Point3D
Coord(1 To 4) As Single ' Original coordinates.
Trans(1 To 4) As Single ' Translated coordinates.
End Type
Const Xmin = -10
Const Xmax = 15
Const Ymin = -10
Const Ymax = 15
Dim Points(Xmin To Xmax, Ymin To Ymax) As Point3D
For x As Integer = Xmin To Xmax
For y As Integer = Ymin To Ymax
Points(x, y).Coord(1) = y ' X coordinate.
Next
Next
For x = Xmin To Xmax
For y = Ymin To Ymax
print Points(x, y).Coord(1)
Next
Next
$End
Dim k[0 To 2, 0 To 10] As Integer
k[1, 5] = 9
For y As Integer = 0 To 2
For x As Integer = 0 To 5
k[y, x] = x
Next
Next
CLS
For y = 0 To 2
For x = 0 To 5
Print "y" + y + "x" + x + "=" + k[y, x]
Next
Next
'k[15, 51] = 6
'k[15, 52] = 7
CLS
Print k[15, 50] :
Print k[15, 51]
Print k[15, 52]
/*
Dim k[10 To 55, 0 To 88, 10] As Integer
k[15, 50, 5] = 5 : k[15, 50, 6] = 600
k[15, 51, 6] = 6
k[15, 52, 7] = 7
Print k[15, 50, 5] : Print k[15, 50, 6]
Print k[15, 51, 6]
Print k[15, 52, 7]
*/
'Dim k[ - 10 To 100, 0 To 100] As Integer
'
'k[ - 5, 50] = 99
'Points(-5, -5).Coord(1) = 111
For i As Integer = 1 To 1000 Print "hello" + i Next
Option OldBasic a% = CINT(12) b& = CLNG(12) c! = CSNG(12) d# = CDBL(12) 'e@ = CCUR(12) f = CBOOL(12) g = CBYTE(12) 'h = CDATE(12)
Rem ' This is yet another test ' c = 3.14 Rem This is another test ' a = 4 Print "The end!" ' another rem here! 'End Rem definitely the end Dim n As Integer Dim s As String /** this is a documentation comment */ Print "Hi" /* this is mulitlinecomment */ Print "Hi" Print "Hi again" /* s = "to be or not to be" n = 200 */ REM n = 9999 Rem n fkdjfalksjfd 'fdnklfsflsgdngndl dflyjvn REM This is a test of REM ' x = 2 Print "Gloria in exelsis deo."
CLASS rumba
PRIVATE latein AS INTEGER
PUBLIC englisch AS STRING
Dim k
'PRIVATE CONST kbAccess = 0
PUBLIC SUB dance_rumba()
PRINT "rumba!!!"
' RETURN
Print "1!!!"
Print "2!!!"
Print "3!!!"
'print mySalsa.var
END SUB
CONSTRUCTOR rumba()
PRINT "constructor"
END CONSTRUCTOR
DESTRUCTOR rumba()
PRINT "destructor"
END DESTRUCTOR
END CLASS
DIM r AS NEW rumba
r.dance_rumba()
r = NULL
DIM c AS Currency c = 21.56@ PRINT c
Dim b As Boolean = True Dim s As String = "What" Dim n1 As Byte = 88 Dim n2 As Short = 666 Dim n3 As Integer = 777 Dim n4 As Long = 333 Dim si As Single = 67.8 Dim d As Double = 367.8 Dim v As Variant v = d v = 67 v = "Gut" s = s
CLASS rumba
PRIVATE latein AS INTEGER
PUBLIC englisch AS STRING
PUBLIC SUB dance_rumba()
Print "rumba!!!"
END SUB
CONSTRUCTOR rumba()
PRINT "constructor"
END CONSTRUCTOR
DESTRUCTOR rumba()'s AS INTEGER)
PRINT "destructor"
END DESTRUCTOR
END CLASS
DIM r AS NEW rumba
r.dance_rumba()
r = NULL
' without 'As TYPE' means always 'As Variant' Dim A, B As Integer ' --> A As Variant, B As Integer Dim A2 As Integer, B2 As Integer ' --> A2 As Integer, B2 As Integer Dim A3 As Integer, B3 ' --> A3 As Integer, B3 As Variant
' DLL USING (old style)
' Warning! If you use predeclared DECLARE statements of VB6, be aware
' that the size of the datatypes differs between VB6 and KBasic,
' namely Long in VB6 must be Integer in KBasic! You have to change it.
Declare Function GetComputerName Lib "kernel32" Alias _
"GetComputerNameA"(ByVal lpBuffer As String, nSize As Integer) As Integer
Dim Buffer As String
Dim compname As String
Dim Ret As Integer
Buffer = Space(255)
Dim n As Integer = Len(Buffer)
Ret = GetComputerName(Buffer, n)
If Ret > 0 Then compname = Left(Buffer, n)
Print "name of your computer: " + compname + " : " + n
/*
Dim Buffer[50] As String
Dim compname As String
Dim Ret As Long
Buffer[25] = Space(255)
'Buffer = "he"
Dim n As Integer = Len(Buffer[25])
Buffer[24] = "hi"
Ret = GetComputerName(Buffer[25], n)
If Ret > 0 Then compname = Left(Buffer[25], n)
Print "name of your computer: " + compname + " : " + n
Print Buffer[24]
*/
' DLL USING (old style)
' Warning! If you use predeclared DECLARE statements of VB6, be aware
' that the size of the datatypes differs between VB6 and KBasic,
' namely Long in VB6 must be Integer in KBasic! You have to change it.
' WARNING! This program will work as expected, when you compile it to exe and then
' run the exe, because the started program 'edit' here won't appear on screen, if not
'zunächst die benötigten API-Deklarationen
Private Declare Function CloseHandle Lib "kernel32" _
(ByVal hObject As Integer) As Integer
Private Declare Function OpenProcess Lib "kernel32"_
(ByVal dwDesiredAccess As Integer,_
ByVal bInheritHandle As Integer,_
ByVal dwProcessId As Integer) As Integer
Private Declare Function WaitForSingleObject Lib _
"kernel32"(ByVal hHandle As Integer,_
ByVal dwMilliseconds As Integer) As Integer
Private Const INFINITE = &HFFFF
Private Const SYNCHRONIZE = &H100000
'Warten bis Anwendung beendet
Public Sub AppStartAndWait(ByVal sFile As String)
'Parameterbeschreibung
'sFile: Anwendung, die gestartet werden soll
Dim lHandle As Integer
Dim lRet As Integer
Dim lRetVal As Integer
lRetVal = Shell(sFile)
lHandle = OpenProcess(SYNCHRONIZE, 0, lRetVal)
If lHandle <> 0 Then
lRet = WaitForSingleObject(lHandle, INFINITE)
CloseHandle (lHandle)
End If
End Sub
AppStartAndWait("edit")
' DLL USING (old style)
' Warning! If you use predeclared DECLARE statements of VB6, be aware
' that the size of the datatypes differs between VB6 and KBasic,
' namely Long in VB6 must be Integer in KBasic! You have to change it.
Private Declare Function ExitWindowsEx Lib "user32"(ByVal uFlags As Integer,_
dwReserved As Integer) As Integer
Private Const EWX_FORCE = 4
Private Const EWX_LOGOFF = 0
Private Const EWX_REBOOT = 2
Private Const EWX_SHUTDOWN = 1
Private Const EWX_POWEROFF = 8
Dim Retval As Integer, MsgResult As Integer
MsgResult = MsgBox("Would you like to restart your computer now?",_
kbQuestion + kbYesNo, "Restart")
If MsgResult = kbYes Then
Retval = ExitWindowsEx(EWX_LOGOFF, 0)
If Retval = 0 Then MsgBox "Restarting " & _
"failed.", kbInformation
End If
Retval = Retval
' DLL USING (old style)
' Warning! If you use predeclared DECLARE statements of VB6, be aware
' that the size of the datatypes differs between VB6 and KBasic,
' namely Long in VB6 must be Integer in KBasic! You have to change it.
Private Declare Function ChooseColor_Dlg Lib "comdlg32.dll" Alias "ChooseColorA"_
(lpcc As CHOOSECOLOR_TYPE) As Integer
Type CHOOSECOLOR_TYPE
lStructSize As Integer
hwndOwner As Integer
hInstance As Integer
rgbResult As Integer
lpCustColors As Integer
flags As Integer
lCustData As Integer
lpfnHook As Integer
lpTemplateName As String
End Type
' Anwender kann alle Farben wählen
Const CC_ANYCOLOR = &H100
' Nachrichten können "abgefangen" werden
Const CC_ENABLEHOOK = &H10
' Dialogbox Template
Const CC_ENABLETEMPLATE = &H20
' Benutzt Template, ignoriert aber den Template-Namen
Const CC_ENABLETEMPLATEHANDLE = &H40
' Vollauswahl aller Farben anzeigen
Const CC_FULLOPEN = &H2
' Deaktiviert den Button zum Öffnen der Dialogbox-Erweiterung
Const CC_PREVENTFULLOPEN = &H4
' Vorgabe einer Standard-Farbe
Const CC_RGBINIT = &H1
' Hilfe-Button anzeigen
Const CC_SHOWHELP = &H8
' nur Grundfarben auswählbar
Const CC_SOLIDCOLOR = &H80
Dim CC_T As CHOOSECOLOR_TYPE, Retval As Integer
Dim BDF(16) As Integer
'Dim k As String
'CC_T.lpTemplateName = AddressOf(k)
'CC_T.lpTemplateName = "fdgfg"
'Print CC_T.lpTemplateName
'Einige Farben vordefinieren (Benutzerdefinierte Farben)
BDF(0) = RGB(255, 255, 255)
BDF(1) = RGB(125, 125, 125)
BDF(2) = RGB(90, 90, 90)
'Print Len(CC_T) 'Strukturgröße
With CC_T
.lStructSize = Len(CC_T) 'Strukturgröße
.hInstance = 0'App.hInstance 'Anwendungs-Instanz
.hwndOwner = 0 'Me.hWnd 'Fenster-Handle
.flags = CC_RGBINIT Or CC_ANYCOLOR Or CC_FULLOPEN Or _
CC_PREVENTFULLOPEN 'Flags
.rgbResult = RGB(0, 255, 0) 'Farbe voreinstellen
.lpCustColors = AddressOf(BDF(0)) 'Benutzerdefinierte Farben zuweisen
End With
Retval = ChooseColor_Dlg(CC_T) 'Dialog anzeigen
If Retval <> 0 Then
Print Hex$(CC_T.rgbResult) 'gewählte Farbe als Hintergrund setzen
Else
MsgBox "Das Auswählen einer Farbe ist fehlgeschlagen," & _
"oder Sie haben Abbrechen gedrückt", kbCritical, "Fehler"
End If
DOEVENTS
DIM n = 0 AS INTEGER DIM b = FALSE AS BOOLEAN DO n = n + 1 IF n = 4 THEN b = TRUE PRINT n LOOP UNTIL b = TRUE
DIM x = 0 AS DOUBLE, p = 1.9 AS INTEGER DIM n = 0 AS INTEGER, ms = 9.9 AS INTEGER DIM mddd = 8989, fff = 9 AS INTEGER DIM b = TRUE AS BOOLEAN 'b = TRUE DO DIM mmm AS BOOLEAN n = n + 1 IF n = 4 THEN EXIT LOOP ' ITERATE LOOP PRINT n LOOP WHILE b PRINT b END 'b = TRUE DO n = n + 1 IF n = 4 THEN b = FALSE PRINT n LOOP WHILE b PRINT b STOP
DIM n AS INTEGER DIM i AS INTEGER DIM b AS BOOLEAN b = FALSE DO UNTIL b n = n + 1 IF n = 4 THEN b = TRUE PRINT n LOOP STOP
DIM n AS INTEGER DIM b AS BOOLEAN b = TRUE DO WHILE b n = n + 1 IF n = 4 THEN b = FALSE PRINT n LOOP DIM i AS INTEGER
' this kbasic program contains no lines except this comment and many empty lines, to test how the scanner and parser acts on such a situation
' using the error ERROR 4 ' throw an error 'PRINT ERR 'PRINT ERL
CLS
Dim b As Boolean
Dim g As Boolean
Dim n As Integer = 0
Dim k As Integer = 0
b = True
Do While b
g = True
n = n + 1
Print "n = " + n
If n = 3 Then b = False
/*
Do While g
k = k + 1
Print k
If k >= 4 Then Exit Do
' If k >= 3 Then g = False
Loop
*/
/*
Do
k = k + 1
Print k
If k >= 4 Then Exit Do
' If k >= 3 Then g = False
Loop Until g = False
*/
/*
Do
k = k + 1
Print k
If k >= 4 Then Exit Do
' If k >= 3 Then g = False
Loop while g
*/
Do until g = false
k = k + 1
Print k
If k >= 4 Then Exit Do
' If k >= 3 Then g = False
Loop
Loop
Option OldBasic
Option Explicit Off
CLS
Dim e As Integer
e = 59
PRINT 8 + e
'$END
PRINT 0 * (2 ^ 2) + 1 * (2 ^ 1) + 1 * (2 ^ 0)
'$END
PRINT "a" >= "b"
'$END
p = (ii + 6) * 34 + 9
INPUT "say something: ", add$
n% = 99
s$ = "1" + ("" + n% + "2 is shown to me: " + 23.56 ) + add$
PRINT s$
d = 55
b = 66
u = d + b
s$ = "kkkkkk"
' test type check
s = "Hours: "
'n = n + s ' throws an error
'n = s
s = s + n
'$END
'TYPE address
' name AS STRING
'END TYPE
'DIM j AS address
's = s + j.name
IF 12.234 = 12 + 0.234 THEN
'PRINT "it's equal :-)"
ENDIF
DIM y AS DOUBLE
n = 1 + (0 + (2 + 3) * (4 + 5))
n = 1 * (2 + 3)
n = (2 + 3) * 1
n = (2 + 3) * (4 * 5)
n = 1 * (2 + 3) * (4 - 5)
n = 1 - (2 + 3) * 4
n = 1 * (2 + 3) * 4
n = 1 + (3 - 4 + 5 * 6)
n = 1 + 2 - (3 - 4 + 5 * 6)
n = &Hff - &H01 + &H100
n = +(1 + 2 - (3 * (4 + 5) * 6))
n = 1 * 2 + 3 + 4 * 5
n = 1 + 2 + 3 - 4 - 5
n = 1 + 2 * 3 * 4 / 5 * 6
y = 1 = 2 + 4 AND 4 * 5
'y = (12 * ) 2
'y = 12 (*) 2
$END
DIM uu = "Bernd" AS STRING
DIM gg = "Bern" AS STRING
DIM i = &b1111 OR &b10000 AS INTEGER
'PRINT gg + uu
'PRINT gg
' PRINT NOT (12 * 2)
'PRINT NOT 12 * 2
i = NOT NOT NOT NOT NOT (12 * 2)
'uu = (12 * (8))
'uu = NOT y
'uu = y + NOT y
'uu = y + NOT (y)
'uu = y + (NOT y)
'uu = y + NOT (NOT y)
'IF uu = gg + "d" AND NOT (NOT y - i) THEN
' LOCATE 5, 13
' PRINT uu
'ENDIF
$END
FOR y = 1 TO 7
' COLOR y
' PRINT uu
NEXT
'uu = "Input your name: " & uu & " Noetscher"
'string1$ = "Hello world\n" ' Test escape sequence
'string2$ = "He said,""Hello""" ' He said,"Hello" is equivalent using 2 double-quotes
'string3$ = "He said,Hello" ' He said,"Hello" is equivalent using escape sequence
'string4$ = "He said," & chr$(34) & "Hello" & chr$(34) ' He said,"Hello" is equivalent
$END
Dim n As Integer n = 1 + 55 And 55 Print n
Dim i As Integer Dim k As String = "What a nice day!" Print k.Len() i = 100 + .5 If (i > 5) Or (i + 3) Then Print "1" End If
CLS FOR i AS INTEGER = 1 TO 10 PRINT "i = " + i NEXT '$END DIM z# ' test something DIM y# DIM n AS INTEGER FOR z# = 1 TO 2 STEP 1 FOR y# = 1 TO 10 PRINT "y# = " + y# IF y# = 5 THEN EXIT FOR n = 99 PRINT "n = " + n NEXT NEXT n = 100 $END
OPTION VERYOLDBASIC FOR i = 200 TO 100 STEP -2 PRINT "The nifty numeral is now:"; i NEXT i PRINT i
Option OldBasic
CLS
Function nadja(ByRef h As Double) As Integer
'Print "h = " + h
h = h + 99
'Return h + 1000
nadja = h
' insert always automatically a hidden return line
End Function
Dim m = 1 As Integer
m = nadja(25)
nadja(25)
Print "m = " + m
'Option OldBasic CLS Function nadja(ByRef h As Double) As Integer ' h = h + 99 ' ' Print "h = " + h 'Exit Function 'nadja = h + 99 Return h + 99 ' insert always automatically a hidden return line End Function Dim m = 1 As Integer 'm = Print nadja(m) Print "m = " + m
OPTION VERYOLDBASIC
FOR i% = 1 TO 20
GOSUB square
NEXT i%
END
square:
PRINT i% * i%
RETURN
DIM b AS INTEGER DIM n AS INTEGER b = 45 GOTO bernd b = 99999 bernd: n = 0 ok: n = n + 1 PRINT "n = " + n IF n < 5 THEN GOTO ok
Sub t ' ex cannot be used inside the sub, must be at the same level of scope ' jump outside sub not allowed 'GoTo ex ' would case an error End Sub t() End ex: Print "ex reached"
CLS Locate 11, 11 Print "Hallo Berfnd :-)"
' ------------------------------------------------------------------ ' ' ' Dear KBasic user! ' ' ' Thank you for your interest in trying out KBasic. ' This is the free Personal Editon. If you are ' interested in the Professional version without ads and more ' features, just visit www.kbasic.com. ' ' **** ' Enjoy it! * * * ' * **** * ' * *********** * ' Best Regards, * ********* * ' Bernd Noetscher * ******* * ' * * * ** ' * ** ' **** ' ' ' Hit the [run/play button] to start your first kbasic program ' ' ------------------------------------------------------------------ ' program beginning CLS Print "Hello World!" Print Print Print " / `._ . . _.' \" Print " '.@ = `. \ / .' = @.'" Print " \ @`.@ `. \ / .' @.'@ / " Print " \;`@`.@ `. \ / .' @.'@`;/ " Print " \`.@ `.@ `'.(*).'` @.' @.'/ " Print " \ '=._`. @ :=: @ .'_.=' / " Print " \ @ '.'..'='..'.' @ / " Print " \_@_.==.: = :.==._@_/ " Print " / @ @_.: = :._@ @ \ " Print " /@ _.-' : = : '-._ @\ " Print " /`'@ @ .-': = :'-.@ @`'`\ " Print " \.@_.=` .-: = :-. `=._@./ " Print " \._.-' '.' '-._./ " Print Print "... did your first kbasic program!" ' program ending
DIM j AS INTEGER = 6 DIM i = 4 AS INTEGER DIM n AS INTEGER IF i = 5 THEN n = 66: n = 55 IF i = 4 THEN n = 77: n = 99 'IF i = 4 THEN : n = 4: n = 10 '$END IF i <> 1 THEN: n = 11111: ENDIF IF i <> 1 THEN n = 11111 : n = 9 ELSEIF i = 2 * 10 THEN n = 22222 ELSE n = 33333 ENDIF IF i <> 1 THEN n = 11111 END IF PRINT "i = " + i PRINT "n = " + n $END DIM nReturn AS INTEGER nReturn = (-.5) + (-1) + 99 nReturn = (-(+5 - -1) * -2) * 4 / -4 END DIM x,y AS INTEGER ' must be MSC_ID_INTEGER DIM integer__% ' must be MSC_ID_DOUBLE DIM double__# ' must be MSC_ID_SINGLE DIM single__! ' must be MSC_ID_STRING DIM string__$ ' must be MSC_ID_LONG DIM long__& long__& = 12 double__& = 10 / 3 double__& = 10 \ 3 ' integer division! 'single__! = 10.10! double__# = 22.22# string__$ = "kbasic" integer__% = 123434% 'long__& = 2134& END x=1 y=1 y = x AND y END DIM b AS BOOLEAN DIM t AS SINGLE DIM ll AS LONG DIM aa AS LONG DIM b1=1, b2=0 AS BOOLEAN ll = 234 aa = 99 t = 2.8 IF b1 OR b2 AND ll THEN 'IF ll = 234 AND t = 2.8 THEN aa = 123456 ENDIF b = false END DIM n AS INTEGER DIM i AS INTEGER DIM x AS INTEGER i = &O4 IF i <> 1 THEN n = 11111 ELSE n = 33333 print i IF i = 1 THEN n = 11111 ELSEIF i = 2 THEN n = 22222 ELSEIF i = 3 THEN n = 33333 ELSEIF i = 4 THEN n = 44444 ELSE n = 55555 ENDIF END i = 20 i = 20 IF i <> 1 THEN n = 11111 ELSEIF i = 2 * 10 THEN n = 22222 ELSE n = 33333 ENDIF 'FOR i = 1 TO 10 ' n = 123 'NEXT DIM bRet AS BOOLEAN DIM b AS BOOLEAN DIM nReturn AS INTEGER 'GOTO ok bRet = TRUE 'ok: b = 45 'nReturn = 5 - 1 * (2 * 4) * 7 / 8 nReturn = ((+5 - -1) * -2) * 4 / -4 + 9 * 88 - 88 'nReturn = (-.5) + (-1) + 6 'nReturn = 4 + 5 * 6 4000 n = +10 * +8 8000 n = TRUE 9000 nReturn = 4 + 5 MOD 2 ' IF i = 10 THEN ' PRINT i ' ENDIF
DIM s AS STRING DIM i AS INTEGER i = 2 s = IIF(i = 1, "Der Menschen Hörigkeit", "Casanova") PRINT s
Dim a = 1, b, c = 5 Dim d(10), e(55) Dim array1(1 To 5) As Integer, array2, Test1 array2 = Array(1, 2, 3) Test1 = IsArray(array1) ' returns True. Print Test1 Test1 = IsArray(array2) ' returns True. Print Test1
DIM v AS VARIANT PRINT ISEMPTY(v)
Function Benutzerfunktion() Dim v = Error Return v End Function Dim result, Test1 result = Benutzerfunktion() Test1 = IsError(result) ' return true.
Option OldBasic
Dim result
result = doubleit() ' returns 0.
Print result
result = doubleit(2) ' returns 4.
Print result
Function doubleit(Optional ByVal A)
If IsMissing(A) Then
' if no argument, then return 0
doubleit = 0
Else
' if argument, then return double value
doubleit = A * 2
End If
End Function
DIM v AS VARIANT DIM f AS Form v = NULL PRINT "v = " + ISNULL(v) PRINT "f = " + ISNULL(f)
PRINT ISNUMERIC(67)
DIM m AS OBJECT PRINT ISOBJECT(m)
/* TODO2
Sub l_Click(m As Mouse)
Print "hi"
End Sub
*/
Dim f As New Form
'
f.X = 120
f.Y = 120
f.Width = 333
f.Height = 320
f.Caption = "A form generated by a kbasic program at runtime"
Dim l As New Label(f)
l.BackImage = "c:\kbasic\ide\9.jpg"
l.Caption = "Hi"
l.X = 12
l.Y = 33
Dim kk As CheckBox
kk = New CheckBox(f)
kk.Value = True
Dim a As New TextArea(f)
a.Value = "<h1>This is a <u>textarea</u>...</h1>"
a.X = 120
a.Y = 33
a.Width = 333
a.Height = 320
Dim ll As New TextBox(f)
ll.Value = "Hi"
ll.X = 53
Dim k As New ProgressBar(f)
k.Y = 133
f.Open()
a.SetFocus()
Do While True
For i As Integer = 1 To 1000
l.Caption = i
k.Value = i / 10
Next
Loop
DIM b AS INTEGER DIM n AS INTEGER b = 45 GOTO goout b = 999999999 goout: n = 0 ok: n = n + 1 IF n < 5 THEN GOTO ok
'SCREEN 12 'LINE (110, 70)-(190, 120), , B 'LINE (0, 0)-(302, 200), 3, , &HFF00 CLS LINE(0, 0) - (302, 200), 14
CLASS rumba
PRIVATE latein AS INTEGER
PUBLIC englisch AS STRING
DIM k
PRIVATE CONST kbAccess = 0
PRIVATE SUB Class_Initialize()
DIM b = 99
END SUB
PUBLIC SUB dance_rumba()
PRINT "rumba!!!"
PRINT "__LINE__ = " + __LINE__
PRINT "__MODULE__ = " + __MODULE__
PRINT "__SCOPE__ = " + __SCOPE__
PRINT "__CLASS__ = " + __CLASS__
PRINT "__SUB__ = " + __SUB__
END SUB
END CLASS
CLS
DIM m AS NEW rumba
m.dance_rumba()
PRINT
PRINT "Press Esc, to stop ..."
DO
LOOP UNTIL INKEY$ = CHR$(27) '27 is the ASCII-Code for Esc.
MODULE einkauf PUBLIC m AS INTEGER END MODULE MODULE verkauf DIM m2 AS INTEGER PRIVATE m3 AS INTEGER END MODULE 'm3 = 45 m = 77 m2 = 99 Print m Print m2 Print einkauf.m Print verkauf.m2
Option OldBasic Sub OnGosubGotoDemo() Dim dday, Text1 dday = 2 On dday GoSub Sub1, Sub2 On dday GoTo row1, row2 Exit Sub Sub1: Text1 = "In Sub1" : Return Sub2: Text1 = "In Sub2" : Return row1: Text1 = "In row1" row2: Text1 = "In row2" End Sub OnGosubGotoDemo()
OPTION OLDBASIC
FOR i% = 1 TO 2
On i% GoSub Eins, Zwei
NEXT i%
END
Eins: Print "Eins"
RETURN
Zwei: PRINT "Zwei"
RETURN
DIM i%
FOR i% = 1 TO 2
ON i% goto Eins, Zwei
NEXT i%
END
Eins: PRINT "Eins"
end
Zwei: PRINT "Zwei"
end
OPTION VERYOLDBASIC
ON TIMER(1) GOSUB TimeUpdate
TIMER ON
CLS
PRINT "Zeit: "; TIME$
DIM Start = TIMER
DIM Past
WHILE Past < 10
Past = TIMER - Start
WEND
END
TimeUpdate:
LOCATE 1, 8: PRINT TIME$
RETURN
Dim b As Boolean b = TRUE AndAlso FALSE AndAlso FALSE 'b = FALSE OrElse TRUE Print b 'Dim i As Integer 'i = 1 SHL 4 'i = 1 << 4 'i = 1 SHR 4 'i = 1 >> 4 'i++ 'INC(i) 'DEC(i) 'i-- 'i += 5 'i -= 7 'i /= 8 'i *= 7 'i |= 7 'i &= 8 'i = 1 BITAND 5 'i = 1 BITOR 5 'i = 1 BITXOR 5 'i = 1 BITNOT 5 'i = i + 1 'i = i - 1 'i = i * 1 'i = i / 1 'i = i MOD 1 'i = i = 1 'i = i <> 1 'i = i <= 5 'i = i > 5 'i = i < 5 'i = i AND 5 'i = 1 OR 2 'i = NOT TRUE 'i = 2 ^ 8 'PRINT "i: " & i 'i = 1 XOR 4 'i = 9 \ 6 'i = i EQV 2 'i = i IMP 5
' There are several OPTION expressions defined for Basic (option range, option base, option explicit, option compare...) OPTION OLDBASIC OPTION EXPLICIT OFF ' turn off 'OPTION EXPLICIT ON ' turn on i$ = "Heyoi"
Function monique(ByRef i As Integer, ByVal h As Double, ParamArray b() As Variant) As Integer
If LBound(b) < UBound(b) Then
For i = LBound(b) To UBound(b)
Print b(i)
Next i
End If
Return i
End Function
CLS
Dim m = 12 As Integer
'Print monique(h := 12.2, i := m)
'Print monique(m, 12.2)
'monique(m, 12.2, 1, 2, 3, 4, 5, 6)
monique(m, 12.2, 1, 2, 3, 4, 5, 6)
Print "m = " + m
Dim i As Integer For i = 1 To 1000 Print i Next
CLS Locate 3 , 75 Print "123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890"
Class movies
Private sMovieName As String
Private Sub printName
print sMovieName
End Sub
Constructor movies(s As String)
sMovieName = s
End Constructor
End Class
Dim m As New movies("final fantasy")
'm.printName()' would cause an error
Class movies
Private sMovieName As String
Sub printName
print sMovieName
End Sub
Constructor movies(s As String)
sMovieName = s
End Constructor
End Class
Dim m As New movies("final fantasy")
m.printName()
'm.sMovieName = "test"
Class snowBerries
Private MonthNum As Integer ' = 1 ' Internal storage for property value.
Property Month2() As Integer
Get
Return MonthNum
End Get
Set(Value As Integer)
If Value < 1 Or Value > 12 Then
' Error processing for invalid value.
Else
MonthNum = Value
End If
End Set
End Property ' Month
Sub doIt()
'Me.Month2 = 9
'Print Me.Month2
Month2 = 12
Print Month2
End Sub
End Class
Class snowBerries2
Sub doIt()
Dim m As New snowBerries
m.Month2 = 6
m.Month2 = 499
Print m.Month2
End Sub
End Class
'Dim m As New snowBerries
Dim m2 As New snowBerries2
/*
Sub kkk()
m.Month2 = 6
m.Month2 = 499
Print m.Month2
End Sub
*/
'kkk()
'm.Month2 = 8
'm.doIt()
m2.doIt()
Class Salsa
Public Sub test ( )
Print "test!!!"
End Sub
Private pvtFname As String
Public Property Name2 As String
Get
Return pvtFname
End Get
Set (ByVal Value As String)
pvtFname = Value
End Set
End Property
End Class
CLASS rumba
PRIVATE latein AS INTEGER
PUBLIC englisch AS STRING
Dim k
Public mySalsa As Salsa
PUBLIC SUB dance_rumba()
Print "rumba!!!"
mySalsa = New Salsa
mySalsa.Name2 = "rumba!!!999"
print mySalsa.Name2
END SUB
CONSTRUCTOR rumba()
PRINT "constructor"
END CONSTRUCTOR
DESTRUCTOR rumba()
PRINT "destructor"
END DESTRUCTOR
END CLASS
'Dim Emp As rumba = New rumba
DIM m AS NEW rumba
m.dance_rumba()
'Print m.latein
' old syntax of property methods, still supported
Class snowBerries
Private MonthNum As Integer ' = 1 ' Internal storage for property value.
Property Get Month2() As Integer
Return MonthNum
End Property
Property Set Month2(Value As Integer)
If Value < 1 Or Value > 12 Then
' Error processing for invalid value.
Else
MonthNum = Value
End If
End Property ' Month
Sub doIt()
'Me.Month2 = 9
'Print Me.Month2
Month2 = 12
Print Month2
End Sub
End Class
Class snowBerries2
Sub doIt()
Dim m As New snowBerries
m.Month2 = 6
m.Month2 = 499
Print m.Month2
End Sub
End Class
'Dim m As New snowBerries
Dim m2 As New snowBerries2
/*
Sub kkk()
m.Month2 = 6
m.Month2 = 499
Print m.Month2
End Sub
*/
'kkk()
'm.Month2 = 8
'm.doIt()
m2.doIt()
Class movies
Public sMovieName As String
Public Sub printName
print sMovieName
End Sub
Constructor movies(s As String)
sMovieName = s
End Constructor
End Class
Dim m As New movies("final fantasy")
m.printName()
Class movies
Public sMovieName As String
Sub printName
print sMovieName
End Sub
Constructor movies(s As String)
sMovieName = s
End Constructor
End Class
Dim m As New movies("final fantasy")
m.printName()
Print m.sMovieName
m.sMovieName = "test"
Print m.sMovieName
CLS Dim s As String Input "do", s For i As Integer = 1 To 40 Print "1234567890 1234567890 1234567890 1234567890 1234567890 1234567890 1234567890 " + i Next
DIM i AS DOUBLE DIM n AS INTEGER i = 4 + 6 * 5 SELECT CASE i CASE 0 n = 0 CASE 1, 2 n = 1122 CASE 4 TO 10 n = 441000 CASE IS = 9 n = 9999 CASE ELSE n = 88888 END SELECT CLS PRINT "i = " + i PRINT "n = " + n $END i = 9884 SELECT CASE i CASE 0: n = 0: CASE 1, 2: n = 1122 CASE 4 TO 10: n = 441000: CASE IS = 9: n = 9999 CASE ELSE: n = 999999 END SELECT
' make all local vars implicitly static SUB myMsgbox(i AS INTEGER) 'STATIC SUB myMsgbox(i AS INTEGER) 'DIM s AS STRING STATIC s AS STRING PRINT "s??? " + s IF i = 0 THEN s = "Je suis Bernd. Tu't appelles comment?" END SUB CLS myMsgbox (0) myMsgbox (1)
/* */ DIM uu AS STRING uu = """"" """"""""""1Help""you""""" /* CLS PRINT uu uu = "2Help""""you" uu = " ""3Help""you"" " uu = """"" """"""""""4Help""you""""" uu = " """" """"""""""5Help""you"""" " DIM z AS STRING * 80 z = "he" DIM a = "Langsamer" AS STRING DIM b = " Walzer" AS STRING DIM c AS STRING c = "Langsamer" + " Walzer" ' static string + static string c = a + b ' string + string 'uu = "111" uu = uu + "222" DIM n = "hello" AS STRING * 1000 ' max length of 1000 characters, like "char s[1000]" in C++ DIM s AS STRING s = "I really knew it, KBasic will be great!" ' static string PRINT uu 'CLS PRINT s PRINT uu LOCATE 15, 3 PRINT uu STOP */
PRINT STRING$(10, "*") PRINT STRING$(22, 65) PRINT "Welcome to " + STRING$(10, "*")
OPTION OLDBASIC uu$ = "Input your name: " & uu$ & " Noetscher" PRINT uu$ 'string1$ = "Hello world\n" ' Test escape sequence string2$ = "He said,""Hello""" ' He said,"Hello" is equivalent using 2 double-quotes PRINT string2$ string3$ = "He said,Hello" ' He said,"Hello" is equivalent using escape sequence PRINT string3$ string4$ = "He said," & chr$(34) & "Hello" & chr$(34) ' He said,"Hello" is equivalent PRINT string4$
CLS Dim n(8) As Integer ' fixed size array arguement not allowed Sub test(ByRef t() As Integer) Print t(8) t(8) = 88 End Sub Print "--" n(8) = 99 test(n) Print "-- end --" Print n(8)
CLS Dim n(8) As Long Sub test(/*ByVal*/ t() As Long) ' array passing ByVal not allowed Print t(8) End Sub Print "--" n(8) = 99 test(n) Print "-- end --" 'Print n
OPTION OLDBASIC B$ = "12345678" A$ = MID$(B$, 3, 4) PRINT A$
CLASS rumba
SUB dance
PRINT "dance"
END SUB
END CLASS
PUBLIC SUB test() THROWS rumba
'EXIT SUB
THROW NEW rumba ' return rumba = new rumba
' return rumba = 0
END SUB
PUBLIC SUB tt
test()
' 1. if rumba gesetzt, goto catch rumba
' goto finally
' 2. if throws and if rumba gesetzt, goto parent, throw rumba
CATCH (b AS rumba)
' dim b as rumba = rumba
PRINT "got you!"
b.dance()
' goto finally
FINALLY
PRINT "will be always executed, whatever happend"
END SUB
tt()
CLASS rumba
SUB dance
PRINT "rumba.dance"
END SUB
END CLASS
CLASS samba
SUB dance
PRINT "samba.dance"
END SUB
END CLASS
PUBLIC SUB test2() THROWS rumba, samba
'EXIT SUB
THROW NEW rumba ' return rumba = new rumba
'THROW NEW samba
' return rumba = 0
END SUB
PUBLIC SUB tt2() THROWS samba
TRY
test2()
CATCH (b AS rumba)
PRINT "tt2: got you!"
b.dance()
' CATCH (c AS samba)
' ' dim b as samba = samba
' PRINT "got you!"
' c.dance()
FINALLY
PRINT "tt2: will be always executed, whatever happend"
END CATCH
END SUB
PUBLIC SUB tt()
tt2()
CATCH (c AS samba)
PRINT "tt: got you!"
c.dance()
FINALLY
PRINT "tt: will be always executed, whatever happend"
END SUB
tt()
Dim b = 6 'Const b = 99 b = 7
/*
test it
p+ op
*/
/*
Module module1
' class scope
Function ttt() As CommandButton
End Function
Dim c As CommandButton
c = FormControl("Button1") ' Button1 is declared as CommandButton in this form
c.SetFocus()
c.Icon
Class Walzer
Public var As integer
End Class
walzer.var.var..
r..
Salsa..meExplicit....classSubWithArgument.publicClassVar = 111
*/
Class Walzer
Public var As integer
End Class
Const globalConst = 1
Const globalConst2 As Integer = 2
Dim globalVar As Integer = 4
Dim globalVar2 As test
globalVar2 = test.Entry
' global scope
Enum test
Entry = 666
Entry2
Security = Entry
securus
secura
securum
End Enum
Type book
bkname As String * 100
isbn(1000) As Integer
End Type
Type address
books(50) As book
age As book
Name[9] As Integer
End Type
Sub globalSub()
Dim localVar = 99
End Sub
' module scope
Module module1
Public Type address2
age As Integer
End Type
Public Type module_type
element AS integer
End Type
Public Enum module_enum
Entry
Entry2
Security = Entry
End Enum
Const moduleConst = 7
Public publicModuleVar As Integer
Private privateModuleVar As Integer
Sub moduleExplicit()
Dim localVar = module1.publicModuleVar
Dim localVar2 = module1.moduleConst
' Dim localVar3 As module1.module_enum ' full type name not allowed after AS
Dim localVar3 As module_enum
localVar3 = module1.module_enum.Entry
'Dim localVar4 As module1.module_type ' full type name not allowed after AS
Dim localVar5 As module_type ' full type name not allowed after AS
End Sub
Sub moduleImplicit()
dim localVar = publicModuleVar
dim localVar2 = moduleConst
dim localVar3 as module_enum
localVar3 = module_enum.Entry
Dim localVar4 As module_type
Dim localVar5 As module_type
Dim localVar6 = module1.publicModuleVar
End Sub
Sub moduleSubWithDefaultArgument(ko as integer = 6)
Dim localVar = ko
End Sub
Sub moduleSubWithOptionalArgument(Optional ko As Integer)
If Not IsMissing(ko) Then
dim localVar = ko
End If
End Sub
Sub moduleSub()
Const localConst = 6
dim n = localConst
End Sub
Sub moduleSubWithArgument(i as integer)
dim localVar = i
End Sub
Sub moduleSubWithArgumentShadowing(i2 as integer)
Dim localVar = i2
Dim i2 = localVar + 99
dim i3 = i2
End Sub
Sub subOverloading ( )
print "sub1"
End Sub
Sub subOverloading ( i as integer = 1)
print "sub2"
End Sub
Function moduleFunction() As String
subOverloading()
subOverloading(88)
return "hello"
End function
function moduleFunctionRecursive(byref i as integer) as integer
if i > 6 then return 1''i
''i = i + 1
return moduleFunctionRecursive(1)''i)
End function
End Module
Class Salsa inherits Walzer
public Enum class_enum
Entry
Entry2
Security = Entry
End Enum
public type class_type
element AS integer
End Type
const classConst = 4
public publicInstanceVar as integer
Private privateInstanceVar As Integer
'Protected protectedInstanceVar As Integer
Static Public publicClassVar As Integer' = 8
'dim publicModuleType as module1.module_type
dim publicModuleType2 as module_type
' parent constructor call inside constructor
Sub meExplicit()
dim localVar = Me.publicInstanceVar ' it is the same with Parent
dim localVar2 = Me.publicClassVar
dim localVar3 = Salsa.publicClassVar
dim localVar4 = Salsa.classConst
Dim localVar5 = classConst
'Dim localVar5b = Me.classConst
' left
Dim localVar6 As class_enum
localVar6 = Salsa.class_enum.Entry
' Dim localVar7 As Me.class_enum ' full type name not allowed after AS
dim localVar8 as class_type
End Sub
Sub meImplicit()
dim localVar = publicInstanceVar
dim localVar2 = publicClassVar
dim localVar3 = classConst
Dim localVar4 As class_enum
dim localVar5 as class_type
End Sub
Sub classSub()
const localConst = 6
dim n = localConst
End Sub
Sub classSubWithArgument(i as integer)
dim localVar = i
End Sub
Function classFunction() As String
return "hello"
End Function
' Static Public Sub test() Throws Walzer
' Throw New Walzer
' End Sub
' Private pvtFname As String
'
' Public Property Nickname As String
'
' Get
' print "Hi"
' End Get
'
' Set ( ByVal Value As String )
' print "Hi"
' End Set
'
' End Property
End Class
CLASS rumba
Public latein AS INTEGER
'Public mySalsa As New Salsa
'Public mySalsa2[10] As Salsa
' Public mySalsa3[] As Salsa
PUBLIC SUB dance_rumba()
Print "rumba!!!"
'print mySalsa.var
End Sub
' default constructor
Constructor rumba ()
print "constructor"
End Constructor
Constructor rumba ( _latein as integer)
Print "constructor2"
latein = _latein
End Constructor
Destructor rumba ( )
print "destructor"
End Destructor
Static Sub myMsgBox(ByRef m As Double)
'' m = m + 1
End Sub
Static Sub myMsgbox2(Optional m As Integer)
If IsMissing(m) Then
'' m = m + 1
Else
Print "do nothing"
End If
End Sub
Static Function monique(ByRef i As Integer, ByVal h As Double, ParamArray b() As Variant) As Integer
For i = LBound(b) To UBound(b)
Print b(i)
Next i
Return i
End Function
static SUB structByReference(byref m AS address)
''m.name[2] = 71
End Sub
' static SUB structByValue(byval m AS address) ' struct passed byval not allowed
' m.name[2] = 71
' End Sub
' Static Function returnStructByVal() as address ' struct returned not allowed
' dim m AS address
' ''m.Name[2] = 71
' return m
' End Sub
' static SUB arrayByRef(byref m[] AS address) ' array arguement not allowed
' m[8].name[2] = 71
' End Sub
' Sub test(ByRef t(8) As Long) ' fixed size array arguement not allowed
' End Sub
' Sub test2(ByVal t(8) As Long) ' fixed size array arguement not allowed
' End Sub
' Static Function returnArrayByRef() as adress[] ' open array returned not allowed
' dim m[8] AS address
' m[1].Name[2] = 71
' return m
' End Sub
' static SUB arrayByRef(byref m[][] AS address)
' m[8][9].name[2] = 71
' End Sub
'
' Static Function returnArrayByRef() as adress[][] ' open array returned not allowed
' dim m[8][6] AS address
' m[1][4].Name[2] = 71
' return m
' End Sub
END CLASS
DIM j(5 TO 10) AS address
''j(3).namer(6) = 123
''j(1).age.isbn(10) = 1000
''j[2].namer[1] = j(3).namer(6) + j(1).age.isbn(10)
'Dim Emp As rumba = New rumba
DIM r AS NEW rumba
r.dance_rumba()
'With r
' .dance_rumba()
'End With
'Print r.latein
'Print r.mySalsa.var
Print globalVar ' accessable from everywhere
Print globalVar2 ' accessable from everywhere
Print globalConst ' accessable from everywhere
publicModuleVar = 99
module1.publicModuleVar = 99
'moduleFunctionRecursive(1)
' module1.moduleFunctionRecursive(1)
Print publicModuleVar
Salsa.publicClassVar = 111
Print Salsa.publicClassVar
print moduleConst
DIM m = 1 AS INTEGER
'PRINT rumba.monique( h:=12.2, i:=m )
''Print rumba.monique(m, 12.2, 5, 8, 7)
' TRY
' Salsa.test()
' CATCH (b AS Walzer)
' PRINT "got you!"
' End Catch
'
DIM n AS INTEGER DIM i AS INTEGER DIM b AS BOOLEAN b = TRUE WHILE b n = n + 1 IF n = 4 THEN b = FALSE PRINT n END WHILE STOP
CLASS rumba
PUBLIC SUB dance_rumba()
PRINT "rumba!!!"
WITH ME
.test()
END WITH
END SUB
PRIVATE SUB test()
PRINT "test"
END SUB
END CLASS
DIM m AS NEW rumba
WITH m
.dance_rumba()
/*jjj*/ ' .dance_rumba()
' .dance_rumba() :.dance_rumba()
END WITH
Type Point3D
Coord(1 To 4) As Single ' Original coordinates.
Trans(1 To 4) As Single ' Translated coordinates.
End Type
Const Xmin = 0
Const Xmax = 1
Const Ymin = 0
Const Ymax = 3
Dim Points(Xmin To Xmax, Ymin To Ymax) As Point3D
Dim T(1 To 4, 1 To 4) As Single
Dim T1(1 To 4, 1 To 4) As Single
Dim T2(1 To 4, 1 To 4) As Single
Dim EyeX As Single
Dim EyeY As Single
Dim EyeZ As Single
Dim Axes(1 To 3) As Point3D
' ********************************************************
' Perform vector-matrix multiplication. Set Rpt = Ppt * A.
' ********************************************************
Sub VectorMatrixMult1(x As Integer, y As Integer)
Dim i As Integer
Dim j As Integer
Dim value As Single
For i = 1 To 4
value = 0
For j = 1 To 4
value = value + Points(x, y).Coord(j) * T(j, i)
Next j
Points(x, y).Trans(i) = value
Next i
' Renormalize the point.
' Note that value still holds Rpt(4).
Points(x, y).Trans(1) = Points(x, y).Trans(1) / value
Points(x, y).Trans(2) = Points(x, y).Trans(2) / value
Points(x, y).Trans(3) = Points(x, y).Trans(3) / value
Points(x, y).Trans(4) = 1
End Sub
' ********************************************************
' Return the angle with tangent y / x.
' ********************************************************
Function Atan(x As Single, y As Single)
Const PI = 3.14159
Dim angle As Single
If x = 0 Then
angle = 0
Else
angle = Atn(y / x)
If x < 0 Then angle = PI + angle
End If
Return angle
End Function
' ********************************************************
' Make M an identity matrix.
' ********************************************************
Sub MakeIdentity1()
Dim i As Integer
Dim j As Integer
For i = 1 To 4
For j = 1 To 4
If i = j Then
T1(i, j) = 1
Else
T1(i, j) = 0
End If
Next j
Next i
End Sub
Sub MakeIdentity2()
Dim i As Integer
Dim j As Integer
For i = 1 To 4
For j = 1 To 4
If i = j Then
T2(i, j) = 1
Else
T2(i, j) = 0
End If
Next j
Next i
End Sub
' ********************************************************
' Perform matrix-matrix multiplication. Set R = A * B.
' ********************************************************
Sub MatrixMatrixMult()
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim value As Single
For i = 1 To 4
For j = 1 To 4
value = 0
For k = 1 To 4
value = value + T1(i, k) * T2(k, j)
Next k
T(i, j) = value
Next j
Next i
End Sub
' ********************************************************
' Calculate the transformation matrix.
' ********************************************************
Private Sub CalculateTransformation()
Dim r1 As Single
Dim r2 As Single
Dim ctheta As Single
Dim stheta As Single
Dim cphi As Single
Dim sphi As Single
' Rotate around the Z axis so the
' eye lies in the Y-Z plane.
r1 = Sqr(EyeX * EyeX + EyeY * EyeY)
stheta = EyeX / r1
ctheta = EyeY / r1
MakeIdentity1
T1(1, 1) = ctheta
T1(1, 2) = stheta
T1(2, 1) = -stheta
T1(2, 2) = ctheta
' Rotate around the X axis so the
' eye lies in the Z axis.
r2 = Sqr(EyeX * EyeX + EyeY * EyeY + EyeZ * EyeZ)
sphi = -r1 / r2
cphi = -EyeZ / r2
MakeIdentity2
T2(2, 2) = cphi
T2(2, 3) = sphi
T2(3, 2) = -sphi
T2(3, 3) = cphi
' Project along the Z axis. (Actually we do nothing
' here. We just ignore the Z coordinate when drawing.)
' Combine the transformations.
MatrixMatrixMult
End Sub
' ********************************************************
' Draw the surface.
' ********************************************************
Private Sub DrawSurface()
Dim x As Integer
Dim y As Integer
' Calculate the transformation matrix.
CalculateTransformation
' Transform the axes.
For x = 1 To 3
VectorMatrixMult2 x
Next x
' Apply the transformation matrix to the points.
For x = Xmin To Xmax
For y = Ymin To Ymax
VectorMatrixMult1 x, y
Next y
Next x
Dim CurrentX As Integer, CurrentY As Integer
CLS
Print "Rotate with a, d, w or x ESC = exit"
' draw the axes.
For x = 1 To 3
Line(512, 384) - (512 + Axes(x).Trans(1) * 30, 384 + Axes(x).Trans(2) * 30), 4
Next x
Line(512 + Points(0, 0).Trans(1) * 20, 384 + Points(0, 0).Trans(2) * 20) - (512 + Points(0, 1).Trans(1) * 20, 384 + Points(0, 1).Trans(2) * 20), 15
Line(512 + Points(0, 1).Trans(1) * 20, 384 + Points(0, 1).Trans(2) * 20) - (512 + Points(0, 2).Trans(1) * 20, 384 + Points(0, 2).Trans(2) * 20), 15
Line(512 + Points(0, 2).Trans(1) * 20, 384 + Points(0, 2).Trans(2) * 20) - (512 + Points(0, 3).Trans(1) * 20, 384 + Points(0, 3).Trans(2) * 20), 15
Line(512 + Points(0, 3).Trans(1) * 20, 384 + Points(0, 3).Trans(2) * 20) - (512 + Points(0, 0).Trans(1) * 20, 384 + Points(0, 0).Trans(2) * 20), 15
Line(512 + Points(1, 0).Trans(1) * 20, 384 + Points(1, 0).Trans(2) * 20) - (512 + Points(1, 1).Trans(1) * 20, 384 + Points(1, 1).Trans(2) * 20), 10
Line(512 + Points(1, 1).Trans(1) * 20, 384 + Points(1, 1).Trans(2) * 20) - (512 + Points(1, 2).Trans(1) * 20, 384 + Points(1, 2).Trans(2) * 20), 10
Line(512 + Points(1, 2).Trans(1) * 20, 384 + Points(1, 2).Trans(2) * 20) - (512 + Points(1, 3).Trans(1) * 20, 384 + Points(1, 3).Trans(2) * 20), 10
Line(512 + Points(1, 3).Trans(1) * 20, 384 + Points(1, 3).Trans(2) * 20) - (512 + Points(1, 0).Trans(1) * 20, 384 + Points(1, 0).Trans(2) * 20), 10
Line(512 + Points(0, 0).Trans(1) * 20, 384 + Points(0, 0).Trans(2) * 20) - (512 + Points(1, 0).Trans(1) * 20, 384 + Points(1, 0).Trans(2) * 20), 15
Line(512 + Points(0, 1).Trans(1) * 20, 384 + Points(0, 1).Trans(2) * 20) - (512 + Points(1, 1).Trans(1) * 20, 384 + Points(1, 1).Trans(2) * 20), 15
Line(512 + Points(0, 3).Trans(1) * 20, 384 + Points(0, 3).Trans(2) * 20) - (512 + Points(1, 3).Trans(1) * 20, 384 + Points(1, 3).Trans(2) * 20), 15
Line(512 + Points(0, 2).Trans(1) * 20, 384 + Points(0, 2).Trans(2) * 20) - (512 + Points(1, 2).Trans(1) * 20, 384 + Points(1, 2).Trans(2) * 20), 15
/*
' Draw lines parallel to the X axis.
'ForeColor = RGB(0, 0, 0)
For x = Xmin To Xmax
CurrentX = Points(x, Ymin).Trans(1)
CurrentY = Points(x, Ymin).Trans(2)
For y = Ymin + 1 To Ymax
Line(512 + CurrentX * 20, 384 + CurrentY * 20) - (512 + Points(x, y).Trans(1) * 20, 384 + Points(x, y).Trans(2) * 20), 7
Next y
Next x
' Draw lines parallel to the Y axis.
For y = Ymin To Ymax
CurrentX = Points(Xmin, y).Trans(1)
CurrentY = Points(Xmin, y).Trans(2)
For x = Xmin + 1 To Xmax
Line(512 + CurrentX * 20, 384 + CurrentY * 20) - (512 + Points(x, y).Trans(1) * 20, 384 + Points(x, y).Trans(2) * 20), 15
Next x
Next y
*/
End Sub
Private Sub getkey()
Const PI = 3.14159
Const PI2 = -3.14159
Const Dtheta = PI / 16
Const Dphi = PI / 8
Dim theta As Single
Dim phi As Single
Dim r1 As Single
Dim r2 As Single
Dim i$
re:
Do
i$ = inkey
Loop While i$ = ""
theta = Atan(EyeX, EyeY)
r1 = Sqr(EyeX * EyeX + EyeY * EyeY)
r2 = Sqr(EyeX * EyeX + EyeY * EyeY + EyeZ * EyeZ)
phi = Atan(r1, EyeZ)
Select Case i$
Case "a"
theta = theta - Dtheta
Case "w"
phi = phi + Dphi
If phi > PI / 2 Then phi = PI / 2
Case "d"
theta = theta + Dtheta
Case "x"
phi = phi - Dphi
If phi < PI2 / 2 Then phi = PI2 / 2
Case Else
End
End Select
EyeX = r1 * Cos(theta)
EyeY = r1 * Sin(theta)
EyeZ = r2 * Sin(phi)
DrawSurface
goto re
End Sub
Sub VectorMatrixMult2(x As Integer)
Dim i As Integer
Dim j As Integer
Dim value As Single
For i = 1 To 4
value = 0
For j = 1 To 4
value = value + Axes(x).Coord(j) * T(j, i)
Next j
Axes(x).Trans(i) = value
Next i
' Renormalize the point.
' Note that value still holds Rpt(4).
Axes(x).Trans(1) = Axes(x).Trans(1) / value
Axes(x).Trans(2) = Axes(x).Trans(2) / value
Axes(x).Trans(3) = Axes(x).Trans(3) / value
Axes(x).Trans(4) = 1
End Sub
Private Sub Main()
Dim x As Integer
Dim y As Integer
Dim R As Single
' Initialize the viewing location.
EyeX = 40
EyeY = 20
EyeZ = 20
Points(0, 0).Coord(1) = 0 ' X coordinate.
Points(0, 0).Coord(2) = 0 ' Y coordinate.
Points(0, 0).Coord(3) = 1 ' Z
Points(0, 0).Coord(4) = 1 ' Scale factor.
Points(0, 1).Coord(1) = 10 ' X coordinate.
Points(0, 1).Coord(2) = 0 ' Y coordinate.
Points(0, 1).Coord(3) = 1 ' Z
Points(0, 1).Coord(4) = 1 ' Scale factor.
Points(0, 2).Coord(1) = 10 ' X coordinate.
Points(0, 2).Coord(2) = 10 ' Y coordinate.
Points(0, 2).Coord(3) = 1 ' Z
Points(0, 2).Coord(4) = 1 ' Scale factor.
Points(0, 3).Coord(1) = 0 ' X coordinate.
Points(0, 3).Coord(2) = 10 ' Y coordinate.
Points(0, 3).Coord(3) = 1 ' Z
Points(0, 3).Coord(4) = 1 ' Scale factor.
Points(1, 0).Coord(1) = 0 ' X coordinate.
Points(1, 0).Coord(2) = 0 ' Y coordinate.
Points(1, 0).Coord(3) = 10 ' Z
Points(1, 0).Coord(4) = 1 ' Scale factor.
Points(1, 1).Coord(1) = 10 ' X coordinate.
Points(1, 1).Coord(2) = 0 ' Y coordinate.
Points(1, 1).Coord(3) = 10 ' Z
Points(1, 1).Coord(4) = 1 ' Scale factor.
Points(1, 2).Coord(1) = 10 ' X coordinate.
Points(1, 2).Coord(2) = 10 ' Y coordinate.
Points(1, 2).Coord(3) = 10 ' Z
Points(1, 2).Coord(4) = 1 ' Scale factor.
Points(1, 3).Coord(1) = 0 ' X coordinate.
Points(1, 3).Coord(2) = 10 ' Y coordinate.
Points(1, 3).Coord(3) = 10 ' Z
Points(1, 3).Coord(4) = 1 ' Scale factor.
/*
' Initialize the data points.
For x = Xmin To Xmax
For y = Ymin To Ymax
Points(x, y).Coord(1) = x ' X coordinate.
Points(x, y).Coord(2) = y ' Y coordinate.
Points(x, y).Coord(4) = 1 ' Scale factor.
' Z coordinate.
R = Sqr(x * x + y * y)
Points(x, y).Coord(3) = Cos(R)
Next y
Next x
*/
' Initialize the axes.
Axes(1).Coord(1) = 10 ' X axis.
Axes(1).Coord(4) = 1
Axes(2).Coord(2) = 10 ' Y axis.
Axes(2).Coord(4) = 1
Axes(3).Coord(3) = 10 ' Z axis.
Axes(3).Coord(4) = 1
DrawSurface
getkey()
End Sub
Main()
Dim value1 As Integer Dim value2 As Integer 'Print Abs ( 35.5 - 100 ) 'use ABS to find the difference 'between 2 values value1 = 112 value2 = 108 Print "The difference is " ; Abs ( value1 - value2 )
CLASS ABSTRACT rumba
PUBLIC ABSTRACT SUB dance_rumba()
PRIVATE latein AS INTEGER
PUBLIC englisch AS STRING
PRIVATE CONST kbAccess = 0
CONSTRUCTOR rumba()
DIM p = 77777777
END CONSTRUCTOR
DESTRUCTOR rumba()
DIM a = 3333
END DESTRUCTOR
END CLASS
CLASS jive INHERITS rumba
CONSTRUCTOR jive()
DIM b = 99
END CONSTRUCTOR
DESTRUCTOR jive()
DIM a = 888
END DESTRUCTOR
PUBLIC SUB dance_rumba()
PRINT "rumba!!!"
END SUB
END CLASS
'DIM k AS NEW rumba
DIM m AS NEW jive
m.dance_rumba()
Dim A, B As Variant A = Array(10, 20, 30) A(2) = 999 B = A(2) Print B
'ASCII tester
' This pogram waits for you to press a key and then displays the ASCII code
' of the key you pressed, along with any leading zero's and the character
' generated by the key you pressed.
'
' Suggested use: find out ASCII codes that belong to certain key you want to
' use in your programs.
'
DIM i$
CLS
DO
i$ = ""
WHILE i$ = ""
i$ = INKEY$
WEND
LOCATE 1, 1
IF LEN(i$) = 1 THEN PRINT "ASCII="+ASC(i$);
IF LEN(i$) = 2 THEN PRINT "0 +" + STR$(ASC(RIGHT$(i$, 1)));
PRINT "....you pressed: " + i$ + SPACE$(10)
LOOP UNTIL i$ = CHR$(27)
'****************************************************************************
'**
'** Copyright ( C ) 1992-2000 Trolltech AS. All rights reserved.
'**
'** This file is part of an example program for Qt. This example
'** program may be used, distributed and modified without limitation.
'**
'*****************************************************************************/
'$END
' Analog Clock
' This example displays an analog clock widget.
Class AnalogClock Inherits QWidget
Private clickPos As QPoint
Private time2 As QTime
Private internalTimer As QTimer
Constructor AnalogClock()
time2 = QTime.currentTime() ' get current time
internalTimer = New QTimer(Me) ' create internal timer
connect(internalTimer, Signal(timeout()), Me, Slot(timeout()))
internalTimer.start(5000, False) ' emit signal every 5 seconds
End Constructor
Sub mousePressEvent(e As QMouseEvent)
If isTopLevel() Then
Dim x1 As Integer = e.pos().x()
Dim y1 = e.pos().y()
Dim x2 = geometry().topLeft().x() - frameGeometry().topLeft().x()
Dim y2 = geometry().topLeft().y() - frameGeometry().topLeft().y()
clickPos = New QPoint(x1 + x2, y1 + y2)
End If
End Sub
Sub mouseMoveEvent(e As QMouseEvent)
If isTopLevel() Then
Dim x = e.globalPos().x() - clickPos.x()
Dim y = e.globalPos().y() - clickPos.y()
move(x, y)
End If
End Sub
'
' When we set an explicit time we don't want the timeout() slot to be
' called anymore as this relies on currentTime()
'
Public Slot setTime(t As QTime)
time2 = t
' TODO2 disconnect( internalTimer, SIGNAL(timeout()), me, SLOT(timeout()) )
If autoMask() Then
updateMask()
Else
update ( )
End If
End Slot
'
' The QTimer.timeout() signal is received by this slot.
'
Private Slot timeout()
Dim old_time As QTime = time2
time2 = QTime.currentTime()
If old_time.minute() <> time2.minute()_
OrElse old_time.hour() <> time2.hour() Then ' minute or hour has changed
If autoMask() Then
updateMask()
Else
update()
End If
End If
End Slot
Sub paintEvent(e As QPaintEvent)
If autoMask() Then End
Dim p As New QPainter(Me)
drawClock( p )
End Sub
' The clock is painted using a 1000x1000 square coordinate system, in
' the a centered square, as big as possible. The painter's pen and
' brush colors are used.
Sub drawClock(p As QPainter)
p.save()
p.setWindow( -500,-500, 1000,1000 )
Dim v As QRect = p.viewport()
Dim d As Integer = 0
If v.width() > v.height() Then
d = v.height()
Else
d = v.width()
End If
p.setViewport(v.left() + (v.width() - d) / 2, v.top() + (v.height() - d) / 2, d, d)
p.save()
p.rotate(30 * (time2.hour() Mod 12 - 3) + time2.minute() / 2)
p.setPen(new QPen(new QColor(0, 0, 0), 4, Qt.DashLine))
p.drawLine(0, 0, 300, 0)
p.restore()
p.save()
p.rotate((time2.minute() - 15) * 6)
p.setPen(new QPen(new QColor(0, 0, 0), 4, Qt.DashLine))
p.drawLine(0, 0, 400, 0)
p.restore()
For i As Integer = 0 To 11
p.drawLine(440, 0, 460, 0)
p.rotate(30)
Next
p.restore()
End Sub
' If the clock is transparent, we use updateMask()
' instead of paintEvent()
Sub updateMask() ' paint clock mask
Dim bm As New QBitmap(size())
Dim color0 As QColor = New QColor(255, 255, 255)
bm.fill(color0) 'transparent
Dim p As New QPainter
p.begin(bm, Me)
drawClock(p)
p.end()
setMask( bm )
End Sub
Sub setAutoMask(b As Boolean)
If b Then
setBackgroundMode( Qt.PaletteForeground )
Else
setBackgroundMode( Qt.PaletteBackground )
End If
Parent.setAutoMask(b)
End Sub
End Class
Dim clock As New AnalogClock()
'clock.setAutoMask(true)
clock.resize(650, 400)
clock.setCaption("Qt Example - Analog Clock")
'clock.setPaletteBackgroundPixmap(new QPixmap(new QImage("c:\kbasic\ide\9.jpg")))
clock.show()
'clock.setTime(new QTime(6, 44))
'****************************************************************************
'**
'** Copyright ( C ) 1992-2000 Trolltech AS. All rights reserved.
'**
'** This file is part of an example program for Qt. This example
'** program may be used, distributed and modified without limitation.
'**
'*****************************************************************************/
' Analog Clock
' This example displays an analog clock widget.
Class AnalogClock2 Inherits QWidget
Private clickPos As QPoint
Private time2 As QTime
Private internalTimer As QTimer
Constructor AnalogClock2()
time2 = QTime.currentTime() ' get current time
internalTimer = New QTimer(Me) ' create internal timer
connect(internalTimer, Signal(timeout()), Me, Slot(timeout()))
internalTimer.start(5000, False) ' emit signal every 5 seconds
End Constructor
Sub mousePressEvent(e As QMouseEvent)
If isTopLevel() Then
Dim x1 As Integer = e.pos().x()
Dim y1 = e.pos().y()
Dim x2 = geometry().topLeft().x() - frameGeometry().topLeft().x()
Dim y2 = geometry().topLeft().y() - frameGeometry().topLeft().y()
clickPos = New QPoint(x1 + x2, y1 + y2)
End If
End Sub
Sub mouseMoveEvent(e As QMouseEvent)
If isTopLevel() Then
Dim x = e.globalPos().x() - clickPos.x()
Dim y = e.globalPos().y() - clickPos.y()
move(x, y)
End If
End Sub
'
' When we set an explicit time we don't want the timeout() slot to be
' called anymore as this relies on currentTime()
'
Public Slot setTime(t As QTime)
time2 = t
' TODO2 disconnect( internalTimer, SIGNAL(timeout()), me, SLOT(timeout()) )
If autoMask() Then
updateMask()
Else
update ( )
End If
End Slot
'
' The QTimer.timeout() signal is received by this slot.
'
Private Slot timeout()
Dim old_time As QTime = time2
time2 = QTime.currentTime()
If old_time.minute() <> time2.minute()_
OrElse old_time.hour() <> time2.hour() Then ' minute or hour has changed
If autoMask() Then
updateMask()
Else
update()
End If
End If
End Slot
Sub paintEvent(e As QPaintEvent)
If autoMask() Then End
Dim p As New QPainter(Me)
drawClock( p )
End Sub
' The clock is painted using a 1000x1000 square coordinate system, in
' the a centered square, as big as possible. The painter's pen and
' brush colors are used.
Sub drawClock(p As QPainter)
p.save()
p.setWindow( -500,-500, 1000,1000 )
Dim v As QRect = p.viewport()
Dim d As Integer = 0
If v.width() > v.height() Then
d = v.height()
Else
d = v.width()
End If
p.setViewport(v.left() + (v.width() - d) / 2, v.top() + (v.height() - d) / 2, d, d)
p.save()
p.rotate(30 * (time2.hour() Mod 12 - 3) + time2.minute() / 2)
p.setPen(new QPen(new QColor(0, 0, 0), 4, Qt.DashLine))
p.drawLine(0, 0, 300, 0)
p.restore()
p.save()
p.rotate((time2.minute() - 15) * 6)
p.setPen(new QPen(new QColor(0, 0, 0), 4, Qt.DashLine))
p.drawLine(0, 0, 400, 0)
p.restore()
For i As Integer = 0 To 11
p.drawLine(440, 0, 460, 0)
p.rotate(30)
Next
p.restore()
End Sub
' If the clock is transparent, we use updateMask()
' instead of paintEvent()
Sub updateMask() ' paint clock mask
Dim bm As New QBitmap(size())
Dim color0 As QColor = New QColor(255, 255, 255)
bm.fill(color0) 'transparent
Dim p As New QPainter
p.begin(bm, Me)
drawClock(p)
p.end()
setMask( bm )
End Sub
Sub setAutoMask(b As Boolean)
If b Then
setBackgroundMode( Qt.PaletteForeground )
Else
setBackgroundMode( Qt.PaletteBackground )
End If
Parent.setAutoMask(b)
End Sub
End Class
Dim clock As New AnalogClock()
'clock.setAutoMask(true)
clock.resize(650, 400)
clock.setCaption("Qt Example - Analog Clock")
'clock.setPaletteBackgroundPixmap(new QPixmap(new QImage("c:\kbasic\ide\9.jpg")))
clock.show()
'clock.setTime(new QTime(6, 44))
Do While true
Loop
Do While true
Loop
'****************************************************************************
'**
'** Copyright ( C ) 1992-2000 Trolltech AS. All rights reserved.
'**
'** This file is part of an example program for Qt. This example
'** program may be used, distributed and modified without limitation.
'**
'*****************************************************************************/
' Analog Clock
' This example displays an analog clock widget.
Class AnalogClock3 Inherits QWidget
Private clickPos As QPoint
Private time2 As QTime
Private internalTimer As QTimer
Constructor AnalogClock3()
time2 = QTime.currentTime() ' get current time
internalTimer = New QTimer(Me) ' create internal timer
connect(internalTimer, Signal(timeout()), Me, Slot(timeout()))
internalTimer.start(5000, False) ' emit signal every 5 seconds
End Constructor
Sub mousePressEvent(e As QMouseEvent)
If isTopLevel() Then
Dim x1 As Integer = e.pos().x()
Dim y1 = e.pos().y()
Dim x2 = geometry().topLeft().x() - frameGeometry().topLeft().x()
Dim y2 = geometry().topLeft().y() - frameGeometry().topLeft().y()
clickPos = New QPoint(x1 + x2, y1 + y2)
End If
End Sub
Sub mouseMoveEvent(e As QMouseEvent)
If isTopLevel() Then
Dim x = e.globalPos().x() - clickPos.x()
Dim y = e.globalPos().y() - clickPos.y()
move(x, y)
End If
End Sub
'
' When we set an explicit time we don't want the timeout() slot to be
' called anymore as this relies on currentTime()
'
Public Slot setTime(t As QTime)
time2 = t
' TODO2 disconnect( internalTimer, SIGNAL(timeout()), me, SLOT(timeout()) )
If autoMask() Then
updateMask()
Else
update ( )
End If
End Slot
'
' The QTimer.timeout() signal is received by this slot.
'
Private Slot timeout()
Dim old_time As QTime = time2
time2 = QTime.currentTime()
If old_time.minute() <> time2.minute()_
OrElse old_time.hour() <> time2.hour() Then ' minute or hour has changed
If autoMask() Then
updateMask()
Else
update()
End If
End If
End Slot
Sub paintEvent(e As QPaintEvent)
If autoMask() Then End
Dim p As New QPainter(Me)
drawClock( p )
End Sub
' The clock is painted using a 1000x1000 square coordinate system, in
' the a centered square, as big as possible. The painter's pen and
' brush colors are used.
Sub drawClock(p As QPainter)
p.save()
p.setWindow( -500,-500, 1000,1000 )
Dim v As QRect = p.viewport()
Dim d As Integer = 0
If v.width() > v.height() Then
d = v.height()
Else
d = v.width()
End If
p.setViewport(v.left() + (v.width() - d) / 2, v.top() + (v.height() - d) / 2, d, d)
p.save()
p.rotate(30 * (time2.hour() Mod 12 - 3) + time2.minute() / 2)
p.setPen(new QPen(new QColor(0, 0, 0), 4, Qt.DashLine))
p.drawLine(0, 0, 300, 0)
p.restore()
p.save()
p.rotate((time2.minute() - 15) * 6)
p.setPen(new QPen(new QColor(0, 0, 0), 4, Qt.DashLine))
p.drawLine(0, 0, 400, 0)
p.restore()
For i As Integer = 0 To 11
p.drawLine(440, 0, 460, 0)
p.rotate(30)
Next
p.restore()
End Sub
' If the clock is transparent, we use updateMask()
' instead of paintEvent()
Sub updateMask() ' paint clock mask
Dim bm As New QBitmap(size())
Dim color0 As QColor = New QColor(255, 255, 255)
bm.fill(color0) 'transparent
Dim p As New QPainter
p.begin(bm, Me)
drawClock(p)
p.end()
setMask( bm )
End Sub
Sub setAutoMask(b As Boolean)
If b Then
setBackgroundMode( Qt.PaletteForeground )
Else
setBackgroundMode( Qt.PaletteBackground )
End If
Parent.setAutoMask(b)
End Sub
End Class
Dim i As Integer
'****************************************************************************
'**
'** Copyright ( C ) 1992-2000 Trolltech AS. All rights reserved.
'**
'** This file is part of an example program for Qt. This example
'** program may be used, distributed and modified without limitation.
'**
'*****************************************************************************/
' Analog Clock
' This example displays an analog clock widget.
Class AnalogClock4 Inherits QWidget
Private clickPos As QPoint
Private time2 As QTime
Private internalTimer As QTimer
Constructor AnalogClock4()
time2 = QTime.currentTime() ' get current time
internalTimer = New QTimer(Me) ' create internal timer
connect(internalTimer, Signal(timeout()), Me, Slot(timeout()))
internalTimer.start(5000, False) ' emit signal every 5 seconds
End Constructor
Sub mousePressEvent(e As QMouseEvent)
If isTopLevel() Then
Dim x1 As Integer = e.pos().x()
Dim y1 = e.pos().y()
Dim x2 = geometry().topLeft().x() - frameGeometry().topLeft().x()
Dim y2 = geometry().topLeft().y() - frameGeometry().topLeft().y()
clickPos = New QPoint(x1 + x2, y1 + y2)
End If
End Sub
Sub mouseMoveEvent(e As QMouseEvent)
If isTopLevel() Then
Dim x = e.globalPos().x() - clickPos.x()
Dim y = e.globalPos().y() - clickPos.y()
move(x, y)
End If
End Sub
'
' When we set an explicit time we don't want the timeout() slot to be
' called anymore as this relies on currentTime()
'
Public Slot setTime(t As QTime)
time2 = t
' TODO2 disconnect( internalTimer, SIGNAL(timeout()), me, SLOT(timeout()) )
If autoMask() Then
updateMask()
Else
update ( )
End If
End Slot
'
' The QTimer.timeout() signal is received by this slot.
'
Private Slot timeout()
Dim old_time As QTime = time2
time2 = QTime.currentTime()
If old_time.minute() <> time2.minute()_
OrElse old_time.hour() <> time2.hour() Then ' minute or hour has changed
If autoMask() Then
updateMask()
Else
update()
End If
End If
End Slot
Sub paintEvent(e As QPaintEvent)
If autoMask() Then End
Dim p As New QPainter(Me)
drawClock( p )
End Sub
' The clock is painted using a 1000x1000 square coordinate system, in
' the a centered square, as big as possible. The painter's pen and
' brush colors are used.
Sub drawClock(p As QPainter)
p.save()
p.setWindow( -500,-500, 1000,1000 )
Dim v As QRect = p.viewport()
Dim d As Integer = 0
If v.width() > v.height() Then
d = v.height()
Else
d = v.width()
End If
p.setViewport(v.left() + (v.width() - d) / 2, v.top() + (v.height() - d) / 2, d, d)
p.save()
p.rotate(30 * (time2.hour() Mod 12 - 3) + time2.minute() / 2)
p.setPen(new QPen(new QColor(0, 0, 0), 4, Qt.DashLine))
p.drawLine(0, 0, 300, 0)
p.restore()
p.save()
p.rotate((time2.minute() - 15) * 6)
p.setPen(new QPen(new QColor(0, 0, 0), 4, Qt.DashLine))
p.drawLine(0, 0, 400, 0)
p.restore()
For i As Integer = 0 To 11
p.drawLine(440, 0, 460, 0)
p.rotate(30)
Next
p.restore()
End Sub
' If the clock is transparent, we use updateMask()
' instead of paintEvent()
Sub updateMask() ' paint clock mask
Dim bm As New QBitmap(size())
Dim color0 As QColor = New QColor(255, 255, 255)
bm.fill(color0) 'transparent
Dim p As New QPainter
p.begin(bm, Me)
drawClock(p)
p.end()
setMask( bm )
End Sub
Sub setAutoMask(b As Boolean)
If b Then
setBackgroundMode( Qt.PaletteForeground )
Else
setBackgroundMode( Qt.PaletteBackground )
End If
Parent.setAutoMask(b)
End Sub
End Class
Dim clock As New AnalogClock()
'clock.setAutoMask(true)
clock.resize(650, 400)
clock.setCaption("Qt Example - Analog Clock")
'clock.setPaletteBackgroundPixmap(new QPixmap(new QImage("c:\kbasic\ide\9.jpg")))
clock.show()
'clock.setTime(new QTime(6, 44))
Do While true
Loop
Dim clock As New AnalogClock()
'clock.setAutoMask(true)
clock.resize(650, 400)
clock.setCaption("Qt Example - Analog Clock")
'clock.setPaletteBackgroundPixmap(new QPixmap(new QImage("c:\kbasic\ide\9.jpg")))
clock.show()
'clock.setTime(new QTime(6, 44))
Do While true
Loop
'****************************************************************************
'**
'** Copyright ( C ) 1992-2000 Trolltech AS. All rights reserved.
'**
'** This file is part of an example program for Qt. This example
'** program may be used, distributed and modified without limitation.
'**
'*****************************************************************************/
' Analog Clock
' This example displays an analog clock widget.
Class AnalogClock5 Inherits QWidget
Private clickPos As QPoint
Private time2 As QTime
Private internalTimer As QTimer
Constructor AnalogClock5()
time2 = QTime.currentTime() ' get current time
internalTimer = New QTimer(Me) ' create internal timer
connect(internalTimer, Signal(timeout()), Me, Slot(timeout()))
internalTimer.start(5000, False) ' emit signal every 5 seconds
End Constructor
Sub mousePressEvent(e As QMouseEvent)
If isTopLevel() Then
Dim x1 As Integer = e.pos().x()
Dim y1 = e.pos().y()
Dim x2 = geometry().topLeft().x() - frameGeometry().topLeft().x()
Dim y2 = geometry().topLeft().y() - frameGeometry().topLeft().y()
clickPos = New QPoint(x1 + x2, y1 + y2)
End If
End Sub
Sub mouseMoveEvent(e As QMouseEvent)
If isTopLevel() Then
Dim x = e.globalPos().x() - clickPos.x()
Dim y = e.globalPos().y() - clickPos.y()
move(x, y)
End If
End Sub
'
' When we set an explicit time we don't want the timeout() slot to be
' called anymore as this relies on currentTime()
'
Public Slot setTime(t As QTime)
time2 = t
' TODO2 disconnect( internalTimer, SIGNAL(timeout()), me, SLOT(timeout()) )
If autoMask() Then
updateMask()
Else
update ( )
End If
End Slot
'
' The QTimer.timeout() signal is received by this slot.
'
Private Slot timeout()
Dim old_time As QTime = time2
time2 = QTime.currentTime()
If old_time.minute() <> time2.minute()_
OrElse old_time.hour() <> time2.hour() Then ' minute or hour has changed
If autoMask() Then
updateMask()
Else
update()
End If
End If
End Slot
Sub paintEvent(e As QPaintEvent)
If autoMask() Then End
Dim p As New QPainter(Me)
drawClock( p )
End Sub
' The clock is painted using a 1000x1000 square coordinate system, in
' the a centered square, as big as possible. The painter's pen and
' brush colors are used.
Sub drawClock(p As QPainter)
p.save()
p.setWindow( -500,-500, 1000,1000 )
Dim v As QRect = p.viewport()
Dim d As Integer = 0
If v.width() > v.height() Then
d = v.height()
Else
d = v.width()
End If
p.setViewport(v.left() + (v.width() - d) / 2, v.top() + (v.height() - d) / 2, d, d)
p.save()
p.rotate(30 * (time2.hour() Mod 12 - 3) + time2.minute() / 2)
p.setPen(new QPen(new QColor(0, 0, 0), 4, Qt.DashLine))
p.drawLine(0, 0, 300, 0)
p.restore()
p.save()
p.rotate((time2.minute() - 15) * 6)
p.setPen(new QPen(new QColor(0, 0, 0), 4, Qt.DashLine))
p.drawLine(0, 0, 400, 0)
p.restore()
For i As Integer = 0 To 11
p.drawLine(440, 0, 460, 0)
p.rotate(30)
Next
p.restore()
End Sub
' If the clock is transparent, we use updateMask()
' instead of paintEvent()
Sub updateMask() ' paint clock mask
Dim bm As New QBitmap(size())
Dim color0 As QColor = New QColor(255, 255, 255)
bm.fill(color0) 'transparent
Dim p As New QPainter
p.begin(bm, Me)
drawClock(p)
p.end()
setMask( bm )
End Sub
Sub setAutoMask(b As Boolean)
If b Then
setBackgroundMode( Qt.PaletteForeground )
Else
setBackgroundMode( Qt.PaletteBackground )
End If
Parent.setAutoMask(b)
End Sub
End Class
Dim clock As New AnalogClock()
'clock.setAutoMask(true)
clock.resize(650, 400)
clock.setCaption("Qt Example - Analog Clock")
'clock.setPaletteBackgroundPixmap(new QPixmap(new QImage("c:\kbasic\ide\9.jpg")))
clock.show()
'clock.setTime(new QTime(6, 44))
Do While true
Loop
'****************************************************************************
'**
'** Copyright ( C ) 1992-2000 Trolltech AS. All rights reserved.
'**
'** This file is part of an example program for Qt. This example
'** program may be used, distributed and modified without limitation.
'**
'*****************************************************************************/
' Analog Clock
' This example displays an analog clock widget.
Class AnalogClock6 Inherits QWidget
Private clickPos As QPoint
Private time2 As QTime
Private internalTimer As QTimer
Constructor AnalogClock6()
time2 = QTime.currentTime() ' get current time
internalTimer = New QTimer(Me) ' create internal timer
connect(internalTimer, Signal(timeout()), Me, Slot(timeout()))
internalTimer.start(5000, False) ' emit signal every 5 seconds
End Constructor
Sub mousePressEvent(e As QMouseEvent)
If isTopLevel() Then
Dim x1 As Integer = e.pos().x()
Dim y1 = e.pos().y()
Dim x2 = geometry().topLeft().x() - frameGeometry().topLeft().x()
Dim y2 = geometry().topLeft().y() - frameGeometry().topLeft().y()
clickPos = New QPoint(x1 + x2, y1 + y2)
End If
End Sub
Sub mouseMoveEvent(e As QMouseEvent)
If isTopLevel() Then
Dim x = e.globalPos().x() - clickPos.x()
Dim y = e.globalPos().y() - clickPos.y()
move(x, y)
End If
End Sub
'
' When we set an explicit time we don't want the timeout() slot to be
' called anymore as this relies on currentTime()
'
Public Slot setTime(t As QTime)
time2 = t
' TODO2 disconnect( internalTimer, SIGNAL(timeout()), me, SLOT(timeout()) )
If autoMask() Then
updateMask()
Else
update ( )
End If
End Slot
'
' The QTimer.timeout() signal is received by this slot.
'
Private Slot timeout()
Dim old_time As QTime = time2
time2 = QTime.currentTime()
If old_time.minute() <> time2.minute()_
OrElse old_time.hour() <> time2.hour() Then ' minute or hour has changed
If autoMask() Then
updateMask()
Else
update()
End If
End If
End Slot
Sub paintEvent(e As QPaintEvent)
If autoMask() Then End
Dim p As New QPainter(Me)
drawClock( p )
End Sub
' The clock is painted using a 1000x1000 square coordinate system, in
' the a centered square, as big as possible. The painter's pen and
' brush colors are used.
Sub drawClock(p As QPainter)
p.save()
p.setWindow( -500,-500, 1000,1000 )
Dim v As QRect = p.viewport()
Dim d As Integer = 0
If v.width() > v.height() Then
d = v.height()
Else
d = v.width()
End If
p.setViewport(v.left() + (v.width() - d) / 2, v.top() + (v.height() - d) / 2, d, d)
p.save()
p.rotate(30 * (time2.hour() Mod 12 - 3) + time2.minute() / 2)
p.setPen(new QPen(new QColor(0, 0, 0), 4, Qt.DashLine))
p.drawLine(0, 0, 300, 0)
p.restore()
p.save()
p.rotate((time2.minute() - 15) * 6)
p.setPen(new QPen(new QColor(0, 0, 0), 4, Qt.DashLine))
p.drawLine(0, 0, 400, 0)
p.restore()
For i As Integer = 0 To 11
p.drawLine(440, 0, 460, 0)
p.rotate(30)
Next
p.restore()
End Sub
' If the clock is transparent, we use updateMask()
' instead of paintEvent()
Sub updateMask() ' paint clock mask
Dim bm As New QBitmap(size())
Dim color0 As QColor = New QColor(255, 255, 255)
bm.fill(color0) 'transparent
Dim p As New QPainter
p.begin(bm, Me)
drawClock(p)
p.end()
setMask( bm )
End Sub
Sub setAutoMask(b As Boolean)
If b Then
setBackgroundMode( Qt.PaletteForeground )
Else
setBackgroundMode( Qt.PaletteBackground )
End If
Parent.setAutoMask(b)
End Sub
End Class
Dim clock As New AnalogClock()
'clock.setAutoMask(true)
clock.resize(650, 400)
clock.setCaption("Qt Example - Analog Clock")
'clock.setPaletteBackgroundPixmap(new QPixmap(new QImage("c:\kbasic\ide\9.jpg")))
clock.show()
'clock.setTime(new QTime(6, 44))
Do While true
Loop
CLASS rumba
SUB dance
PRINT "rumba.dance"
END SUB
END CLASS
PUBLIC SUB test() THROWS rumba
THROW NEW rumba
End Sub
TRY
test()
CATCH (b AS rumba)
PRINT "got you!"
END CATCH
CHDIR("/home/bernd")
CHDRIVE "C" ' change to D:
DIM s AS STRING s = CHOOSE(2, "un", "deux", "troi") PRINT s
Dim I, filename For I = 1 To 3 ' repeat loop 3 times filename = "TEST" & I ' create filename Open filename For Output As #I ' open file Print #I, "Ein Test." ' write string into file Next I Close ' close all 3 opened files
OPTION OLDBASIC ' CLS clearing the terminal screen ' with a new background color PRINT "This is to show the CLS command" INPUT "To clear the screen, press [Return]", keypressed$ ' changes the background color: COLOR (2, 1) CLS PRINT "This is green text on a blue screen!"
COLOR(5) PRINT "Hi" COLOR(15,1) PRINT "Nadja"
Sub Namer ( ) Const pi = 3.14 Print pi End Sub Namer() Sub test Dim k As Integer k = 9 + 23 Print k End Sub CONST a = 123.88 * 2, bb = 6 Const k As Integer = 2 DIM i AS DOUBLE i = bb test 'a = i ' would cause a parser error
CLASS rumba
PRIVATE latein AS INTEGER
PUBLIC englisch AS STRING
Dim k
'PRIVATE CONST kbAccess = 0
PUBLIC SUB dance_rumba()
Print "rumba!!!"
'print mySalsa.var
END SUB
CONSTRUCTOR rumba()
PRINT "constructor"
END CONSTRUCTOR
DESTRUCTOR rumba()
PRINT "destructor"
END DESTRUCTOR
END CLASS
DIM t AS NEW rumba
PRINT COS(232)
OPTION OLDBASIC PRINT "row = " + POS(0) INPUT s$ PRINT "line = " + CSRLIN PRINT s$
' Windows:
' C: is the active drive.
Dim path
path = CurDir'
path = CurDir("C")
path = CurDir("D")
Option OldBasic
Sub test()
Print doubleit("395.45bernd")
End Sub
Function doubleit(no)
If IsNumeric(no) Then
doubleit = no* 2 ' return result
Else
doubleit = CVErr(2001) ' return user defined error
End If
End Function
test()
CLASS rumba
PRIVATE latein AS INTEGER
PUBLIC englisch AS STRING
Dim k
'PRIVATE CONST kbAccess = 0
PUBLIC SUB dance_rumba()
Print "rumba!!!"
'print mySalsa.var
END SUB
CONSTRUCTOR rumba()
PRINT "constructor"
END CONSTRUCTOR
DESTRUCTOR rumba()
PRINT "destructor"
END DESTRUCTOR
END CLASS
DIM r AS NEW rumba
DIM x AS INTEGER x = 1 * x + 100000 / 47323 DIM n = 999 AS INTEGER DIM i AS INTEGER i = 3 i = 333333
Dim Name1 As String
Name1 = Dir("c:\", kbDirectory) ' first entry
Do While Name1 <> "" ' loop
If Name1 <> "." And Name1 <> ".." Then
If (GetAttr(Name1) And kbDirectory) = kbDirectory Then
Print Name1
End If
End If
Name1 = Dir ' next entry
Loop
Dim d As Double d = 0#
END
Dim i As Integer Do While True i = i + 1 Loop
Enum Level Mo= -1 Di = 0 Fr = 1 Sa = 1 + Fr AND 2 End Enum Enum test Entry Entry2 Security = Entry End Enum 'Debug. Print 3 + Level.Mo Print test.Entry Print test.Security
Enum unit_type people pilot scientist soldier End Enum Dim r As unit_type r = unit_type.people
OPTION OLDBASIC
CLS
OPEN "TEST.DAT" FOR OUTPUT AS #1
FOR i% = 1 TO 10
WRITE #1, i%, 2 * i%, 5 * i%
NEXT i%
CLOSE #1
OPEN "TEST.DAT" FOR INPUT AS #1
DO
LINE INPUT #1, a$
PRINT a$
LOOP UNTIL (EOF(1))
CLS DIM im _ AS INTEGER ' test the multi line symbol _ DIM i _ AS INTEGER DIM n = 12 AS INTEGER i _ = _ 33 _ + 9 PRINT i IF (i = 77 OR i = 0 _ AND 1) THEN n = 33 PRINT n END IF i = 2 * _ 99 * 4 _ / _ n _ * 77 IF (i = 42 _ OR i = 42) THEN PRINT i END IF PRINT i
PRINT ERL
Dim Msg On Error Resume Next Err.Clear Err.Raise 6 If ERR.Number <> 0 Then Msg = "Error # " & Str(Err.Number) & " " _ & Err.Source & Chr(13) & Err.Description MsgBox Msg, , "Error" End If
Dim filehandle, Mode filehandle = 1 Open "file1" For Append As filehandle Mode = FileAttr(filehandle, 1) ' returns 8 (Append). Close filehandle ' close file
Sub FileDialog(sDir As String, n As Integer, ByRef sReturn As String)
CLS
Print "File Dialog"
Print "************************************************************"
Dim Name1 As String
Name1 = Dir(sDir) ' first entry
Do While Name1 <> "" ' loop
If (GetAttr(Name1) And n) = n Then
Print "Dir --> " + Name1
Else
Print "File " + Name1
End If
Name1 = Dir ' next entry
Loop
Print "************************************************************"
Input "Bitte wählen Sie eine Datei:"; Name1
sReturn = Name1
End Sub
Dim sFilename As String
FileDialog("c:\kbasic15\i*.cpp", kbDirectory, sFilename)
Print "Sie haben Datei " + sFilename + " gewählt."
Dim Index1, filehandle For Index1 = 1 To 5 filehandle = FreeFile ' next free available file handle Open "TEST" & Index1 For Output As #filehandle Write #filehandle, "example text." Close #filehandle Next
TYPE TestRecord
Student AS STRING * 20
Result AS SINGLE
END TYPE
DIM MyClass2 AS TestRecord
OPEN "ENDRESULTS.DAT" FOR RANDOM AS #1 LEN = LEN(MyClass2)
MyClass2.Student = "Bernd Noetscher"
MyClass2.Result = 99
PUT #1, 1, MyClass2
CLOSE #1
OPEN "ENDRESULTS.DAT" FOR RANDOM AS #1 LEN = LEN(MyClass2)
GET #1, 1, MyClass2
PRINT "STUDENT:", MyClass2.Student
PRINT "SCORE:", MyClass2.Result
CLOSE #1
KILL "ENDRESULTS.DAT"
Dim Attr1
' "hidden" has been set for TSTFILE
Attr1 = GetAttr("TSTFILE") ' returns 2.
DIM b AS INTEGER DIM n AS INTEGER b = 45 GOTO bernd b = 99999 bernd: n = 0 ok: n = n + 1 IF n < 5 THEN GOTO ok
DIM j AS INTEGER = 6 DIM i = 4 AS INTEGER DIM n AS INTEGER IF i = 5 THEN n = 66: n = 55 IF i = 4 THEN n = 77: n = 99 'IF i = 4 THEN : n = 4: n = 10 '$END IF i <> 1 THEN: n = 11111: ENDIF IF i <> 1 THEN n = 11111 : n = 9 ELSEIF i = 2 * 10 THEN n = 22222 ELSE n = 33333 ENDIF IF i <> 1 THEN n = 11111 END IF PRINT n $END DIM nReturn AS INTEGER nReturn = (-.5) + (-1) + 99 nReturn = (-(+5 - -1) * -2) * 4 / -4 END DIM x,y AS INTEGER ' must be MSC_ID_INTEGER DIM integer__% ' must be MSC_ID_DOUBLE DIM double__# ' must be MSC_ID_SINGLE DIM single__! ' must be MSC_ID_STRING DIM string__$ ' must be MSC_ID_LONG DIM long__& long__& = 12 double__& = 10 / 3 double__& = 10 \ 3 ' integer division! 'single__! = 10.10! double__# = 22.22# string__$ = "kbasic" integer__% = 123434% 'long__& = 2134& END x=1 y=1 y = x AND y END DIM b AS BOOLEAN DIM t AS SINGLE DIM ll AS LONG DIM aa AS LONG DIM b1=1, b2=0 AS BOOLEAN ll = 234 aa = 99 t = 2.8 IF b1 OR b2 AND ll THEN 'IF ll = 234 AND t = 2.8 THEN aa = 123456 ENDIF b = false END DIM n AS INTEGER DIM i AS INTEGER DIM x AS INTEGER i = &O4 IF i <> 1 THEN n = 11111 ELSE n = 33333 print i IF i = 1 THEN n = 11111 ELSEIF i = 2 THEN n = 22222 ELSEIF i = 3 THEN n = 33333 ELSEIF i = 4 THEN n = 44444 ELSE n = 55555 ENDIF END i = 20 i = 20 IF i <> 1 THEN n = 11111 ELSEIF i = 2 * 10 THEN n = 22222 ELSE n = 33333 ENDIF 'FOR i = 1 TO 10 ' n = 123 'NEXT DIM bRet AS BOOLEAN DIM b AS BOOLEAN DIM nReturn AS INTEGER 'GOTO ok bRet = TRUE 'ok: b = 45 'nReturn = 5 - 1 * (2 * 4) * 7 / 8 nReturn = ((+5 - -1) * -2) * 4 / -4 + 9 * 88 - 88 'nReturn = (-.5) + (-1) + 6 'nReturn = 4 + 5 * 6 4000 n = +10 * +8 8000 n = TRUE 9000 nReturn = 4 + 5 MOD 2 ' IF i = 10 THEN ' PRINT i ' ENDIF
DIM s AS STRING DIM i AS INTEGER i = 1 s = IIF(i = 1, "Der Menschen Hörigkeit", "Casanova") PRINT s
cls PRINT "Press Esc, to stop ..." DO LOOP UNTIL INKEY$ = CHR$(27) '27 is the ASCII-Code for Esc.
OPTION OLDBASIC
CLS
OPEN "LIST" FOR OUTPUT AS #1
DO
INPUT " NAME: ", Name$ 'input from keyboard
INPUT " Age: ", Age$
WRITE #1, Name$, Age$
INPUT "Type a new entry"; R$
LOOP WHILE UCASE$(R$) = "Y"
CLOSE #1
'print content of file
OPEN "LIST" FOR INPUT AS #1
CLS
PRINT "entries of file:": PRINT
DO WHILE NOT EOF(1)
LINE INPUT #1, REC$
PRINT REC$
LOOP
CLOSE #1
Dim Msg, Titel, defv, Wert1 Msg = "Input value between 1 and 3" Titel = "InputBox-Demo" defv = "1" Wert1 = InputBox ( Msg , Titel , defv )
DIM s$ s$ = "Bernd Noetscher's KBasic" PRINT "string position = "; INSTR(1, s$, "KBasic")
dim x as string, y as string x = "This is a string" y = "s" PRINT INSTREV(x, y)
Dim array1(1 To 5) As Integer, array2, Test1 array2 = Array(1, 2, 3) Test1 = IsArray(array1) ' returns True. Print Test1 Test1 = IsArray(array2) ' returns True. Print Test1
DIM v AS VARIANT PRINT ISEMPTY(v)
Function Benutzerfunktion() 'Return 0 Return CVERR(23) End Function Dim result, Test1 result = Benutzerfunktion() Test1 = IsError(result) ' return true.
Option OldBasic Dim result result = doubleit() ' returns 0. Print result result = doubleit(2) ' returns 4. Print result Function doubleit(Optional ByVal A) If IsMissing(A) Then ' if no argument, then return 0 doubleit = 0 Else ' if argument, then return double value doubleit = A * 2 End If End Function
DIM v AS VARIANT v = Null PRINT ISNULL(v)
DIM n = 0 AS INTEGER DIM b = FALSE AS BOOLEAN DO n = n + 1 PRINT n IF n = 3 THEN b = TRUE ELSE IF n = 6 THEN b = TRUE ELSE b = FALSE IF n = 4 THEN b = TRUE ELSE ITERATE DO PRINT "something" LOOP UNTIL b = TRUE
' This deletes the file "test.xml": KILL "test.xml"
TYPE book bkname AS STRING * 100 isbn(1000) AS INTEGER END TYPE TYPE address books(50) AS book age AS INTEGER name AS STRING * 100 END TYPE DIM j(5 TO 10) AS book PRINT LBOUND(j, 1)
PRINT LCASE$("KBASIC")
DIM src AS STRING src = "What a nice day" PRINT LEFT$(src, 4)
Dim s As String s = "Bernd Noetscher's KBasic" Print Len(s) 'Print s.Len() '? "hi".Len()
CLS
For a As Integer = 1 To 15
Line(10, a * 80) - (1000, a * 80), 15
Next
For a = 1 To 15
Line(a * 80, 10) - (a * 80, 1000), 15
Next
For y As Integer = 1 To 100
For i As Integer = 1 To 600
Locate 1, 1 : Print "y=" + y + " : i=" + i
Line(11 + i + y, 11 + i + y) - (2 * i + y, 11 + i + y), i / 10
Next
Next
Dim text Open "file1" For Input As #1 ' open file Do While Not EOF(1) ' loop until end of file Line Input #1, text ' read line into variable Print text Loop Close #1
PRINT LN(33)
OPTION OLDBASIC CLS LOCATE 5, 5 row% = CSRLIN column% = POS(0) PRINT "position 1 (press any key)" DO LOOP WHILE INKEY$ = "" LOCATE (row% + 2), (column% + 2) PRINT "position 2"
OPTION OLDBASIC INPUT "input filename: "; f$ OPEN f$ FOR BINARY AS #1 PRINT "file len is = "; LOF(1) CLOSE
PRINT LOG(675)
PRINT LTRIM$(" bedazzeled ")
~' if then else example
Dim itsFunny As Boolean = True
If itsFunny Then
~ Print "Laughing :-)"
Else
~ Print "...BORING!"
End If
Do
loop While True
~' if then else example Dim itsFunny As Boolean = True If itsFunny Then ~ Print "Laughing :-)" Else ~ Print "...BORING!" End If
PRINT MAX(44, 3)
Class k
Sub julie
Print "Julie"
nadja
End Sub
Sub nadja
Print "Nadja"
End Sub
End Class
Dim kk As New k
kk.julie
OPTION OLDBASIC text$ = "The dog bites the cat" text$ = MID$(text$, 10, 1) PRINT text$
OPTION OLDBASIC
DIM txt AS STRING, replacement AS STRING, originaltxt AS STRING
txt = "The dog bites the cat"
MID(txt, 5) = "cat"
PRINT txt
MID(txt, 19) = "dog"
PRINT txt
MID(txt, 5) = "text is too long for the string"
PRINT txt
$END
replacement = "The power of KBasic"
originaltxt = "*********************"
FOR i = 1 to LEN(replacement)
MID(originaltxt, 2, i) = replacement
PRINT originaltxt
NEXT i
OPTION OLDBASIC
DIM txt AS STRING, replacement AS STRING, originaltxt AS STRING
replacement = "The power of KBasic"
originaltxt = "*********************"
FOR i = 1 to LEN(replacement)
MID(originaltxt, 2, i) = replacement
PRINT originaltxt
NEXT i
PRINT MIN(45, 4)
MKDIR "C:\TEMP\TEST" CHDIR "C:\TEMP" FILES RMDIR "TEST"
MODULE einkauf PUBLIC m AS INTEGER '= 88 END MODULE MODULE verkauf DIM m2 AS INTEGER END MODULE m = 88 m2 = 234 Print m Print m2 Print einkauf.m Print verkauf.m2
Dim answer = MsgBox("Hi", kbOKOnly, "Question")
NAME "old.txt" AS "new.txt"
Function test() Return Null End Function Print "'" + Nz(test) + "'" ' --> ""
CLASS rumba
PRIVATE latein AS INTEGER
PUBLIC englisch AS STRING
Dim k
'PRIVATE CONST kbAccess = 0
PUBLIC SUB dance_rumba()
Print "rumba!!!"
'print mySalsa.var
END SUB
' CONSTRUCTOR rumba2()
' PRINT "constructor"
' END CONSTRUCTOR
'
' DESTRUCTOR rumba3()
' PRINT "destructor"
' END DESTRUCTOR
END CLASS
'Dim Emp As rumba = New rumba
DIM m AS NEW rumba
m.dance_rumba()
'Print m.latein
'Print m.mySalsa.var
Class a
Constructor a
myB = New b
End Constructor
Sub send()
myB.receive()
End Sub
Sub receive()
myB.send()
End Sub
Private myB As b
End Class
Class b
Constructor b
myA = New a
End Constructor
Sub send()
myA.receive()
End Sub
Sub receive()
myA.send()
End Sub
Private myA As a
End Class
New a()
PRINT OCT$(8)
Dim TextLine As String, ff As Integer ff = FreeFile ' next availaible filehandle Open "test.txt" For Input As #ff ' open test file Do While Not EOF(ff) ' while end of file has not been reached Line Input #ff, TextLine ' store next line in string print TextLine Loop Close #ff ' Datei schließen
Function monique(ByRef i As Integer, ByVal h As Double, ParamArray b() As Variant) As Integer return i END FUNCTION DIM m = 1 AS INTEGER PRINT monique( h:=12.2, i:=m ) PRINT monique( m, 12.2 ) 'PRINT monique(1)
OPTION OLDBASIC PRINT POS(0) INPUT s$ PRINT CSRLIN PRINT s$
PRINT USING "##.### "; 12.12345
CLASS snowBerries
Private MonthNum As Integer' = 1 ' Internal storage for property value.
Property Month2() As Integer
Get
Return MonthNum
End Get
Set(Value As Integer)
If Value < 1 Or Value > 12 Then
' Error processing for invalid value.
Else
MonthNum = Value
End If
End Set
End Property ' Month
END CLASS
DIM m AS NEW snowBerries
m.Month2 = 10
Print m.Month2
TYPE TestRecord
Student AS STRING * 20
Result AS SINGLE
END TYPE
DIM clss AS TestRecord
OPEN "ENDRESULTS.DAT" FOR RANDOM AS #1 LEN = LEN(clss)
clss.Student = "Bernd Noetscher"
clss.Result = 99
PUT #1, 1, clss
CLOSE #1
OPEN "ENDRESULTS.DAT" FOR RANDOM AS #1 LEN = LEN(clss)
GET #1, 1, clss
PRINT "STUDENT:", clss.Student
PRINT "SCORE:", clss.Result
CLOSE #1
KILL "ENDRESULTS.DAT"
SUB t DIM s (100) AS STRING s (1) = "You are my angel." REDIM s (10) REDIM s (1000) REDIM s (1) s (1) = "Without your love..." END SUB t()
rem ' This is yet another test ' c = 3.14 REM This is another test ' a = 4 print "The end!" ' another rem here! 'END : REM definitely the end DIM n AS INTEGER DIM s AS STRING /** this is a documentation comment */ /* this is mulitline comment */ /* s = "to be or not to be" n = 200 */ REM n = 9999 REM n fkdjfalksjfd 'fdnklfsflsgdngndl dflyjvn REM This is a test of REM ' x = 2 PRINT "Gloria in exelsis deo."
DIM s = "Das ist alles was wir brauchen. Fang nochmal von vorne an." DIM pattern = "vorne" DIM toReplace = "hinten" PRINT REPLACE(s, pattern, toReplace)
RESET
Dim red red = RGB(255, 0, 0)
MKDIR "C:\TEMP\TEST" CHDIR "C:\TEMP" FILES RMDIR "TEST"
OPTION OLDBASIC RANDOMIZE TIMER x% = INT(RND * 6) + 1 y% = INT(RND * 6) + 1 PRINT "2 Würfe mit einem Würfel: Wurf 1 ="; x%; "und Wurf 2 ="; y% END CLS FOR i = 1 TO 300 'PRINT(RND(-7)) 'PRINT TIMER NEXT PRINT TIMER
PRINT RTRIM$(" bedazzeled ")
PRINT SGN(77) PRINT SGN(1), SGN(-1), SGN(0) ' 1 -1 0
PRINT SIN(44)
PRINT "Pausing 5 seconds..." SLEEP 5 PRINT "Continue..."
PRINT SPACE$(4.3 + 2) PRINT "*" + SPACE(5) + "*"
PRINT SQR(44)
STATIC SUB myMsgbox(i AS INTEGER) DIM s AS STRING IF i = 0 THEN s = "Je suis Bernd. Tu't appelles comment?" PRINT s END SUB myMsgbox (0) myMsgbox (1)
STOP
PRINT STR$(23.546)
Option OldBasic Dim Text1, Text2, Vergl Text1 = "ABCD": Text2 = "abcd" ' Verg1 = StrComp(Text1, Text2, 1) ' result:0. Verg1 = StrComp(Text1, Text2, 0) ' result:-1. Verg1 = StrComp(Text2, Text1) ' result:1.
CLS DIM s = "I really knew it, KBasic will be great!" ' static string PRINT s DIM z AS STRING * 80 z = "he" PRINT z DIM a = "Langsamer" AS STRING DIM b = " Walzer" AS STRING DIM c AS STRING c = "Langsamer" + " Walzer" ' static string + static string PRINT c c = a + b ' string + string PRINT c DIM uu AS STRING uu = " ""Help""you"" " uu = """"" """"""""""Help""you""""" uu = " """" """"""""""Help""you"""" " 'uu = "Help""""you" 'uu = "111" 'uu = uu + "222" DIM n="hello" AS STRING * 1000 ' max length of 1000 characters, like "char s[1000]" in C++ PRINT n LOCATE 25, 3 PRINT uu STOP
PRINT STRING$(10, "*") PRINT STRING$(22, 65) 'PRINT "Welcome to " + STRING$(10, "*")
SUB downloadFile() DIM tti# tti = 99 ' EXIT SUB END SUB downloadFile()
Sub location() Print "location" fly() End Sub Sub fly() Print "fly" End Sub Sub intercepting() Print "intercepting" location() End Sub CLS intercepting()
Dim s As String Dim i As Integer i = 2 s = Switch ( i = 1 , "Der Menschen Hörigkeit" , i = 2 , "Casanova" ) Print s
SYSTEM
PRINT TAN(333)
Class a
Public i As Integer
End Class
Class b
Sub testing
Dim aa As New a
Dim k As Integer
k = aa.i
End Sub
End Class
Dim bb As New b()
bb.testing()
/*
'Option OldBasic
Enum dud
n1
n2
End Enum
'Class zzz
'End Class
Module c
Public i As Double
Const h = "hello!!!"
End Module
Module d
Sub testing() Throws zzz
Dim k As Integer
Const v = 999
k = c.i
uuu()
Throw New zzz
End Sub
Sub uuu
Dim z As Single
End Sub
End Module
Dim g As dud
g = dud.n1
'
'Try
' d.testing()
'Catch (zz As zzz)
' Dim rz = 12345
'End Catch
*/
Color(15, 0) ' default
Color(15, 5)
Print "hello"
Print Max(30.05, 30)
Color(15, 0) ' switch to default
Print "hello"
SUB nadja()
DIM i AS INTEGER
END SUB
k:
DIM c[100] AS INTEGER
c[0] = 21
'PRINT c
nadja
GOTO k
PRINT TRIM$(" bedazzeled ")
TYPE book bkname AS STRING * 100 isbn(1000) AS INTEGER END TYPE TYPE address books(500) AS book age AS INTEGER NAME AS STRING * 100 a AS book END TYPE DIM j(5 TO 10) AS address 'PRINT LBOUND(j, 1) j(5).books(99).isbn[2] = 123 j(5).a.isbn(10) = 1000 j(5).books(99).isbn[2] = 9 j(5).a.isbn(10) = 11 PRINT j(5).books(99).isbn[2] + j(5).a.isbn(10)
TYPE book bkname AS STRING * 100 isbn(1000) AS INTEGER END TYPE TYPE address books(50) AS book age AS INTEGER name AS STRING * 100 END TYPE DIM j(10) AS book PRINT UBOUND(j, 1) $END j(3).nn(99) = 123 j(1).a.isbn(10) = 1000 j(2).nn(1) = j(3).nn(99) + j(1).a.isbn(10)
PRINT UCASE$("kbasic")
DIM i, a = 2, b = 4, c = 8 AS INTEGER i = -a i = +a i = +a + +b + +c i = -a + -b + -c i = +a+b i = -a-b i = -a+-b i = +a-+b i = +a - -b i = a+ +a i = a-+a ' normal human brain? ' someone find this beautiful i = -(-a + -a) - a i = -(a+a) - a ' incredible i = -(-(-a + -a)) - a i = -(-(-(-a + -a))) - a i = -(a -(-a + -a)) - a ' normal human brain? i = -1 i = +1 i = +1 + +2 + +3 i = -1 + -2 + -3 i = +1+2 i = -1-2 i = -1+-2 i = +1-+2 i = +1- -2 i = 1+ +1 i = 1-+1 ' someone finds this beautiful i = -(-1 + -1) - 1 i = -(1+1) - 1 ' incredible i = -(-(-1 + -1)) - 1 i = -(-(-(-1 + -1))) - 1 i = -(1 -(-1 + -1)) - 1
DIM s AS STRING
PRINT VAL("43.3")
Option OldBasic Sub t Const kk = 9 Echo kk : Echo "ßß</html>" End Sub t
CLS
DIM c = ARRAY("abc", 22, 33)
PRINT c(0)
DIM i AS INTEGER
DIM a = 1
a(2) = 99
PRINT "a=" + a
PRINT "a(2)=" + a(2)
DIM s'k(33), s(11), ii
DIM b
b = a
PRINT "b=" + b
FOR i = 1 TO 10
b(i) = a(i)
NEXT
PRINT "b(2)=" + b(2)
' if all field elements should be copied, you have to use a for next loop b(i) = a(i)
'$END
b = c
a = c
PRINT "a(0)=" + a(0)
FOR i = 1 TO 10
s(i) = i
PRINT s(i)
NEXT
s = a
PRINT ISARRAY(s)
DIM t(10)
FOR i = 1 TO 10
t(i) = i
PRINT t(i)
NEXT
CLASS rumba
PUBLIC SUB dance_rumba()
Print "rumba!!!"
END SUB
END CLASS
TYPE book
bkname AS STRING * 100
isbn(1000) AS INTEGER
End Type
Type zoo
e As book
End Type
DIM j(1 TO 10) AS zoo
With j ( 3 )
with .e
. isbn ( 99 ) = 123
end with
End With
print j[3].e.isbn[99]
'end
DIM m AS NEW rumba
With m
.dance_rumba()
End with
OPTION OLDBASIC
CLS
OPEN "LIST" FOR OUTPUT AS #1
DO
INPUT " NAME: ", Name$
INPUT " AGE: ", Age$
WRITE #1, Name$, Age$
INPUT "More entries?"; R$
LOOP WHILE UCASE$(R$) = "Y"
CLOSE #1
'print file on screen
OPEN "LIST" FOR INPUT AS #1
CLS
PRINT "Entries of file:": PRINT
DO WHILE NOT EOF(1)
INPUT #1, Rec1$, Rec2$
PRINT Rec1$, Rec2$
LOOP
CLOSE #1
KILL "LIST"
' ' ' Dear KBasic user! ' ' ' Thank you for trying out KBasic. ' ' If you are new to coding, you should read KBasic's Learning Coding ' for beginners, a group of small lessons on how to use the KBasic ' programming language, located in the 'Help' menu. You might also ' like to try 'The KBasic Book': this book contains detailed information ' about the programming language. ' ' **** ' Enjoy it! * * * ' * **** * ' * *********** * ' * ********* * ' Bernd Noetscher * ******* * ' * * * ** ' * ** ' **** ' ' ' Hit the [start/play button] to run your first KBasic program now ' ' program beginning CLS Print "Hello World!" Print Print Print " / `._ . . _.' \" Print " '.@ = `. \ / .' = @.'" Print " \ @`.@ `. \ / .' @.'@ / " Print " \ @`.@ `. \ / .' @.'@ / " Print " \;`@`.@ `. \ / .' @.'@`;/ " Print " \`.@ `.@ `'.(*).'` @.' @.'/ " Print " \ '=._`. @ :=: @ .'_.=' / " Print " \ @ '.'..'='..'.' @ / " Print " \_@_.==.: = :.==._@_/ " Print " / @ @_.: = :._@ @ \ " Print " /@ _.-' : = : '-._ @\ " Print " /`'@ @ .-': = :'-.@ @`'`\ " Print " \.@_.=` .-: = :-. `=._@./ " Print " \._.-' '.' '-._./ " Print Print "... you just run your first KBasic program!" ' program ending
'color(0,15)
'CLS(15)
' class example
Class being
Constructor being()
Print "being.Constructor!!!!"
End Constructor
Sub cry()
Print "being.cry"
End Sub
End Class
Class body Inherits being
Constructor body()
Print "body.Constructor!!!!"
End Constructor
Sub cry()
Print "body.cry"
End Sub
End Class
Class face Inherits being
Constructor face()
Print "face.Constructor!!!!"
End Constructor
Sub cry()
Print "face.cry"
End Sub
End Class
'Class t
'End Class
Dim l[10] As being
l[3] = New being
l[4] = New face
l[5] = New body
'l[6] = New t
' polymorphism
l[3].cry()
l[4].cry()
l[5].cry()
'For i As Integer = 2 To 100
'Line(0, 0) - (111+i, 333), 10
'Next
'
'Locate 1, 1
' const example Const pi = 3.14159265 Print pi
' dim example Dim i As Integer i = 2 Print i Dim k As String k = "Backfischfest in Worms" Print k
' do...loop while example
Dim b As Boolean = True
Dim i As Integer = 0
Do
Print i
i = i + 1
If i > 12 Then b = False
Loop While b
' do while...loop example Dim b As Boolean = True Dim i As Integer = 0 Do While b If i > 2 Then b = False Print i i = i + 1 Loop
' for next example Dim i As Integer For i = 0 To 11 Print "doing the same thing all time: " + i ' repeated 11times Next
' function example Function divide(dividend As Double, divisor As Double) As Double Return dividend / divisor End Function Print divide(18, 9)
' if then else example Dim itsFunny As Boolean = True If itsFunny Then Print "Laughing :-)" Else Print "...boring!" End If
' print example ' show something on the screen Print "show something on the screen"
' select case example
Dim age As Integer = 24
Select Case age
Case 12
Print "you are young"
Case 24
Print "nearly quarter a century old"
Case 33
Print "just a little bit older"
End Select
' statement example Dim i As Integer ' create variable i = 0 ' set value of variable to 0 i = i + 33 ' increase value of variable Print i ' show variable on screen
' sub example Sub theMusic Print "represents cuba" Print "your hips make a shift..." Print "I'm the one to find you in the mood..." Print "CUBA!" Print "represents cuba" Print "represents cuba" End Sub theMusic() ' first use of sub theMusic() ' 2nd use theMusic() ' 3rd use
' type example Type woman eyes As String mouth As String tongue As String hair As String teeth As String lips As String smile As String End Type Dim nadja As woman nadja.eyes = "so impressive" nadja.mouth = "sweets!" nadja.tongue = "I should better say nothing ;-)" nadja.hair = "brown, short style" nadja.teeth = "nice" nadja.lips = "full of love" nadja.smile = "unbelievable!" CLS Print nadja.eyes Print nadja.mouth Print nadja.tongue Print nadja.hair Print nadja.teeth Print nadja.lips Print nadja.smile
Const globalConst = 1
Const globalConst2 As Integer = 2
Dim globalVar As Integer = 4
Dim globalVar2 As test
globalVar2 = test.Entry
' global scope
Enum test
Entry = 666
Entry2
Security = Entry
securus
secura
securum
End Enum
Type book
bkname As String * 100
isbn(1000) As Integer
End Type
Type address
books(50) As book
age As book
Name[9] As Integer
End Type
Sub globalSub()
Dim localVar = 99
End Sub
' module scope
Module module1
Public Type address2
age As Integer
End Type
Public Type module_type
element AS integer
End Type
Public Enum module_enum
Entry
Entry2
Security = Entry
End Enum
Const moduleConst = 7
Public publicModuleVar As Integer
Private privateModuleVar As Integer
Sub moduleExplicit()
Dim localVar = module1.publicModuleVar
Dim localVar2 = module1.moduleConst
' Dim localVar3 As module1.module_enum ' full type name not allowed after AS
Dim localVar3 As module_enum
localVar3 = module1.module_enum.Entry
'Dim localVar4 As module1.module_type ' full type name not allowed after AS
End Sub
Sub moduleImplicit()
dim localVar = publicModuleVar
dim localVar2 = moduleConst
dim localVar3 as module_enum
localVar3 = module_enum.Entry
dim localVar4 as module_type
End Sub
Sub moduleSubWithDefaultArgument(ko as integer = 6)
dim localVar = ko
End Sub
Sub moduleSubWithOptionalArgument(Optional ko As Integer)
If Not IsMissing(ko) Then
dim localVar = ko
End If
End Sub
Sub moduleSub()
Const localConst = 6
dim n = localConst
End Sub
Sub moduleSubWithArgument(i as integer)
dim localVar = i
End Sub
Sub moduleSubWithArgumentShadowing(i2 as integer)
Dim localVar = i2
Dim i2 = localVar + 99
dim i3 = i2
End Sub
Sub subOverloading ( )
print "sub1"
End Sub
Sub subOverloading ( i as integer = 1)
print "sub2"
End Sub
Function moduleFunction() As String
subOverloading()
subOverloading(88)
return "hello"
End function
function moduleFunctionRecursive(byref i as integer) as integer
if i > 6 then return 1''i
''i = i + 1
return moduleFunctionRecursive(1)''i)
End function
End Module
' class scope
Class Walzer
Public var As integer
End Class
Class Salsa inherits Walzer
public Enum class_enum
Entry
Entry2
Security = Entry
End Enum
public type class_type
element AS integer
End Type
const classConst = 4
public publicInstanceVar as integer
Private privateInstanceVar As Integer
'Protected protectedInstanceVar As Integer
Static Public publicClassVar As Integer' = 8
'dim publicModuleType as module1.module_type
dim publicModuleType2 as module_type
' parent constructor call inside constructor
Sub meExplicit()
dim localVar = Me.publicInstanceVar ' it is the same with Parent
dim localVar2 = Me.publicClassVar
dim localVar3 = Salsa.publicClassVar
dim localVar4 = Salsa.classConst
Dim localVar5 = classConst
'Dim localVar5b = Me.classConst
'
Dim localVar6 As class_enum
localVar6 = Salsa.class_enum.Entry
' Dim localVar7 As Me.class_enum ' full type name not allowed after AS
dim localVar8 as class_type
End Sub
Sub meImplicit()
dim localVar = publicInstanceVar
dim localVar2 = publicClassVar
dim localVar3 = classConst
Dim localVar4 As class_enum
dim localVar5 as class_type
End Sub
Sub classSub()
const localConst = 6
dim n = localConst
End Sub
Sub classSubWithArgument(i as integer)
dim localVar = i
End Sub
function classFunction() as string
return "hello"
End Function
' Static Public Sub test() Throws Walzer
' Throw New Walzer
' End Sub
' Private pvtFname As String
'
' Public Property Nickname As String
'
' Get
' print "Hi"
' End Get
'
' Set ( ByVal Value As String )
' print "Hi"
' End Set
'
' End Property
End Class
CLASS rumba
Public latein AS INTEGER
'Public mySalsa As New Salsa
'Public mySalsa2[10] As Salsa
' Public mySalsa3[] As Salsa
PUBLIC SUB dance_rumba()
Print "rumba!!!"
'print mySalsa.var
End Sub
' default constructor
Constructor rumba ()
print "constructor"
End Constructor
Constructor rumba ( _latein as integer)
Print "constructor2"
latein = _latein
End Constructor
Destructor rumba ( )
print "destructor"
End Destructor
Static Sub myMsgBox(ByRef m As Double)
'' m = m + 1
End Sub
Static Sub myMsgbox2(Optional m As Integer)
If IsMissing(m) Then
'' m = m + 1
Else
Print "do nothing"
End If
End Sub
Static Function monique(ByRef i As Integer, ByVal h As Double, ParamArray b() As Variant) As Integer
For i = LBound(b) To UBound(b)
Print b(i)
Next i
Return i
End Function
static SUB structByReference(byref m AS address)
''m.name[2] = 71
End Sub
' static SUB structByValue(byval m AS address) ' struct passed byval not allowed
' m.name[2] = 71
' End Sub
' Static Function returnStructByVal() as address ' struct returned not allowed
' dim m AS address
' ''m.Name[2] = 71
' return m
' End Sub
' static SUB arrayByRef(byref m[] AS address) ' array arguement not allowed
' m[8].name[2] = 71
' End Sub
' Sub test(ByRef t(8) As Long) ' fixed size array arguement not allowed
' End Sub
' Sub test2(ByVal t(8) As Long) ' fixed size array arguement not allowed
' End Sub
' Static Function returnArrayByRef() as adress[] ' open array returned not allowed
' dim m[8] AS address
' m[1].Name[2] = 71
' return m
' End Sub
' static SUB arrayByRef(byref m[][] AS address)
' m[8][9].name[2] = 71
' End Sub
'
' Static Function returnArrayByRef() as adress[][] ' open array returned not allowed
' dim m[8][6] AS address
' m[1][4].Name[2] = 71
' return m
' End Sub
END CLASS
DIM j(5 TO 10) AS address
''j(3).namer(6) = 123
''j(1).age.isbn(10) = 1000
''j[2].namer[1] = j(3).namer(6) + j(1).age.isbn(10)
'Dim Emp As rumba = New rumba
DIM r AS NEW rumba
r.dance_rumba()
'With r
' .dance_rumba()
'End With
'Print r.latein
'Print r.mySalsa.var
Print globalVar ' accessable from everywhere
Print globalVar2 ' accessable from everywhere
Print globalConst ' accessable from everywhere
publicModuleVar = 99
Print publicModuleVar
Salsa.publicClassVar = 111
Print Salsa.publicClassVar
print moduleConst
DIM m = 1 AS INTEGER
'PRINT rumba.monique( h:=12.2, i:=m )
''Print rumba.monique(m, 12.2, 5, 8, 7)
' TRY
' Salsa.test()
' CATCH (b AS Walzer)
' PRINT "got you!"
' End Catch
'
' Create variable:
DIM variablename AS VARIANT
CLASS ABSTRACT rumba
PUBLIC ABSTRACT SUB dance_rumba()
PRIVATE latein AS INTEGER
PUBLIC englisch AS STRING
PRIVATE CONST kbAccess = 0
CONSTRUCTOR rumba()
DIM p = 77777777
END CONSTRUCTOR
DESTRUCTOR rumba()
DIM a = 3333
END DESTRUCTOR
END CLASS
CLASS jive INHERITS rumba
CONSTRUCTOR jive()
DIM b = 99
END CONSTRUCTOR
DESTRUCTOR jive()
DIM a = 888
END DESTRUCTOR
PUBLIC SUB dance_rumba()
PRINT "rumba!!!"
END SUB
END CLASS
'DIM k AS NEW rumba
DIM m AS NEW jive
m.dance_rumba()
Type a k As Integer m As Double End Type Dim b As a Dim i As Integer Dim k As Integer CLS i = AddressOf(k) Print "&H" + Hex(i) i = AddressOf(b) Print "&H" + Hex(i)
Dim i As Integer i = 99 Print i
Sub ferrari(ByRef pace As Integer) pace = pace + 10 End Sub Dim i As Integer = 50 ferrari(i) Print i ferrari(i) Print i
Sub ferrari(ByVal pace As Integer) pace = pace + 10 ' won't have effect on global var i End Sub Dim i As Integer = 50 ferrari(i) Print i ferrari(i) Print i
Dim k As Double
k = 12.12
Select Case k
Case 12.12
Print "it's the same value"
End Select
CLASS rumba
SUB dance
PRINT "rumba.dance"
END SUB
END CLASS
PUBLIC SUB test() THROWS rumba
THROW NEW rumba
End Sub
TRY
test()
CATCH (b AS rumba)
PRINT "got you!"
END CATCH
DIM s AS STRING s = CHOOSE(1, "un", "deux", "troi") PRINT s
Class Salsa
Static
Print "Static part of class"
End Static
Public Sub test()
Print "test!!!"
End Sub
/*
Private pvtFname As String
Public Property Nickname As String
Get
' return pvtFname
print "Hi"
End Get
Set ( ByVal Value As String )
print "Hi"
'pvtFname = Value
End Set
End Property
Public Property Set MyNumber(ByVal strValue As String)
print "Hi"
' pvtFname = Val(strValue)
End Property
Public Property Get MyNumber() As String
print "Hi"
' MyNumber = pvtFname
End Property
*/
End Class
Class rumba
Private latein As Integer
Public englisch As String
Dim k
'Public mySalsa As New Salsa
Public Sub dance_rumba()
Print "rumba!!!"
'print mySalsa.var
END SUB
' CONSTRUCTOR rumba2()
' PRINT "constructor"
' END CONSTRUCTOR
'
' DESTRUCTOR rumba3()
' PRINT "destructor"
' END DESTRUCTOR
END CLASS
'DIM m AS New rumba
DIM m AS rumba = New rumba
m.dance_rumba()
'Print m.latein
'Print m.mySalsa.var
Sub Namer ( ) Const pi = 3.14 Print pi End Sub CONST a = 123.88 * 2, bb = 6 Const k As Integer = 2 DIM i AS DOUBLE i = bb 'a = i ' would cause a parser error Namer()
CLASS rumba
PRIVATE latein AS INTEGER
PUBLIC englisch AS STRING
Dim k
'PRIVATE CONST kbAccess = 0
PUBLIC SUB dance_rumba()
Print "rumba!!!"
'print mySalsa.var
END SUB
CONSTRUCTOR rumba()
PRINT "constructor"
END CONSTRUCTOR
DESTRUCTOR rumba()
PRINT "destructor"
END DESTRUCTOR
END CLASS
DIM r AS NEW rumba
CLASS rumba
PRIVATE latein AS INTEGER
PUBLIC englisch AS STRING
Dim k
'PRIVATE CONST kbAccess = 0
PUBLIC SUB dance_rumba()
Print "rumba!!!"
'print mySalsa.var
END SUB
CONSTRUCTOR rumba()
PRINT "constructor"
END CONSTRUCTOR
DESTRUCTOR rumba()
PRINT "destructor"
END DESTRUCTOR
END CLASS
DIM r AS NEW rumba
r = NULL
DIM x AS INTEGER x = 1 * x + 10 / 47323 DIM n = 999 AS INTEGER DIM i AS INTEGER i = 3 i = 333333
Dim b As Boolean = True Do While b b = false Loop b = True ' another do loop Do b = false Loop While b
Dim b As Boolean = false If b Then Print "b is true" Else Print "b is false" EndIf
Dim b As Boolean = false If b Then Print "true" ElseIf b = False Then Print "false" Else Print "tr+alse ??" EndIf
Print "statement1" End Print "statement2" ' will never be executed, because 'End' is in the line above
Dim b As Boolean = true If b Then Print "b is true" Else Print "b is false" EndIf
Enum Level Mo= -1 Di = 0 Fr = 1 Sa = 1 + Fr AND 2 End Enum Enum test Entry Entry2 Security = Entry End Enum Dim i As test i = test.Entry Print i 'Debug. Print 3 + Level.Mo Print test.Entry Print test.Security
Sub doingSomething
Print "did something"
Exit Sub
Print "end of sub"
End Sub
Function doingSomething2() As Variant
Print "did something"
Exit Function
Print "end of function"
End Function
For i As Integer = 1 To 11
Exit For
Print "xyz"
Next
doingSomething()
doingSomething2()
CLASS rumba
SUB dance
PRINT "rumba.dance"
END SUB
END CLASS
PUBLIC SUB test() THROWS rumba
THROW NEW rumba
End Sub
TRY
test()
CATCH (b AS rumba)
PRINT "got you!"
FINALLY
PRINT "will be always executed, whatever happend"
END CATCH
' example - counting in French Dim i As Integer For i = 1 To 10 If i = 1 Then Print "un" If i = 2 Then Print "deux" If i = 3 Then Print "trois" If i = 4 Then Print "quatre" If i = 5 Then Print "cinq" If i = 6 Then Print "six" If i = 7 Then Print "sept" If i = 8 Then Print "huit" If i = 9 Then Print "neuf" If i = 10 Then Print "dix" If i = 5 Then Iterate For Print " next step " Next
Dim c As New Collection
Dim f As New Form
Dim k As Form
'Dim a As Collection = c
k = Null
c.Add(f, "Form1")
c.Add(f, "Form2")
'Print c.Len()
'Print a.Len()
f = f
'k = c("Form1")
k = c(0)
'c.Remove(0)
k = f
'k.Width= 100
'k.Height = 100
'k.Open
For Each k In c
'k = k
print "z"
Next
Function returnSomethingReallyImportMaybeItsAPassword() As String return "login:bernd, passw:245tg" End Function Print returnSomethingReallyImportMaybeItsAPassword()
DIM b AS INTEGER DIM n AS INTEGER b = 45 GOTO bernd b = 99999 bernd: n = 0 ok: n = n + 1 IF n < 5 THEN GOTO ok
DIM j AS INTEGER = 6 DIM i = 4 AS INTEGER DIM n AS INTEGER IF i = 5 THEN n = 66: n = 55 IF i = 4 THEN n = 77: n = 99 'IF i = 4 THEN : n = 4: n = 10 IF i = 4 THEN n = 22 ELSE n = 55 IF i = 5 THEN n = 33 ELSE IF i = 6 THEN n = 33 ELSE n = 99 IF i <> 1 THEN n = 11111 ELSE n = 33333 '$END IF i <> 1 THEN: n = 11111: ENDIF IF i <> 1 THEN n = 11111 : n = 9 ELSEIF i = 2 * 10 THEN n = 22222 ELSE n = 33333 ENDIF IF i <> 1 THEN n = 11111 END IF $END DIM nReturn AS INTEGER nReturn = (-.5) + (-1) + 99 nReturn = (-(+5 - -1) * -2) * 4 / -4 END DIM x,y AS INTEGER ' must be MSC_ID_INTEGER DIM integer__% ' must be MSC_ID_DOUBLE DIM double__# ' must be MSC_ID_SINGLE DIM single__! ' must be MSC_ID_STRING DIM string__$ ' must be MSC_ID_LONG DIM long__& long__& = 12 double__& = 10 / 3 double__& = 10 \ 3 ' integer division! 'single__! = 10.10! double__# = 22.22# string__$ = "kbasic" integer__% = 123434% 'long__& = 2134& END x=1 y=1 y = x AND y END DIM b AS BOOLEAN DIM t AS SINGLE DIM ll AS LONG DIM aa AS LONG DIM b1=1, b2=0 AS BOOLEAN ll = 234 aa = 99 t = 2.8 IF b1 OR b2 AND ll THEN 'IF ll = 234 AND t = 2.8 THEN aa = 123456 ENDIF b = false END DIM n AS INTEGER DIM i AS INTEGER DIM x AS INTEGER i = &O4 IF i <> 1 THEN n = 11111 ELSE n = 33333 print i IF i = 1 THEN n = 11111 ELSEIF i = 2 THEN n = 22222 ELSEIF i = 3 THEN n = 33333 ELSEIF i = 4 THEN n = 44444 ELSE n = 55555 ENDIF END i = 20 i = 20 IF i <> 1 THEN n = 11111 ELSEIF i = 2 * 10 THEN n = 22222 ELSE n = 33333 ENDIF 'FOR i = 1 TO 10 ' n = 123 'NEXT DIM bRet AS BOOLEAN DIM b AS BOOLEAN DIM nReturn AS INTEGER 'GOTO ok bRet = TRUE 'ok: b = 45 'nReturn = 5 - 1 * (2 * 4) * 7 / 8 nReturn = ((+5 - -1) * -2) * 4 / -4 + 9 * 88 - 88 'nReturn = (-.5) + (-1) + 6 'nReturn = 4 + 5 * 6 4000 n = +10 * +8 8000 n = TRUE 9000 nReturn = 4 + 5 MOD 2 ' IF i = 10 THEN ' PRINT i ' ENDIF
DIM s AS STRING DIM i AS INTEGER i = 1 s = IIF (i = 1, "Der Menschen Hörigkeit", "Casanova") PRINT s
Class generation1 Public gen1 End Class Class generation2 Inherits generation1 Static Public gen2 End Class Class generation3 Inherits generation2 Public gen3 End Class Class generation4 Inherits generation3 Public gen4 End Class Class generation5 Inherits generation4 Public gen5 End Class CLS Dim g As New generation5 g.gen1 = 1 generation5.gen2 = 2 g.gen3 = 3 g.gen4 = 4 g.gen5 = 5 Print g.gen1 Print g.gen2 Print g.gen3 Print g.gen4 Print g.gen5
' 1st use of is DIM m AS CommandButton IF TYPEOF m IS CommandButton THEN PRINT "CommandButton" ENDIF ' 2nd use of is DIM k AS NEW OBJECT DIM a DIM b a = k b = k PRINT a = b PRINT a IS b
CLS
DIM n = 0 AS INTEGER
DIM b = FALSE AS BOOLEAN
/*
DO
n = n + 1
PRINT "1"
IF n = 4 THEN b = TRUE ELSE ITERATE DO
PRINT "something"
LOOP UNTIL b = TRUE
*/
/*
DO WHILE b = FALSE
n = n + 1
PRINT "1"
IF n = 4 THEN b = TRUE ELSE ITERATE DO
PRINT "something"
LOOP
*/
/*
DO UNTIL b = TRUE
n = n + 1
PRINT "1"
IF n = 4 THEN b = TRUE ELSE ITERATE DO
PRINT "something"
LOOP
*/
DO
n = n + 1
PRINT "1"
IF n = 4 THEN b = TRUE ELSE ITERATE DO
PRINT "something"
LOOP WHILE b = FALSE
$END
CLS
DIM n AS INTEGER
DIM i# ' test something
DIM y#
FOR i# = 1 TO 2 STEP 1
FOR y# = 1 TO 4
n = 99
PRINT "y = " + y
IF y# = 2 THEN ITERATE FOR
PRINT "n = " + n
IF y# = 5 THEN EXIT FOR
NEXT
NEXT
n = 100
Option KBasic Print "kbasic syntax and keywords activated"
TYPE book bkname AS STRING * 100 isbn(1000) AS INTEGER END TYPE TYPE address books(50) AS book age AS INTEGER NAME2 AS STRING * 100 END TYPE DIM j(5 TO 10) AS book PRINT LBOUND(j, 1) $END j(3).nn(99) = 123 j(1).a.isbn(10) = 1000 j(2).nn(1) = j(3).nn(99) + j(1).a.isbn(10)
' do...loop while example Dim b As Boolean = True Dim i As Integer = 0 Do If i > 12 Then b = False Print i i = i + 1 Loop While b ' do while...loop example b = True i = 0 Do While b If i > 12 Then b = False Print i i = i + 1 Loop
Class economy
Sub transfer()
Print "economy: transfer"
End Sub
End Class
Class money Inherits economy
Sub transfer()
parent.transfer()
End Sub
Sub stopTransfer()
Print "stopTransfer"
End Sub
End Class
Class bill Inherits economy
Dim m As money
Sub transfer()
Print "bill: transfer"
End Sub
Sub payBill()
Me.transfer()
m = New money
m.transfer()
End Sub
Sub ignoreBill()
Print "ignoreBill"
End Sub
End Class
Dim b As New bill
'b.transfer()
b.payBill()
DIM txt AS STRING, replacement AS STRING, originaltxt AS STRING
txt = "The dog bites the cat"
MID(txt, 5) = "cat"
PRINT txt
MID(txt, 19) = "dog"
PRINT txt
MID(txt, 5) = "text is too long for the string"
PRINT txt
$END
replacement = "The power of KBasic"
originaltxt = "*********************"
FOR i = 1 to LEN(replacement)
MID(originaltxt, 2, i) = replacement
PRINT originaltxt
NEXT i
MODULE einkauf PUBLIC m AS INTEGER END MODULE MODULE verkauf DIM m2 AS INTEGER END MODULE m = 123 m2 = 555 Print m Print m2 Print einkauf.m Print verkauf.m2
Dim o As New Object o = Null
' for next example Dim i As Integer For i = 0 To 11 Print "doing the same thing all time: " + i Next
Class test Dim m As Integer End Class Dim t As test t = New test() t.m = 333 t = Nothing ' it is the same like null t = Null ' it is the same like nothing
' There are several OPTION expressions defined in KBasic (option range, option base, option explicit, option compare...) OPTION OLDBASIC OPTION EXPLICIT OFF ' turn off 'OPTION BASE 0 ' 1 standard 1 i$ = "Heyoi" ' turn runtime over/underflow check on 'OPTION RANGE ON ' let's do an overflow! DIM a AS INTEGER ' 32-bit integer a = 2147483647 ' the maximum positive signed integer a = a + 1 ' this is overflow... a is now -2147483648
Class economy
Sub transfer()
Print "economy.transfer"
End Sub
End Class
Class money Inherits economy
Sub transfer()
parent.transfer()
End Sub
Sub stopTransfer()
Print "money.stopTransfer"
End Sub
End Class
Class bill Inherits economy
Dim m As money
Sub transfer()
Print "bill.transfer"
End Sub
Sub payBill()
Me.transfer()
m = New money
m.transfer()
End Sub
Sub ignoreBill()
Print "bill.ignoreBill"
End Sub
End Class
Dim b As New bill
b.payBill()
Sub te
Dim i[10] As Integer
i[0] = 99
i[1] = 88
i[2] = 77
i[3] = 66
i[4] = 55
i[5] = 44
ReDim Preserve i[20]
Print i[0]
End Sub
te()
Class movies
Private sMovieName As String
Sub printName
print sMovieName
End Sub
Constructor movies(s As String)
sMovieName = s
End Constructor
End Class
Dim m As New movies("final fantasy")
m.printName()
' Print m.sMovieName ' NOT accessable, because it is private
CLASS snowBerries
Private MonthNum As Integer
Property Month2() As Integer
GET
CONST j = TRUE
Return MonthNum
END GET
SET(Value AS INTEGER)
CONST k = TRUE
If Value < 1 Or Value > 12 Then
' Error processing for invalid value.
Else
MonthNum = Value
End If
End Set
End Property ' Month
END CLASS
DIM m AS NEW snowBerries
m.Month2 = 10
PRINT m.Month2
Class movies
Protected sMovieName As String
/*
Constructor movies(ByRef s As String)
End Constructor*/
Sub printName
print sMovieName
End Sub
End Class
Class movies2 Inherits movies
Constructor movies2(ByRef s As String)
' Parent.movies()
sMovieName = s
End Constructor
End Class
Dim k As Integer = 9
Dim m As New movies2("final fantasy")
m.printName()
' Print m.sMovieName ' would cause an error
Class movies
Public sMovieName As String
Sub printName
print sMovieName
End Sub
Constructor movies(s As String)
sMovieName = s
End Constructor
End Class
Dim m As New movies("final fantasy")
m.printName()
Print m.sMovieName ' accessable, because it is public
SUB t() DIM s (100) AS STRING s (15) = "You are my angels." REDIM PRESERVE s(15) REDIM PRESERVE s(100) 'REDIM s (1000) 'REDIM s(1) PRINT s(15) 's (1) = "Without your love..." END SUB CLS CALL t()
Rem ' This is yet another test ' c = 3.14 Rem This is another test ' a = 4 Print "The end!" ' another rem here! End Rem definitely the end Dim n As Integer Dim s As String /** this Is a documentation comment */ Print "Hi" Print "Hi" /* this Is mulitline comment */ Print "Hi" Print "Hi again" /* s = "to be or not to be" n = 200 */ REM n = 9999 REM n fkdjfalksjfd 'fdnklfsflsgdngndl dflyjvn REM This is a test of REM ' x = 2 PRINT "Gloria in exelsis deo."
' New style for return: Used for returning the function value. OPTION KBASIC FUNCTION newUsing() RETURN 33.33 END FUNCTION SUB k() RETURN PRINT "hi" END SUB PRINT newUsing() 'k $END OPTION VERYOLDBASIC ' Old style for return: Used for returning to caller (label, lineno, gosub) FOR i% = 1 TO 2 ON i% GOSUB Eins, Zwei NEXT i% END Eins: PRINT "Eins" RETURN Zwei: PRINT "Zwei" RETURN $END
Dim k As Integer
k = 6
Select Case k
Case 6
Print "it's the same value"
End Select
' take a look in the qt examples in /examples/qt
' take a look in the qt examples in /examples/qt
' make all local vars implicitly static SUB myMsgbox(i AS INTEGER) 'STATIC SUB myMsgbox(i AS INTEGER) 'DIM s AS STRING STATIC s AS STRING PRINT "s??? " + s IF i = 0 THEN s = "Je suis Bernd. Tu't appelles comment?" END SUB CLS myMsgbox (0) myMsgbox (1)
Dim i As Integer For i = 1 To 10 Step 2 If i = 1 Then Print "un" If i = 2 Then Print "deux" If i = 3 Then Print "trois" If i = 4 Then Print "quatre" If i = 5 Then Print "cinq" If i = 6 Then Print "six" If i = 7 Then Print "sept" If i = 8 Then Print "huit" If i = 9 Then Print "neuf" If i = 10 Then Print "dix" Next
STOP
Option OldBasic
CLS
Sub nadja(ByRef h As Double)
Print "h = " + (h + 99)
End Sub
Dim m = 1 As Integer
nadja(m)
Print "m = " + m
Dim s As String Dim i As Integer i = 1 s = Switch ( i = 1 , "Der Menschen Hörigkeit" , i = 2 , "Casanova" ) Print s
Dim b As Boolean = true If b Then Print "b is true" Else Print "b is false" EndIf
CLASS rumba
SUB dance
PRINT "rumba.dance"
END SUB
END CLASS
PUBLIC SUB test() THROWS rumba
THROW NEW rumba
End Sub
TRY
test()
CATCH (b AS rumba)
PRINT "got you!"
FINALLY
PRINT "will be always executed, whatever happend"
END CATCH
CLASS rumba
SUB dance
PRINT "rumba.dance"
END SUB
END CLASS
PUBLIC SUB test() THROWS rumba
THROW NEW rumba
End Sub
TRY
test()
CATCH (b AS rumba)
PRINT "got you!"
FINALLY
PRINT "will be always executed, whatever happend"
END CATCH
' for next example Dim i As Integer For i = 0 To 11 Print "doing the same thing all time: " + i Next
CLASS rumba
SUB dance
PRINT "rumba.dance"
END SUB
END CLASS
PUBLIC SUB test() THROWS rumba
THROW NEW rumba
PRINT "hello"
End Sub
TRY
test()
CATCH (b AS rumba)
PRINT "got you!"
END CATCH
TYPE book bkname AS STRING * 100 isbn(1000) AS INTEGER END TYPE TYPE address a(50) AS book age AS INTEGER name AS STRING * 100 nn(100) AS INTEGER END TYPE DIM j(10) AS address j(6).nn(99) = 123 j(6).a.isbn(10) = 1000 j(0).nn(0) = j(6).nn(99) + j(6).a.isbn(10) PRINT j(0).nn(0)
DIM m AS QWidget IF TYPEOF m IS QWidget THEN PRINT "QWidget" ENDIF DIM f AS Form IF TYPEOF f IS Form THEN PRINT "Form" ENDIF
TYPE book bkname AS STRING * 100 isbn(1000) AS INTEGER END TYPE TYPE address books(50) AS book age AS INTEGER name AS STRING * 100 END TYPE DIM j(10, 5) AS book PRINT UBOUND(j, 2)
' do...loop until example Dim b As Boolean = True Dim i As Integer = 0 Do If i > 12 Then b = False Print i i = i + 1 Loop Until b = False
OPTION VERYOLDBASIC ' $DYNAMIC REM $DYNAMIC DIM i(800)
Print "Hi" $End Print "How do you do?"
OPTION VERYOLDBASIC ' $STATIC REM $STATIC DIM i(800)
Option OldBasic Option Base 1 ' set array start index to 1 Option Explicit Off Dim m(10) As Double For i As Integer = 1 To 9 m(i) = 100 + i Next For x = 1 To 9 Print m(x) Next ' Print m(0) ' index out of bounds
Sub callMe Print "you called me" End Sub Call callMe() callMe() ' call is not needed to call a sub or function, just write it without call
CLASS rumba
PRIVATE latein AS INTEGER
PUBLIC englisch AS STRING
PUBLIC SUB dance_rumba()
Print "rumba!!!"
END SUB
PRIVATE SUB CLASS_INITIALIZE() ' constructor, old style name
PRINT "constructor"
END SUB
PRIVATE SUB CLASS_TERMINATE() ' destructor, old style name
PRINT "destructor"
END SUB
END CLASS
DIM r AS NEW rumba
r.dance_rumba()
r = NULL
CLASS rumba
PRIVATE latein AS INTEGER
PUBLIC englisch AS STRING
PUBLIC SUB dance_rumba()
Print "rumba!!!"
END SUB
PRIVATE SUB CLASS_INITIALIZE() ' constructor, old style name
PRINT "constructor"
END SUB
PRIVATE SUB CLASS_TERMINATE() ' destructor, old style name
PRINT "destructor"
END SUB
END CLASS
DIM r AS NEW rumba
r.dance_rumba()
r = NULL
OPTION VERYOLDBASIC COMMON SHARED i AS INTEGER ' common and shared is totally outdated and obsolete
Option OldBasic
Option Compare Text ' used for STRCOMP, default is 'Binary', other is 'Text'
Dim n As Integer
CLS
n = StrComp("Hi", "HI")
Print n ' --> binary false
n = StrComp("Hi", "Hi")
Print n ' --> binary true
DECLARE SUB testSub() SUB testSub() PRINT "testSub" END SUB testSub()
OPTION OLDBASIC DEFBOOL a - b DEFINT c - M DEFLNG B, m, k DEFSNG C DEFDBL D DEFSTR z DEFOBJ o DEFVAR v aSimpleTest = true
OPTION OLDBASIC DEFBYTE a - b DEFINT c - M DEFLNG B, m, k DEFSNG C DEFDBL D DEFSTR z DEFOBJ o DEFVAR v aSimpleTest = 2
OPTION OLDBASIC DEFBOOL a - b DEFINT c - M DEFLNG B, m, k DEFSNG C DEFDBL D DEFSTR z DEFOBJ o DEFVAR v aSimpleTest = true
OPTION OLDBASIC DEFBOOL a - b DEFINT c - M DEFLNG B, m, k DEFSNG C DEFDBL D DEFSTR z DEFOBJ o DEFVAR v aSimpleTest = true
OPTION OLDBASIC DEFBOOL a - b DEFINT c - M DEFLNG B, m, k DEFSNG C DEFDBL D DEFSTR z DEFOBJ o DEFVAR v aSimpleTest = true
OPTION OLDBASIC DEFBOOL a - b DEFINT c - M DEFLNG B, m, k DEFSNG C DEFDBL D DEFSTR z DEFOBJ o DEFVAR v aSimpleTest = true
OPTION OLDBASIC DEFBOOL a - b DEFINT c - M DEFLNG B, m, k DEFSNG C DEFDBL D DEFSTR z DEFOBJ o DEFVAR v aSimpleTest = true
OPTION OLDBASIC DEFBOOL a - b DEFINT c - M DEFLNG B, m, k DEFSNG C DEFDBL D DEFSTR z DEFOBJ o DEFVAR v aSimpleTest = true
Dim v As Variant v = Empty Print 1 + 2 '"variable is empty?" + IsEmpty(v)
SUB tester()
' DIM b(1000) AS DOUBLE
DIM b(1000) AS STRING
b[33] = "33"
PRINT b[33]
ERASE b
' PRINT b[33]
END SUB
CLS
'TYPE o
' s AS STRING * 100
'END TYPE
'
'DIM oo AS o
'
'oo.s = "33"
'
'ERASE oo
'
'PRINT LEN(oo.s)
'
'END
'
'
'tester
'END
'
'DIM a(1000) AS DOUBLE
DIM a(1000) AS VARIANT
a[33] = "33"
PRINT a[33]
ERASE a
PRINT ISEMPTY(a[33])
tester
Option OldBasic Option Explicit Off ' variables are now created on demand without 'dim' v = 12 i = "GOOOOOOOOOOOOAAAAAAAAAAAAAALLLLLL!!!!!" k = 122.34 b = True
Option OldBasic Global a As Integer ' global is obsolete, use 'Public' instead a = 12
OPTION VERYOLDBASIC
FOR i% = 1 TO 20
GOSUB square
NEXT i%
END
square:
PRINT i% * i%
RETURN
Dim array1(1 To 5) As Integer, array2, Test1 array2 = Array(1, 2, 3) Test1 = IsArray(array1) ' returns True. Print Test1 Test1 = IsArray(array2) ' returns True. Print Test1
DIM v AS VARIANT PRINT ISEMPTY(v)
Function Benutzerfunktion() 'Return 0 Return CVERR(23) End Function Dim result, Test1 result = Benutzerfunktion() Test1 = IsError(result) ' return true.
Option OldBasic Dim result result = doubleit() ' returns 0. result = doubleit(2) ' returns 4. Function doubleit(Optional ByVal A) If IsMissing(A) Then ' if no argument, then return 0 doubleit = 0 Else ' if argument, then return double value doubleit = A * 2 End If End Function
DIM v AS VARIANT v = NULL 'v = 99 PRINT ISNULL(v)
PRINT ISNUMERIC(67)
DIM m AS OBJECT PRINT ISOBJECT(m)
Option OldBasic Dim i As Integer Let i = 12 ' let is obsolete i = 12 ' leave out let it is just the same
CLS
DIM i
'i = "aab" LIKE "aab"
'
'PRINT i
'END
'PRINT "abcdfgcdefg" LIKE "" ' False
'PRINT "abcg" LIKE "a*g" ' True
'PRINT "abcdefcdefg" LIKE "a*cde*g" ' True
'Print "abcdefgcdefg" Like "a*cd*cd*g" ' True
'Print "abcdefgcdefg" Like "a*cd*cd*g" ' True
'Print "00aa" Like "####" ' False
'Print "00aa" Like "????" ' True
'PRINT "00aa" LIKE "##??" ' True
'PRINT "00aa" LIKE "*##*" ' True
'PRINT "hk" LIKE "hk*" ' True
'PRINT "00aa" LIKE "*[1-9]*" ' True
'PRINT "*?x]" LIKE "[*?a-z]]"
'PRINT "l0" LIKE "[!0-9a-z]" ' True
'PRINT "" LIKE "[]"
PRINT "-*?0x-" LIKE "[-*?0-9a-z-]"
OPTION OLDBASIC PRINT 1 LSET test$ = "kkkk"
Class test Dim m As Integer End Class Dim t As test t = New test() t = Nothing ' it is the same like null t = Null ' it is the same like nothing
Option OldBasic Option Explicit Off v = "variant" i = 12
Option OldBasic Print "oldbasic syntax and keywords activated"
OPTION VERYOLDBASIC CLS DIM i% i% = 1 i% = 2 ON i% GOTO one, two myEnd: PRINT "myEnd" END one: PRINT "one" GOTO myEnd two: PRINT "two" GOTO myEnd
Sub jump(meter As Integer, Optional high As Integer)
If Not IsMissing(high) Then
Print "high jump"
Else
print "normal jump"
End If
End Sub
jump(12)
jump(12, 33)
Function monique(ByRef i As Integer, ByVal h As Double, ParamArray a() As Variant) As Integer
For i = LBound(a) To UBound(a)
Print a(i)
Next i
return i
End Function
CLS
Dim m = 1 As Integer
Print monique(m, 12.2, 1, 2, 3)
Print "---"
Print monique(h := 12.2, i := m)
Print "---"
Print monique(m, 12.2)
Print "---"
Print monique(1, 9)
Print "---"
' WARNING! OPTION RANGE IS NOT SUPPORTED. Overflow check is always disabled. /* ' turn runtime over/underflow check on 'OPTION RANGE ON ' let's do an overflow! DIM a AS INTEGER ' 32-bit integer a = 2147483647 ' the maximum positive signed integer a = a + 1 ' this is overflow... a is now -2147483648 */
OPTION VERYOLDBASIC DATA "Salsa" READ a$ DATA 22 READ t% '$END DATA 66, 77 READ t%, txt RESTORE '$END READ a$, txt DATA 55, 99 READ t%, txt READ t%, txt
OPTION VERYOLDBASIC DATA "Salsa" READ a$ DATA 22 READ t% '$END DATA 66, 77 READ t%, txt RESTORE '$END READ a$, txt DATA 55, 99 READ t%, txt READ t%, txt
SUB myTest () ON ERROR GOTO err1 DIM g = 0 DIM k = 1 / g g = 99 EXIT SUB err1: IF ERROR = 11 THEN g = 1 ' PRINT ERL ' PRINT ERR RESUME NEXT ' g = 88 ENDIF 'PRINT "error" END SUB myTest ()
OPTION VERYOLDBASIC
TYPE j
k AS STRING * 40
END TYPE
CLS
DIM jj AS j
RSET jj.k = "abcd"
PRINT jj.k
PRINT "123456789 123456789 123456789 123456789 123456789 123456789 123456789 "
Dim i As Object Set i = Nothing ' set is obsolete, just leave it out i = nothing
OPTION VERYOLDBASIC COMMON SHARED i AS INTEGER ' common and shared is totally outdated and obsolete
SYSTEM
OPTION VERYOLDBASIC
ON TIMER(1) GOSUB Update
TIMER ON
CLS
PRINT "Time: "; TIME$
t = TIMER
WHILE k < 10
k = TIMER - t
WEND
END
Update:
LOCATE 1, 8: PRINT TIME$
RETURN
Option VeryOldBasic Print "veryoldbasic syntax and keywords activated"
Dim b As Boolean = True While b Print "looping endlessly?" b = false Wend
Dim b As Boolean = True While b Print "looping endlessly?" b = false End While
TYPE book
bkname AS STRING * 100
isbn(1000) AS INTEGER
END TYPE
TYPE zoo
e AS book
END TYPE
DIM j(1 TO 10) AS zoo
WITH j(3)
.e.bkname = "Frankfurter Zoo"
WITH .e
. isbn ( 99 ) = 333
END WITH
END WITH
PRINT j(3).e.bkname
PRINT j(3).e.isbn(99)
END
CLASS rumba
PUBLIC SUB dance_rumba()
PRINT "rumba!!!"
WITH ME
.test()
END WITH
END SUB
PRIVATE SUB test()
PRINT "test"
END SUB
END CLASS
DIM m AS NEW rumba
WITH m
.dance_rumba()
/*jjj*/ ' .dance_rumba()
' .dance_rumba() :.dance_rumba()
END WITH
Application.OpenModule("")
Dim k As New Bytearray
k.Add("jul", 33)
k.Set("hello", 2)
Dim n As String
n = k.Get(2)
Print n
'Class myCollection Inherits Collection
'
' Function Len() As Integer ' override the original method
' Print "len"
'
' Return Parent.Len
'
' End Function
'End Class
Dim c As Collection
Dim k As New Form
'Dim j As New myCollection
'j.Add(k, "Test")
'Print j.Len
Application.Name = "Hi"
Print Application.Name
c = Application.Forms
c.Add(k, "test")
c.Add(k, "test2")
k = c("test")
k = Application.Forms("test")
For Each k In Application.Forms
Print "z"
Next
/*
For Each k In c
Print "z"
Next
*/
$End
Dim c As New Collection
Dim f As New Form
Dim k As Form
'Dim a As Collection = c
k = Null
c.Add(f, "Form1")
c.Add(f, "Form2")
'Print c.Len()
'Print a.Len()
f = f
'k = c("Form1")
k = c(0)
'c.Remove(0)
k = f
'k.Width= 100
'k.Height = 100
'k.Open
For Each k In c
'k = k
print "z"
Next
Print Math.Abs(-1)
CLS
Dim k As String = "What a nice day!"
Print k.Len()
Print Abs(4)
Dim s$ = "Bernd Noetscher's KBasic"
Print s$.InStr(1, "KBasic")
Dim d = "43.8".Val()
Print d
Print "Bernd".Asc()
Dim src As String
src = "What a nice day"
Print src.Left$(4)
Print "I'm living in Germany".RIGHT$(7)
Print "KBASIC".LCase()
Print "kbasic".UCase()
Print " bedazzeled ".Trim$()
Print RTrim(" bedazzeled "), "]"
Print " bedazzeled ".LTrim$()
Dim text$ = "The dog bites the cat"
text$ = text$.MID$(10, 1)
PRINT text$
Dim Text1 = "ABCD" : Dim Text2 = "abcd"
Print Text1.StrComp(Text2, 1) ' result:0.
Dim x As String, y As String
x = "This is a string"
y = "s"
Print x.InStRev(y)
'
Dim g = "Das ist alles was wir brauchen. Fang nochmal von vorne an." As String
Dim pattern As String = "vorne"
Dim replaceBy As String = "hinten"
Print g.Replace(pattern, replaceBy)
Dim o = "Mondscheinsonate von Beethoven" As String
Print o.StrReverse() ' --> nevohteeB nov etanosniehcsdnoM
Dim b As Boolean
Dim i As Integer
b = True AndAlso True
If True AndAlso True Then
Print "AndAlso: then"
Else
Print "AndAlso: else"
EndIf
If False OrElse False Then
Print "OrElse: then"
Else
Print "OrElse: else"
EndIf
'i = 1 Shl 4
'i = 1 Shr 4
'Inc(i)
'Dec(i)
'i += 5
'i -= 7
'i /= 8
'i *= 7
'i |= 7
'i &= 8
'i = 1 BITAND 5
'i = 1 BITOR 5
'i = 1 BITXOR 5
'i = 1 BITNOT 5
i = i + 1
i = i - 1
i = i * 1
i = i / 1
i = i Mod 1
i = i = 1
i = i <> 1
i = i <= 5
i = i > 5
i = i < 5
i = i And 5
i = 1 Or 2
i = Not True
i = 2 ^ 8
Print "i: " & i
i = 1 Xor 4
i = 9 \ 6
i = i Eqv 2
i = i Imp 5
ENUM dddddddddd
dd
END ENUM
TYPE ddfddf
d AS BYTE
END TYPE
PRIVATE SUB t()
END SUB
FUNCTION lg
END FUNCTION
SUB myMsgbox(BYREF m AS DOUBLE)
'SUB myMsgbox(OPTIONAL m AS INTEGER)
'SUB myMsgbox(a AS STRING, m AS INTEGER)
m = m + 1
'DIM w AS INTEGER
'w = m
'IF m < 102 THEN myMsgbox(m)
EXIT SUB
'DIM s AS STRING
's = a
End Sub
Sub test ()
Dim j As Byte
Dim i As Integer
i = 12
' Catch ( Exception )
' print "catched"
' Finally
' print "done"
End Sub
SUB openWindow()
DIM i AS INTEGER
i = 10
END SUB
'sName = "Follow the white rabbit! Neo."
'openWindow()
DIM b AS DOUBLE
b = 100
CONST test = 23
myMsgbox (b)
'msgbox (sName, 1)
PRINT b
'sName = "Ende"
'msgbox ("Lummerland")
Sub test () Dim i As Integer i = 12 Print "i = " + i End Sub test()
CLS
Sub nadja(b As Variant)
Dim i As Integer
For i = LBound(b) To UBound(b)
Print "b(" + i + ") = " + b(i)
Next i
b[7] = 7
End Sub
Dim k(10) As Variant
k[1] = 1
nadja(k)
Print k[7]
CLS
Sub nadja(ByRef z As Integer, ByVal h As Double, Optional j As Integer, ParamArray b() As Variant)
Print "z = " + z
Print "h = " + h
If Not IsMissing(j) Then
Print "j = " + j
End If
Dim i As Integer
For i = LBound(b) To UBound(b)
Print "b(" + i + ") = " + b(i)
Next i
End Sub
Dim m = 1 As Integer
'nadja(j := 888, h := 12.2, z := m)
'nadja(m, 12.2)
nadja(m, 12.2, 1, 2, 3, 4, 5, 6)
CLS
Sub nadja(b() As Variant)
Dim i As Integer
For i = LBound(b) To UBound(b)
Print "b(" + i + ") = " + b(i)
Next i
b[7] = 7
End Sub
Dim k(22)
k[1] = 1
nadja(k)
Print k[7]
CLS Dim n(8) As Long ' fixed size array arguement not allowed Sub test(byref t() As Long) Print t(8) t(8) = 88 End Sub Print "--" n(8) = 99 test(n) Print "-- end --" Print n(8)
CLS
Const n = 99
Sub test(ByRef t As Long)
' Dim i As Integer
' i = t
' Print i
Dim o As Long
o = t
Print t
t = 8
End Sub
'Print n
Print "--"
'test(9)
test(n)
Print "-- end --"
Print n
Type type1
e1 As Integer
e2[80] As String * 50
End Type
CLS
Dim n = 8 As Long
Sub test(ByRef t As Long = 99)
Print "t = " + t
End Sub
'Print n
Print "--"
test()
test(n)
'test(n + 1)
Print "-- end --"
CLS
Dim n = 99 As Long
Sub test(ByRef t As Long)
' Dim i As Integer
' i = t
' Print i
Dim o As Long
o = t
Print t
t = 8
End Sub
'Print n
Print "--"
'test(9)
test(n)
Print "-- end --"
Print n
CLS
Dim n = 0 As Long
Sub test(ByRef t As Long)
Print t
If t < 4 Then
t = t + 1
test(t)
End If
End Sub
'Print n
Print "--"
test(n + 1)
Print "-- end --"
Print n
CLS
Dim n = 1 As Integer
Sub test(ByRef t As Integer)
Print t
If t < 4 Then
t = t + 1
test(t)
End If
End Sub
'Print n
Print "--"
test(n)
Print "-- end --"
Print n
CLS
Dim n = 1 As Long
Sub test(ByRef t As Integer) ' different type
Print t
If t < 4 Then
t = t + 1
test(t)
End If
End Sub
'Print n
Print "--"
test(n)
Print "-- end --"
Print n
CLS
Dim n = 0 As Long
Sub test(ByRef t As Long)
Print t
Dim t = 4 ' shadows arguement t
If t < 4 Then
t = t + 1
test(t)
End If
End Sub
'Print n
Print "--"
test(n + 1)
Print "-- end --"
Print n
Type type1
e1 As Integer
e2[80] As String * 100
End Type
CLS
'Dim n = 99 As Long
Sub test(ByRef t As type1)
' Dim i As Integer
' i = t
' Print i
Dim o As type1
o.e1 = 111
'o.e1 = t
o.e2[0] = t.e2[0] '"don't let me be misunderstood"
Print "?" + o.e2[0]
'Print o.e2[0]
't = 8
' t.e2[0] = "rrr"
o.e2[0] = "rrr"
t = o
'Print t
End Sub
Dim k As type1
k.e2[0] = "hello"
'Print n
'test(9)
Print "--"
test(k)
Print "-- end --"
Print "!" + k.e2[0]
Print "(" + k.e1
'Print n
Type t i As Integer m As Double End Type Sub kk() Dim l As t l.i = 9 l.m = 12 hh (l.m) Print l.m End Sub Sub hh(ByRef d As Double) d = 99 End Sub kk
Type type1 e1 As Integer e2[80] As String * 100 e3[20] As Double End Type CLS Sub test(ByRef t As String) t = "99999" End Sub 'Sub test2(ByRef t As Double) ' ' t = 99999 ' 'End Sub Dim k As type1 k.e2[0] = "hello" 'k.e3[0] = 1111 Print "--" Print k.e2[0] 'Print k.e3[0] test(k.e2[0]) 'test2(k.e3[0]) Print "-- end --" Print k.e2[0] 'Print k.e3[0]
CLS Dim n = 8 As Long Sub test(ByVal t As Long = 99) Print "t = " + t End Sub 'Print n Print "--" test() test(n) 'test(n + 1) Print "-- end --"
CLS
Dim n = 99 As Long
Sub test(ByVal t As Long)
' Dim i As Integer
' i = t
' Print i
Dim o As Long
o = t
Print t
t = 8
End Sub
'Print n
Print "--"
'test(9)
test(n)
Print "-- end --"
Print n
CLS
Dim n = 0 As Long
Sub test(ByVal t As Long)
Print t
If t < 4 Then
test(t + 1)
End If
End Sub
'Print n
Print "--"
test(n + 1)
Print "-- end --"
Print n
Class tester
Dim i
End Class
Sub tt(z As tester)
Dim a As tester
a = z
Print a.i
End Sub
Dim r As tester
Dim b As tester
r = New tester()
r.i = 99
b = r
tt(b)
CLS
Sub nadja(ByRef z As Integer, ByVal h As Double, Optional j As Integer, ParamArray b() As Variant)
Print "z = " + z
Print "h = " + h
If Not IsMissing(j) Then
Print "j = " + j
End If
Dim i As Integer
For i = LBound(b) To UBound(b)
Print "b(" + i + ") = " + b(i)
Next i
End Sub
Dim m = 1 As Integer
'nadja(j := 888, h := 12.2, z := m)
nadja(m, 12.2)
'nadja(m, 12.2, 1, 2, 3, 4, 5, 6)
CLS
Sub nadja(ByRef z As Integer, ByVal h As Double, Optional j As Integer, ParamArray b() As Variant)
Print "z = " + z
Print "h = " + h
If Not IsMissing(j) Then
Print "j = " + j
End If
Dim i As Integer
For i = LBound(b) To UBound(b)
Print "b(" + i + ") = " + b(i)
Next i
End Sub
Dim m = 1 As Integer
nadja(j := 33, h := 12.2, z := m, b[12] := "12 hello", b[5] := 555, b[7] := "7 ho")
'nadja(m, 12.2, 1, 2, 3, 4, 5, 6)
'nadja(m, 12.2)
'nadja(m, 12.2, /*1, 2, 3,*/ 4, 5, 6)
Type type1
e1 As Integer
e2[80] As String * 100
End Type
CLS
Dim n = 5 As Long
Sub test(Optional ByVal t As Long)
If Not IsMissing(t) Then
Print "t = " + t
Else
Print "t is missing"
End If
'Print "t? = " + t ' produce ismissing error
End Sub
Print "--"
test()
test(n)
'test(n + 1)
Print "-- end --"
CLS
Sub nadja(ParamArray b() As Variant)
Dim i As Integer
For i = LBound(b) To UBound(b)
Print "b(" + i + ") = " + b(i)
Next i
End Sub
nadja(1, 2, 3, 4, 5, 6)
'nadja()
Dim b As Boolean b = True Print b b = False Print b
Dim b As Byte b = 1 b = 99 b = 36 Print b
Dim b As Double b = 12.23 b = 66.66 Print b
Dim b As Integer b = 1 b = 99 b = 36 Print b
Dim b As Long b = 1 b = 99 b = 36 Print b
CLASS rumba
DIM k
PUBLIC SUB dance_rumba()
Print "rumba!!!"
END SUB
END CLASS
DIM m AS NEW rumba
m.dance_rumba()
Dim b As Short b = 1 b = 99 b = 36 Print b
Dim b As Single b = 1 b = 99 b = 36 Print b
Dim s As String s = "This is the longest name of a village in the world somewhere in Wales: Llanfairpwllgwyngyllgogerychwyrndrobwllllantysiliogogogoch" Print s
Dim i As Currency 'i = 23.57@ + 78.8989 'i = 40.13103 'i = 2 * i 'i = 11.11@ 'i = 111 / i 'i = 4 'i = 1 Or i 'i = 4 'Print 4 = i 'i = 4.5@ 'Print 4 ^ i 'Print 4 ^ 4 'Dim k = "price " + 24.95@ 'Print k i = 45.67@ Print i
Dim m As Date
m = #2006-12-12 4:4:44#
Print m
Dim b As Variant b = 1 Print b b = "Slow down you creazy child...When will you realize Vienna waits for you?" Print b b = 36.657 Print b
' IMPORTANT! select 'View/Browser' after running this example
ECHO "<HTML>"
ECHO "<HEAD>"
ECHO "<TITLE>Web pages on the fly</TITLE>"
ECHO "</HEAD>"
ECHO "<BODY>"
ECHO "<TABLE WIDTH=100% BORDER=1>"
ECHO "<TR>"
ECHO "<TD>"
ECHO "Hello World! Dynamically created HTML files...<hr><br>"
FOR i AS INTEGER = 1 TO 50
ECHO "<h" + i + ">"
/*
SELECT CASE i
CASE 10
' ECHO "<b>"
CASE 20
' ECHO "<i>"
CASE 30
' ECHO "<u>"
CASE ELSE
END SELECT*/
ECHO "<font color='#" + i * 2 + i + i + "'>"
ECHO "i=" + i + "<br>"
/*
SELECT CASE i
CASE 10
' ECHO "</b>"
CASE 20
' ECHO "</i>"
CASE 30
' ECHO "</u>"
CASE ELSE
END SELECT */
ECHO "</h" + i + ">"
NEXT
ECHO "</TD>"
ECHO "</TR>"
ECHO "</TABLE>"
ECHO "</BODY>"
ECHO "</HTML>"
/*
ECHO "_
<HTML>_
"<HEAD>"_
"<TITLE>Web pages on the fly</TITLE>"_
"</HEAD>"_
"<BODY>"_
"<TABLE WIDTH=100% BORDER=0>"_
"<TR>"_
"<TD>"_
"Hello World! Dynamically created HTML files..."_
"</TD>"_
"</TR>"_
"</TABLE>"_
"</BODY>"_
"</HTML>"
*/
DIM MX AS SINGLE
DIM value[99] AS SINGLE
RANDOMIZE TIMER
FOR i AS INTEGER = 0 TO 99
value[i] = RND + 1
NEXT
MX = 0.008
FOR i = 1 TO 99 : IF MX < value(i) THEN MX = value(i) ELSE MX = MX : NEXT
DIM l AS INTEGER = 3147483647
END
DIM lVar AS INTEGER 'Long
Dim sVar As String
Dim dVar As Single 'Double
DIM dVar1 AS SINGLE 'Double
lVar = 123456789
dVar1 = lVar * 1.0
PRINT dVar1
END
sVar = .123456789
dVar = VAL(sVar)
CLS
Print lVar
Print sVar
Print dVar
PRINT dVar1
Print
Print 123456789 * 1.0
Dim a as integer
Dim b as integer
'a = InputBox("text", "text1")
print a
b = a/2
print b
CLS
Color(4, 9)
Dim i%, n%, t$, ans
n = 37
Dim guess_title, guess_text, guess_default, guess_
guess_title = "Made By: jWwtL / xJiX"
guess_text = "Please enter a number between 1 and 100"
guess_default = "1"
t = "%"
For i = 0 To 100 Step 10
Print "Loading [" & i, t, "] Complete"
CLS
Next
MsgBox("Welcome to the guessing game! This is just a simple number guessing game.", , "Guess The # | InfamouS Inc., 2006")
Sub GuessTry
guess_ = InputBox(guess_text, guess_title, guess_default)
ans = Val(guess_)
End Sub
Call GuessTry()
Dim b As Boolean = True
While b
If ans > n Then
Print "I am so Sorry, but you need to guess lower."
'Call GuessTry()
GuessTry()
End If
If ans < n Then
Print "I am Sorry, but you need to guess higher."
'Call GuessTry()
GuessTry()
End If
b = False
End While
Print "That is the Correct Answer!"
DIM i As Integer machs: CLS PRINT COLOR 12 PRINT "kb file test" PRINT COLOR 7 FOR i = 1 TO 12 PRINT "MAC mit KB ";i NEXT i INPUT " weiter mit 1, beenden mit 0 ";i IF i = 1 THEN machs END
REM math testing REM Fehler: REM: weder der richtige Wert a oder b wird bei der Rechnung nicht erkannt REM a wird als a(12) und b als b(22) genommen, REM obwohl a(12), b(22) nicht dimensioniert sind Rem Division und Potenzierung gehen nicht /* 1. Problem: DIM a(10), b(10), c, w, r AS INTEGER --> Variablendeklaration funktioniert wie in KBasic definiert, siehe pcode 000906: DIM &H40FD8A0:: r AS INTEGER ( typesize = 4 ) ( allsize = 4 ) 000930: DIM &H40FD8A0:: w AS VARIANT ( typesize = 40 ) ( allsize = 40 ) 000954: DIM &H40FD8A0:: c AS VARIANT ( typesize = 40 ) ( allsize = 40 ) 000978: DIM &H40FD8A0:: b ( 0 TO 10 ) AS VARIANT ( typesize = 40 ) ( allsize = 440 ) 001002: Dim &H40FD8A0 : : a(0 To 10) As Variant(typesize = 40)( */ Dim a, b(22) As Integer, c, g, w, r As Integer DIM d(10), e(10), f(10) AS VARIANT Dim test As String start: CLS PRINT "Math testing 29-03-06 mit a= ";a; Print " und b= "; b(0) : Print Input " b(0) = "; b(0) /* ' 2. Problem: das hier geht nicht: Input " b = ";b Rem vorher manuell eingegeben funktioniert es: --> die Variable b wird als Variant definiert, da kein Typ angegeben wird.Input kein aber keine Varianttypen aktzeptieren.Hier haben Sie einen kleinen Bug entdeckt, der jetzt korrigiert wurde.Der Parser wird eine Fehlermeldung ausgeben, wenn versucht wird Input mit Variant zu kombinieren.Verwenden Sie statt Variant Integer : Dim b As Integer */ /* ' 3. Problem: Warum wird a(12) akzeptiert, obwohl gar nicht dimensioniert und obwohl --- > Variablen, die ohne Datentyp angegeben werden haben automatisch ein ARRAY der Gr öße 11(0 - 10) Hier ist ein kritischer Bug aufgetaucht, obwohl der Parser richtig erkennt, das die Variable ein ARRAY hat, wei ß der Interpreter davon nichts.Habe den Fehler korrigiert.Sie k önnen den Fehler vorerst umgehen, indem Sie immer den Datentyp bei einer Variablen deklaration angeben. z.B. DIM i AS VARIANT statt DIM i */ /* ' 4. Problem: Arrayformation --> funktioniert, war wohl Folgefehler wegen Deklaration der Variablen als Variant */ DIM v(40) AS INTEGER FOR i AS INTEGER = 1 TO 40 v(i) = 23 v(i) = 23.4353 'v(i) = v(i) * i NEXT DIM t(40) FOR i = 1 TO 40 t(i) = 23 NEXT DIM s FOR i = 1 TO 10 s(i) = 23 print t(i) NEXT Rem: keine Arrayformation akzeptierte irgendeine einfache Rechnung wie Rem for i=1 To 100 : sum = sum+a(i) : Next i mit natürlich DIM a(101) und Rem vorhandenen a(1) bis a(100) Daten egal ob Ganzzahlen oder zB 22.5564 /* ' 5. Problem: Berechnung --> funktioniert, war wohl Folgefehler wegen Deklaration der Variablen als Variant */ Dim x=10, y=2.8, z Print PRINT "add, mult, (div, sqr, pot) mit x und y zu z " Print z = x + y : PRINT "z=x+y : "; z Print INPUT "weiter mit ret, nochmal mit r oder g, Ende mit / : "; test IF test = "r" THEN CLS : GOTO start If test = "g" Then CLS : GOTO start IF test = "/" THEN END weiter: PRINT CLS PRINT " zu x = ";x; : Print "und y = ";y: Print z = x + y : PRINT " z=x+y : "; z z = x * y : PRINT " z=x*y : "; z z = x - y : PRINT " z=x-y : "; z z = x*x*x*x-100 : Print " z=x*x*x*x-100 : ";z z = x / y : PRINT " z=x/y : "; z z = x \ y : PRINT " z=x\y : "; z z = x ^ y : PRINT " z=x^y : "; z Print : Input" return ", test End
DIM i AS INTEGER DIM x(10) AS INTEGER DIM w(10) AS long COLOR(,0) CLS SCREEN 12 PRINT "For graph lines changing data..." 'PRINT CINT(12.49), CINT(12.51) w(1) = 17.3 w(2) = 99.99999 w(3) = 122.0987 w(4) = 600.09876543 w(5) = 12.99876 FOR i = 1 TO 5 Input" Wert ";w(i) PRINT " Raw data ";w(i); i NEXT i Sleep 2 REM PRINT For i = 1 TO 5 x(i) = CINT(w(i)) NEXT i FOR i = 1 TO 5 PRINT " CINT und Ausgangsdaten x(i) & w(i) = "; x(i);" ";w(i) NEXT i Sleep 3 COLOR(6,7) PRINT:PRINT:PRINT:PRINT:PRINT:PRINT:PRINT:PRINT:PRINT PRINT PRINT" blau (3): 0,10 bis 0,730 und &HFF00" PRINT" rot (12): 0,0 bis 1010,735" PRINT" violett(5): 0,600 bis 1010,600" PRINT" grün (10): 32,605 - 700,605" LINE(0,602)-(1005,600), 5, , &HFF00 LINE(0,10) - (0,730), 3, , &HFF00 LINE(0, 0) - (1010, 735), 12, , &HFF00 LINE (32, 605)-(701, 605), 10, , &HFF00 LINE(32, 10) - (32, 730), 11, , &HFF00 LINE(100, 100) - (980, 730), 13, , &HFF00 SLEEP 1 Print" parallele Farblinien (return) " FOR i = 2 TO 16 LINE(50, 50 + 10 * i) - (600, 50 + 10 * i), i, , &HFF00 NEXT i LINE(32, 10) - (32, 730), 3, , &HFF00 PRINT "Zusatzlinie weiss :" LINE(107, 2002) - (1010, 20), 7, , &HFF00 PRINT : PRINT " jetzt mit CINT..." Sleep 2 FOR i = 1 TO 5 LINE(300, 10) - (CINT(w(i)), 500), 5, , &HFF00 Next i END
DIM i AS INTEGER DIM H AS STRING DIM SU AS VARIANT DIM PRO AS VARIANT DIM w(10) As VARIANT start: CLS LOCATE 10, 20 Print "Mini-Rechnen mit KBasic; hier Prozentwerte" LOCATE 13, 4 Print "eingegebene Werte : " Print w(1) = 10.09876 w(2) = 23.99876 w(3) = 18.7654 w(4) = w(1) + w(2) + w(3) w(5) = 100 * w(1) / w(4) w(6) = 100 * w(2) / w(4) w(7) = 100 * w(3) / w(4) w(8) = w(5) + w(6) + w(7) Print " Wert 1 ="; w(1); " 2 ="; w(2); " 3 ="; w(3) Print REM Prozentrechnung SU = 0 For i = 1 TO 3 SU = SU + w(i) Next i w(4) = SU Print: Print Print " Summe Wert 1 bis 3 = "; SU Print For i = 1 TO 3 PRO = 100 * w(i) / SU Print ;" ";i;". Prozentwert = "; PRO Next i SU = 0 For i = 5 TO 7 SU = SU + w(i) Next i Print Print " Prozentsumme = "; SU Print Input" weiter mit ret, stop mit (/)";H IF H = "" THEN GOTO start End
REM dim dependant trouble with minimum maximum claculation (REK -> BN)
DIM i AS INTEGER
DIM W(20) AS DOUBLE 'results look different
'DIM W(20) AS SINGLE
DIM MXS AS SINGLE
DIM MNS AS SINGLE
DIM MXD AS DOUBLE
DIM MND AS DOUBLE
DIM MAHD AS DOUBLE
DIM MAHS AS SINGLE
DIM MNHD AS SINGLE
werte:
CLS
W(1) = 11
W(2) = 4
W(3) = 5
W(4) = 0.1
W(5) = 12.0988
MXD = MAX(W(1), W(5))
MXS = MAX(W(1), W(5))
MND = MIN(W(1), W(5))
MNS = MIN(W(1), W(5))
MAHD = 0
FOR i = 1 TO 5
IF W(i) > MAHD THEN MAHD = W(i)
NEXT i
MAHS = 0
FOR i = 1 TO 5
IF W(i) > MAHS THEN MAHS = W(i)
NEXT i
MNHD = 1000
FOR i = 1 TO 5
IF W(i) < MNHD THEN MNHD = W(i)
NEXT i
FOR i = 1 TO 5
PRINT "data used : "; W(i)
NEXT i
PRINT
PRINT"-----------"
PRINT "max double by MAX = "; MXD
PRINT "max single by MAX = "; MXS
PRINT
PRINT "max double by FORIFNEXT = "; MAHD
PRINT "max single by FORIFNEXT = "; MAHS
PRINT
PRINT "min double by MIN = "; MND
PRINT "min single by FORIFNEXT = "; MNHD
END
CLS
DIM Dots(64, 64) AS INTEGER
DIM Repeats AS INTEGER
DIM RowIndex AS INTEGER
DIM ColIndex AS INTEGER
DIM AddressValue AS INTEGER
DIM k AS INTEGER
FOR Repeats = 1 TO 7
FOR RowIndex = 1 TO 4
FOR ColIndex = 1 TO 4
' ColIndex = ColIndex
'
' ITERATE FOR
AddressValue = Dots(RowIndex, ColIndex)
PRINT " " + RowIndex + ")" + ColIndex;
' IF AddressValue > 0 THEN
' PRINT "" + RowIndex + "~" + ColIndex
' END IF
' Dots(RowIndex, ColIndex) = AddressValue + 1
' IF AddressValue = 0 THEN
'
' END IF
'AddressValue = 5
SELECT CASE AddressValue
CASE IS < 8
Dots(RowIndex, ColIndex) = AddressValue + 1
' k = ColIndex
' Dots(RowIndex, ColIndex) = Dots(RowIndex, ColIndex) + 1
' CASE ELSE
' Dots(RowIndex, ColIndex) = 0
END SELECT
AddressValue = 99
AddressValue = AddressValue
NEXT 'ColIndex
NEXT' RowIndex
NEXT ' Repeats
FOR RowIndex = 1 TO 4
FOR ColIndex = 1 TO 4
PRINT "" + RowIndex + "/" + ColIndex + "=" + Dots(RowIndex, ColIndex)
NEXT ColIndex
NEXT RowIndex
43 212 0 841130 2.74536E+07 0 243.6 0 16706 507726 0 311.1 0 466534.7 2.570066E+07 0 411.2 0 63846.21 5870879 0 449.5 0 192.8027 33925.13 0 488.4 0 76526.43 6452184 0 521.7 0 1357.741 172868 0 696.8 0 16718.12 1727171 0 773.8 0 15381.76 1316250 0 897.2 0 356 38063 0 995.8 0 3408.5 304003.5 0 1015.5 0 896 70460 0 1048.3 0 1518 137371 0 1093.9 0 3961.5 298391.5 0 1221 0 1945.5 155990.5 0 1344.2 0 1395 81320 0 1399.5 0 1128 68100 0 1533 0 2212.5 165886.5 0 1548.8 0 69.5 659 0 1579.7 0 79.5 1016.5 0 1586.8 0 146.5 7149.5 0 1650.6 0 642.5 40644.5 0 1678.7 0 251 3510 0 1753.6 0 84 994 0 1765 0 90 1141 0 1792.9 0 984 59755 0 1846.1 0 175 3745 0 1875.1 0 222.5 2449 0 1910.2 0 149.5 1049.5 0 1949.3 0 236.5 884.5 0 1952.1 0 72 568 0 1995.3 0 219.5 1846 0 2019 0 346.5 9107.5 0 2143.9 0 338.5 5376.5 0 2164.1 0 150.5 1466 0 2185.6 0 542 6034 0 2223.2 0 1043 20348 0 2232.8 0 110 536 0 2261.5 0 317.5 3702.5 0 2287.3 0 482.5 7418 0 2337.8 0 82.5 1468.5 0 2352.9 0 102.5 1032 0 2362 0 40.5 650.5 0 ;rek-rc;;IfC;;(Channel 1);G-methanol2;EGTm2.DAT;00053424.EXP;rek-rc;;;;
76 213.1 0 1301339 9.98069E+07 0 245.1 0 1301027 8.1088E+07 0 310.2 0 1212224 6.639252E+07 0 410.3 0 135295.5 1.237894E+07 0 433.9 ;gekuerzt;10_05_06;rek-rc;08/30/00;IfC;meoh3;(Channel 1);G-methanol2;C:\CHROM-CARD FOR TRACE\DATA\NATURALGAS\NLM3.DAT;08/30/00.EXP;rek-rc;;
CLS Dim s As String Dim count As Integer s = "" Do s = Inkey$ count = count + 1 Loop While s = "" Print count; Asc(s) End count = 0 Do s = "0" count = count + 1 Loop While Inkey$ = "" Print count; Asc(s) End
Function test3() As Integer Dim i As Integer i = 1234 Return i End Function CLS Print test3() End
rem Option OldBasic REM Option VeryOldBasic CLS DIM dt AS SINGLE dt = 1.0 / 1000.0 PRINT dt DIM dx AS SINGLE dx = 180.0 / 1000.0 PRINT dx DIM dy AS SINGLE dy = 1.0 / 100000.0 PRINT dy DIM da AS SINGLE da = 1.0 / 10.0 PRINT da DIM db AS SINGLE db = 3.0 / 4.0 PRINT db DIM dz AS SINGLE dz = dt + dx + dy + da + db PRINT dz
REM val_problem.kbasic
REM to Bernd: note, this is only the read-in-part of a larger piece of code
REM which changes one ASCII data portion into a line graphics.#
REM but these parts are cutted off as they are not necessary to show the
REM VAL() problem.
REM two data sets are to be used: YES1.EXP; YES2.EXP and NO1.EXP: NO2.EXP
REM I have hundreds other ones and those copied and treated many ways, but
REM probably not the correct way to make the data VAL changeable.
DIM w(900) AS DOUBLE : REM Rohwerte des ASCII EXPORT files ausser TEXT
DIM W AS STRING : REM Daten-Einlesewert
DIM t(800) AS DOUBLE, b(800) AS DOUBLE, h(800) AS DOUBLE, a(800) AS DOUBLE
REM t=Zeit, b=Breite, h=Höhe, a=Fläche
DIM x(800) AS DOUBLE : REM x = Index
REM from on here other DIMS are used and necessary for the larger code part
DIM SA AS DOUBLE
DIM pt(100) AS DOUBLE : REM pt = Prozent Fläche
DIM MX AS SINGLE
REM max Fläche
DIM MXB AS SINGLE
REM max and min of Breite
DIM MIB AS DOUBLE
REM Korr Faktor X-Achse (t-Werte)
DIM FX AS DOUBLE
REM Korr Faktor Y-Achse (a-Werte)
DIM FY AS DOUBLE
DIM i AS INTEGER
DIM DZ AS INTEGER : REM Datenzahl Gesamt
DIM z AS INTEGER
DIM Q AS INTEGER
DIM L AS INTEGER
DIM X1 AS INTEGER
DIM Y1 AS SINGLE
DIM Y0 AS INTEGER
DIM Y2 AS INTEGER
DIM Y3 AS INTEGER
DIM TXT1 AS STRING : REM Info-Text im file
DIM FN AS STRING : REM file Name
start:
COLOR(, 0)
CLS
LOCATE 5, 10
PRINT "data input from an EXPORT file"
i = 0
LOCATE 30, 10
INPUT "Enter file name. End of program with (/) "; FN
IF FN = "/" THEN END
REM IF RIGHT(FN, 4) <> ".EXP" THEN FN = FN + ".EXP" ### NOT USED here
'OPEN FN FOR INPUT AS #1
OPEN "c:\kbasic14/examples/kbasic/user/YES1.exp" FOR INPUT AS #1
DO WHILE NOT EOF(1)
i = i + 1
LINE INPUT #1, W
w(i) = VAL(TRIM(W))
L = LEN(W)
IF L >= 20 THEN TXT1 = W
IF i MOD 20 = 0 THEN SLEEP
'IF w(i) = 0 THEN
PRINT i, ". Wert eingelesen= "; W; "VAL() umgewandelt = ", w(i)
'ENDIF
PRINT ".",
LOOP
CLOSE #1
PRINT : PRINT "------------------------------------------"
PRINT "file name used = "; FN
INPUT " one data part represents time values; see them: (RET) ", W
CLS
REM Ende einlesen
DZ = i
PRINT
PRINT "Datenzahl = "; DZ
z = 0
FOR i = 2 TO DZ STEP 5
z = z + 1
t(z) = w(i)
PRINT "w(", i, "), tms(", z, ") "; w(i), " time = ", t(z)
NEXT i
PRINT "-----------------------------"
INPUT " restarting program (R) or stop (/) "; W
IF (W = "R" OR W = "r") THEN GOTO start
END
OPTION VERYOLDBASIC
' gibt das 1 mal 1 aus
FOR i% = 1 TO 9
FOR x% = 1 TO 9
n% = i% * x%
PRINT ""+ x% + " * " + i% + "=" + n%
NEXT
NEXT
Type Point3D
Coord(1 To 4) As Single ' Original coordinates.
Trans(1 To 4) As Single ' Translated coordinates.
End Type
Const Xmin = 0
Const Xmax = 1
Const Ymin = 0
Const Ymax = 3
Dim Points(Xmin To Xmax, Ymin To Ymax) As Point3D
Dim T(1 To 4, 1 To 4) As Single
Dim T1(1 To 4, 1 To 4) As Single
Dim T2(1 To 4, 1 To 4) As Single
Dim EyeX As Single
Dim EyeY As Single
Dim EyeZ As Single
Dim Axes(1 To 3) As Point3D
' ********************************************************
' Perform vector-matrix multiplication. Set Rpt = Ppt * A.
' ********************************************************
Sub VectorMatrixMult1(x As Integer, y As Integer)
Dim i As Integer
Dim j As Integer
Dim value As Single
For i = 1 To 4
value = 0
For j = 1 To 4
value = value + Points(x, y).Coord( j ) * T(j, i)
Next j
Points(x, y).Trans(i) = value
Next i
' Renormalize the point.
' Note that value still holds Rpt(4).
Points(x, y).Trans(1) = Points(x, y).Trans(1) / value
Points(x, y).Trans(2) = Points(x, y).Trans(2) / value
Points(x, y).Trans(3) = Points(x, y).Trans(3) / value
Points(x, y).Trans(4) = 1
End Sub
' ********************************************************
' Return the angle with tangent y / x.
' ********************************************************
Function Atan(x As Single, y As Single)
Const PI = 3.14159
Dim angle As Single
If x = 0 Then
angle = 0
Else
angle = Atn(y / x)
If x < 0 Then angle = PI + angle
End If
Return angle
End Function
' ********************************************************
' Make M an identity matrix.
' ********************************************************
Sub MakeIdentity1()
Dim i As Integer
Dim j As Integer
For i = 1 To 4
For j = 1 To 4
If i = j Then
T1(i, j) = 1
Else
T1(i, j) = 0
End If
Next j
Next i
End Sub
Sub MakeIdentity2()
Dim i As Integer
Dim j As Integer
For i = 1 To 4
For j = 1 To 4
If i = j Then
T2(i, j) = 1
Else
T2(i, j) = 0
End If
Next j
Next i
End Sub
' ********************************************************
' Perform matrix-matrix multiplication. Set R = A * B.
' ********************************************************
Sub MatrixMatrixMult()
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim value As Single
For i = 1 To 4
For j = 1 To 4
value = 0
For k = 1 To 4
value = value + T1(i, k) * T2(k, j)
Next k
T(i, j) = value
Next j
Next i
End Sub
' ********************************************************
' Calculate the transformation matrix.
' ********************************************************
Private Sub CalculateTransformation()
Dim r1 As Single
Dim r2 As Single
Dim ctheta As Single
Dim stheta As Single
Dim cphi As Single
Dim sphi As Single
' Rotate around the Z axis so the
' eye lies in the Y-Z plane.
r1 = Sqr(EyeX * EyeX + EyeY * EyeY)
stheta = EyeX / r1
ctheta = EyeY / r1
MakeIdentity1
T1(1, 1) = ctheta
T1(1, 2) = stheta
T1(2, 1) = -stheta
T1(2, 2) = ctheta
' Rotate around the X axis so the
' eye lies in the Z axis.
r2 = Sqr(EyeX * EyeX + EyeY * EyeY + EyeZ * EyeZ)
sphi = -r1 / r2
cphi = -EyeZ / r2
MakeIdentity2
T2(2, 2) = cphi
T2(2, 3) = sphi
T2(3, 2) = -sphi
T2(3, 3) = cphi
' Project along the Z axis. (Actually we do nothing
' here. We just ignore the Z coordinate when drawing.)
' Combine the transformations.
MatrixMatrixMult
End Sub
' ********************************************************
' Draw the surface.
' ********************************************************
Private Sub DrawSurface()
Dim x As Integer
Dim y As Integer
' Calculate the transformation matrix.
CalculateTransformation
' Transform the axes.
For x = 1 To 3
VectorMatrixMult2 x
Next x
' Apply the transformation matrix to the points.
For x = Xmin To Xmax
For y = Ymin To Ymax
VectorMatrixMult1 x, y
Next y
Next x
Dim CurrentX As Integer, CurrentY As Integer
CLS
Print "Rotate with a, d, w or x ESC = exit"
' draw the axes.
For x = 1 To 3
Line(512, 384) - (512 + Axes(x).Trans(1) * 30, 384 + Axes(x).Trans(2) * 30), 4
Next x
Line(512 + Points(0, 0).Trans(1) * 20, 384 + Points(0, 0).Trans(2) * 20) - (512 + Points(0, 1).Trans(1) * 20, 384 + Points(0, 1).Trans(2) * 20), 15
Line(512 + Points(0, 1).Trans(1) * 20, 384 + Points(0, 1).Trans(2) * 20) - (512 + Points(0, 2).Trans(1) * 20, 384 + Points(0, 2).Trans(2) * 20), 15
Line(512 + Points(0, 2).Trans(1) * 20, 384 + Points(0, 2).Trans(2) * 20) - (512 + Points(0, 3).Trans(1) * 20, 384 + Points(0, 3).Trans(2) * 20), 15
Line(512 + Points(0, 3).Trans(1) * 20, 384 + Points(0, 3).Trans(2) * 20) - (512 + Points(0, 0).Trans(1) * 20, 384 + Points(0, 0).Trans(2) * 20), 15
Line(512 + Points(1, 0).Trans(1) * 20, 384 + Points(1, 0).Trans(2) * 20) - (512 + Points(1, 1).Trans(1) * 20, 384 + Points(1, 1).Trans(2) * 20), 10
Line(512 + Points(1, 1).Trans(1) * 20, 384 + Points(1, 1).Trans(2) * 20) - (512 + Points(1, 2).Trans(1) * 20, 384 + Points(1, 2).Trans(2) * 20), 10
Line(512 + Points(1, 2).Trans(1) * 20, 384 + Points(1, 2).Trans(2) * 20) - (512 + Points(1, 3).Trans(1) * 20, 384 + Points(1, 3).Trans(2) * 20), 10
Line(512 + Points(1, 3).Trans(1) * 20, 384 + Points(1, 3).Trans(2) * 20) - (512 + Points(1, 0).Trans(1) * 20, 384 + Points(1, 0).Trans(2) * 20), 10
Line(512 + Points(0, 0).Trans(1) * 20, 384 + Points(0, 0).Trans(2) * 20) - (512 + Points(1, 0).Trans(1) * 20, 384 + Points(1, 0).Trans(2) * 20), 15
Line(512 + Points(0, 1).Trans(1) * 20, 384 + Points(0, 1).Trans(2) * 20) - (512 + Points(1, 1).Trans(1) * 20, 384 + Points(1, 1).Trans(2) * 20), 15
Line(512 + Points(0, 3).Trans(1) * 20, 384 + Points(0, 3).Trans(2) * 20) - (512 + Points(1, 3).Trans(1) * 20, 384 + Points(1, 3).Trans(2) * 20), 15
Line(512 + Points(0, 2).Trans(1) * 20, 384 + Points(0, 2).Trans(2) * 20) - (512 + Points(1, 2).Trans(1) * 20, 384 + Points(1, 2).Trans(2) * 20), 15
/*
' Draw lines parallel to the X axis.
'ForeColor = RGB(0, 0, 0)
For x = Xmin To Xmax
CurrentX = Points(x, Ymin).Trans(1)
CurrentY = Points(x, Ymin).Trans(2)
For y = Ymin + 1 To Ymax
Line(512 + CurrentX * 20, 384 + CurrentY * 20) - (512 + Points(x, y).Trans(1) * 20, 384 + Points(x, y).Trans(2) * 20), 7
Next y
Next x
' Draw lines parallel to the Y axis.
For y = Ymin To Ymax
CurrentX = Points(Xmin, y).Trans(1)
CurrentY = Points(Xmin, y).Trans(2)
For x = Xmin + 1 To Xmax
Line(512 + CurrentX * 20, 384 + CurrentY * 20) - (512 + Points(x, y).Trans(1) * 20, 384 + Points(x, y).Trans(2) * 20), 15
Next x
Next y
*/
End Sub
Private Sub getkey()
Const PI = 3.14159
Const PI2 = -3.14159
Const Dtheta = PI / 16
Const Dphi = PI / 8
Dim theta As Single
Dim phi As Single
Dim r1 As Single
Dim r2 As Single
Dim i$
re:
Do
i$ = inkey
Loop While i$ = ""
theta = Atan(EyeX, EyeY)
r1 = Sqr(EyeX * EyeX + EyeY * EyeY)
r2 = Sqr(EyeX * EyeX + EyeY * EyeY + EyeZ * EyeZ)
phi = Atan(r1, EyeZ)
Select Case i$
Case "a"
theta = theta - Dtheta
Case "w"
phi = phi + Dphi
If phi > PI / 2 Then phi = PI / 2
Case "d"
theta = theta + Dtheta
Case "x"
phi = phi - Dphi
If phi < PI2 / 2 Then phi = PI2 / 2
Case Else
End
End Select
EyeX = r1 * Cos(theta)
EyeY = r1 * Sin(theta)
EyeZ = r2 * Sin(phi)
DrawSurface
goto re
End Sub
Sub VectorMatrixMult2(x As Integer)
Dim i As Integer
Dim j As Integer
Dim value As Single
For i = 1 To 4
value = 0
For j = 1 To 4
value = value + Axes(x).Coord(j) * T(j, i)
Next j
Axes(x).Trans(i) = value
Next i
' Renormalize the point.
' Note that value still holds Rpt(4).
Axes(x).Trans(1) = Axes(x).Trans(1) / value
Axes(x).Trans(2) = Axes(x).Trans(2) / value
Axes(x).Trans(3) = Axes(x).Trans(3) / value
Axes(x).Trans(4) = 1
End Sub
Private Sub Main()
Dim x As Integer
Dim y As Integer
Dim R As Single
' Initialize the viewing location.
EyeX = 40
EyeY = 20
EyeZ = 20
Points(0, 0).Coord(1) = 0 ' X coordinate.
Points(0, 0).Coord(2) = 0 ' Y coordinate.
Points(0, 0).Coord(3) = 1 ' Z
Points(0, 0).Coord(4) = 1 ' Scale factor.
Points(0, 1).Coord(1) = 10 ' X coordinate.
Points(0, 1).Coord(2) = 0 ' Y coordinate.
Points(0, 1).Coord(3) = 1 ' Z
Points(0, 1).Coord(4) = 1 ' Scale factor.
Points(0, 2).Coord(1) = 10 ' X coordinate.
Points(0, 2).Coord(2) = 10 ' Y coordinate.
Points(0, 2).Coord(3) = 1 ' Z
Points(0, 2).Coord(4) = 1 ' Scale factor.
Points(0, 3).Coord(1) = 0 ' X coordinate.
Points(0, 3).Coord(2) = 10 ' Y coordinate.
Points(0, 3).Coord(3) = 1 ' Z
Points(0, 3).Coord(4) = 1 ' Scale factor.
Points(1, 0).Coord(1) = 0 ' X coordinate.
Points(1, 0).Coord(2) = 0 ' Y coordinate.
Points(1, 0).Coord(3) = 10 ' Z
Points(1, 0).Coord(4) = 1 ' Scale factor.
Points(1, 1).Coord(1) = 10 ' X coordinate.
Points(1, 1).Coord(2) = 0 ' Y coordinate.
Points(1, 1).Coord(3) = 10 ' Z
Points(1, 1).Coord(4) = 1 ' Scale factor.
Points(1, 2).Coord(1) = 10 ' X coordinate.
Points(1, 2).Coord(2) = 10 ' Y coordinate.
Points(1, 2).Coord(3) = 10 ' Z
Points(1, 2).Coord(4) = 1 ' Scale factor.
Points(1, 3).Coord(1) = 0 ' X coordinate.
Points(1, 3).Coord(2) = 10 ' Y coordinate.
Points(1, 3).Coord(3) = 10 ' Z
Points(1, 3).Coord(4) = 1 ' Scale factor.
/*
' Initialize the data points.
For x = Xmin To Xmax
For y = Ymin To Ymax
Points(x, y).Coord(1) = x ' X coordinate.
Points(x, y).Coord(2) = y ' Y coordinate.
Points(x, y).Coord(4) = 1 ' Scale factor.
' Z coordinate.
R = Sqr(x * x + y * y)
Points(x, y).Coord(3) = Cos(R)
Next y
Next x
*/
' Initialize the axes.
Axes(1).Coord(1) = 10 ' X axis.
Axes(1).Coord(4) = 1
Axes(2).Coord(2) = 10 ' Y axis.
Axes(2).Coord(4) = 1
Axes(3).Coord(3) = 10 ' Z axis.
Axes(3).Coord(4) = 1
DrawSurface
getkey()
End Sub
Main()
'-----------------------------------------------
'** Demo der Bresenham-Algorithmen für den Kreis
'** Autor: Roland Heer
'** Sprache: QBasic
'** Stand: 20.10.96
'** Public Domain
'-----------------------------------------------
CLS
DIM md = 5
DIM t! = TIMER
FOR r AS INTEGER = 1 TO 230
Kreis(320, 240, r, 15, md)
NEXT
PRINT USING " needed time: ###.##"; TIMER - t!;
PRINT " sec";
END
SUB Kreis (x0, y0, r, Farbe, md)
STATIC n AS INTEGER
DIM d = 3 - 2 * r
DIM Farbe
DIM x = 0 : DIM y = r 'Anfang bei -90ø
DO
n = n + 1
IF (n MOD md) = 0 THEN Farbe = (Farbe + 1) MOD 16
LINE(x0 + x, y0 + y) - (x0 + x, y0 + y), Farbe
LINE(x0 - x, y0 + y) - (x0 - x, y0 + y), Farbe
LINE(x0 + x, y0 - y) - (x0 + x, y0 - y), Farbe
LINE(x0 - x, y0 - y) - (x0 - x, y0 - y), Farbe
LINE(x0 + y, y0 + x) - (x0 + y, y0 + x), Farbe
LINE(x0 - y, y0 + x) - (x0 - y, y0 + x), Farbe
LINE(x0 + y, y0 - x) - (x0 + y, y0 - x), Farbe
LINE(x0 - y, y0 - x) - (x0 - y, y0 - x), Farbe
IF d >= 0 THEN
d = d + 4 * (x - y) + 10
y = y - 1
ELSE
d = d + 4 * x + 6
END IF
x = x + 1
LOOP UNTIL x > y
END SUB
RANDOMIZE TIMER
DIM Ff = 0
DIM V = 0
DIM X = 0
DIM Y = 0
DIM C = 0
CLS
DO
Ff = Ff + 1
IF Ff > 20000 THEN
V = V + 1
IF V > 1 THEN V = 0
Ff = 0
END IF
X = INT(RND * 919)
Y = INT(RND * 699)
IF V = 0 THEN C = INT(RND * 63)
IF V = 1 THEN C = 0
LINE(X, Y) - (X, Y), C
LOOP UNTIL INKEY$ = CHR(27)
RANDOMIZE TIMER DIM Xx1 = 0 DIM Xx2 = 0 DIM Yy1 = 0 DIM Yy2 = 0 DO Xx1 = Xx1 + INT(RND * 9) - 4 IF Xx1 < 0 THEN Xx1 = 0 IF Xx1 > 640 THEN Xx1 = 640 Xx2 = Xx2 + INT(RND * 9) - 4 IF Xx2 < 0 THEN Xx2 = 0 IF Xx2 > 640 THEN Xx2 = 640 Yy1 = Yy1 + INT(RND * 9) - 4 IF Yy1 < 0 THEN Yy1 = 0 IF Yy1 > 480 THEN Yy1 = 480 Yy2 = Yy2 + INT(RND * 9) - 4 IF Yy2 < 0 THEN Yy2 = 0 IF Yy2 > 480 THEN Yy2 = 480 LINE(Xx1, Yy1) - (Yy1, Yy2), INT(RND * 15) LOOP UNTIL INKEY$ = CHR(27)
OPTION VERYOLDBASIC 3 CLS COLOR 15 PRINT " F I S H M A S T E R S" SLEEP 1 PRINT "" PRINT "" PRINT "" PRINT "" PRINT "" PRINT "" PRINT "" PRINT "" PRINT "" PRINT " V E R S I O N 1.0" PRINT "" PRINT "" PRINT "" PRINT "" PRINT "" PRINT "" SLEEP 1 PRINT " What are 'ya waitin' for? Christmas? Press 1 and start fishin'!" INPUT NUM IF NUM = 1 GOTO 1 IF NUM = 2 GOTO 2 1 CLS PRINT " M E N U" PRINT "" PRINT "1. GO FISHIN'" PRINT "" PRINT "2. EXIT" INPUT NUM IF NUM = 1 GOTO 6 IF NUM = 2 GOTO 5 2 CLS PRINT "" PRINT "" PRINT "" PRINT "" PRINT "" PRINT "You hit th' wrong key, Bozo!" SLEEP 2 GOTO 3 5 END 6 CLS COLOR 15 PRINT "What's ur name, feller?"; sn$; "" INPUT sn$ PRINT sn$; ", huh? Well let's go fishin'!" SLEEP 2 CLS PRINT "What kindda lure do ya wanna use?" PRINT "" PRINT "" PRINT "" PRINT "" PRINT "" PRINT "1. Spoon" PRINT "2. Spinnerbait" PRINT "3. Crankbait" PRINT "4. Plastic Worm" PRINT "5. Jig and Pig" PRINT "6. Buzzbait" PRINT "7. Minnows" PRINT "" PRINT "" PRINT "" PRINT "Chose one fast, so I can get fishin'!" INPUT NUM IF NUM = 1 GOTO 10 IF NUM = 2 GOTO 10 IF NUM = 3 GOTO 10 IF NUM = 4 GOTO 10 IF NUM = 5 GOTO 10 IF NUM = 6 GOTO 10 IF NUM = 7 GOTO 10 10 CLS COLOR 15 PRINT "Good choice! Now I can get th' boat ready so we can go fishin'" SLEEP 2 CLS COLOR 15 PRINT "Well,"; sn$; ", I guess we can start castin'" SLEEP 2 CLS PRINT "INSTRUCTIONS: PRESS 1,2, AND 3 TO CAST IN DIFFERENT PLACES" PRINT "YOU CAN PRESS 1 WHEN YOU'RE TIRED READING THIS" INPUT NUM IF NUM = 1 GOTO 11 11 CLS PRINT "" PRINT "" PRINT "" PRINT "Well, where do ya wanna fish at?" PRINT "" PRINT "1. Near The Rock Bank" PRINT "2. Under The Bridge" PRINT "3. Off A Point" PRINT "4. Around The Dock" PRINT "5. In A Cove" INPUT NUM IF NUM = 1 GOTO 12 IF NUM = 2 GOTO 12 IF NUM = 3 GOTO 12 IF NUM = 4 GOTO 12 IF NUM = 5 GOTO 12 12 CLS SLEEP 2 PRINT "This looks like a good ol' spot" SLEEP 1 CLS PRINT "PRESS 1,2, AND 3 TO CAST IN DIFFERENT PLACES" INPUT NUM IF NUM = 1 GOTO 13 13 CLS PRINT "Aww! Ain't that a shame?" PRINT "Ya cought one, but he got off!" PRINT "" PRINT "PRESS 1 TO CAST AGAIN" INPUT NUM IF NUM = 1 GOTO 14 14 CLS PRINT "Got em'! Lets see if he passes the length" SLEEP 2 GOTO 16 15 PRINT "OL' CARP, YUCK!" PRINT "1 TO CAST AGAIN" INPUT NUM IF NUM = 1 GOTO 14 16 CLS PRINT "1 2 3 4 5 6 7 8 9 10 11 12" PRINT "| | | | | | | | | | | |" PRINT "-----------0" PRINT "" PRINT "" PRINT "Its in the limits! Its a keeper!" PRINT "" PRINT "6 and 1/2 inches!" SLEEP 4 PRINT "Nice fish!" CLS PRINT "PRESS 1,2, OR 3 TO CAST AGAIN" INPUT NUM IF NUM = 1 GOTO 17 IF NUM = 2 GOTO 18 IF NUM = 3 GOTO 19 17 CLS PRINT "Nothin'" PRINT "PRESS 1,2, OR 3 TO CAST AGAIN" INPUT NUM IF NUM = 1 GOTO 19 IF NUM = 2 GOTO 18 IF NUM = 3 GOTO 20 18 CLS PRINT "Wow! Nice fish! Lets measure it" SLEEP 1 PRINT "1 2 3 4 5 6 7 8 9 10 11 12" PRINT "| | | | | | | | | | | |" PRINT "-------------------------0" PRINT "" PRINT "" PRINT "A keeper!" 19 CLS PRINT "Nothin'. Lets go somewhere else, ok?" PRINT "PRESS 1 TO KEEP FISHIN' HERE" PRINT "PRESS 2 TO EXIT THE GAME" PRINT "PRESS 3 TO GOTO ANOTHER SPOT" INPUT NUM IF NUM = 1 GOTO 21 IF NUM = 2 GOTO 5 IF NUM = 3 GOTO 22 21 CLS PRINT "Ok, one more cast, then we leave!" SLEEP 2 CLS PRINT "See, nothin'" SLEEP 2 22 CLS PRINT "1. EXIT" PRINT "2. BRIDGE" PRINT "3. AROUND THE DOCK" INPUT NUM IF NUM = 1 GOTO 5 IF NUM = 2 GOTO 12 IF NUM = 3 GOTO 12 20 GOTO 12
OPTION VERYOLDBASIC 'The Psychotic Glow-worm 'By Aaron Sutherlin 'If this runs too quickly, increase the value "100" in line 18. CLS DIM x(0 TO 15000) AS INTEGER DIM y(0 TO 15000) AS INTEGER 1 DO UNTIL INKEY$ = "q" IF arg = 15000 THEN CLS IF arg = 15000 THEN arg = 0 arg = arg + 1 'IF arg > 900 THEN PSET (x(arg - 900), y(arg - 900)), 0 a = INT(RND(1) * 3) - 1 b = INT(RND(1) * 3) - 1 x(arg) = x(arg - 1) + a IF x(arg) < 10 THEN x(arg) = 300 IF x(arg) > 300 THEN x(arg) = 10 y(arg) = y(arg - 1) + b IF y(arg) < 10 THEN y(arg) = 390 IF y(arg) > 390 THEN y(arg) = 10 LINE(x(arg), y(arg)) - (x(arg)+1, y(arg)+1),(arg MOD 14 + 1) 'PSET (x(arg), y(arg)), (arg MOD 14 + 1) 'FOR z = 1 TO 200 'NEXT LOOP
Option VeryOldBasic
1 REM
2 REM ORIGINALLY FOR THE PDP-11
3 REM CONVERTED TO TRS-80 BASIC 4/02 BY ANTHONY WOOD
4 REM
6 CLS:PRINT "SNOOPY FOR YOU"
10 print
20 print
30 print
40 print" XXXX"
50 print" X XX"
60 print" X *** X XXXXX"
70 print" X ***** X XXX XX"
80 print" XXXX ******* XXX XXXX XX"
90 print" XX X ****** XXXXXXXXX XX XXX"
100 print" XX X **** X X** X"
110 print" X XX XX X X***X"
120 print" X //XXXX X XXXX"
130 print" X // X XX"
140 print" X // X XXXXXXXXXXXXXXXXXX/"
150 print" X XXX// X X"
160 print" X X X X X"
170 print" X X X X X"
180 print" X X X X X XX"
190 print" X X X X X XXX XX"
200 print" X XXX X X X X X X"
210 print" X X X XX X XXXX"
220 print" X X XXXXXXXX\ XX XX X"
230 print" XX XX X X X XX"
240 print" XX XXXX XXXXXX/ X XXXX"
250 print" XXX XX*** X X"
260 print" XXXXXXXXXXXXX * * X X"
270 print" *---* X X X"
280 print" *-* * XXX X X"
290 print" *- * XXX X"
300 print" *- *X XXX"
310 print" *- *X X XXX"
320 print" *- *X X XX"
Sleep 3
330 print" *- *XX X X"
340 print" * *X* X X X"
350 print" * *X * X X X"
360 print " * * X** X XXXX X"
370 print" * * X** XX X X"
380 print" * ** X** X XX X"
390 print" * ** X* XXX X X"
400 print" * ** XX XXXX XXX"
410 print" * * * XXXX X X"
420 print" * * * X X X"
430 print" =======******* * * X X XXXXXXXX\"
440 print" * * * /XXXXX XXXXXXXX\ )"
450 print" =====********** * X ) \ )"
460 print" ====* * X \ \ )XXXXX"
470 print" =========********** XXXXXXXXXXXXXXXXXXXXXX"
480 print
490 print
520 END
'
'*********************************************************************
'
' SPACE - A Space Game For KBasic
'
' (C) Copyright KBasic Software 2006.
'
' This small game demonstrates some programming techniques.
'
'*********************************************************************
Sub intro()
Color(10, 0)
CLS
Locate 5, 1
Locate, 10 : Print " SPACE "
Locate, 10 : Print "_________________________________"
Locate, 10 : Print "It is about a ship flying around the"
Locate, 10 : Print "space. You can fly the ship,"
Locate, 10 : Print "trade goods between planets..."
Sleep 2
Locate, 10 : Print ""
Locate, 10 : Print "Try to keep alive, when pirates"
Locate, 10 : Print "are trying to blast you."
Locate, 10 : Print "Good luck!"
Locate, 10 : Print ""
Locate, 10 : Print ""
Locate, 10 : Print "Use the following keys:"
Locate, 10 : Print ""
Locate, 10 : Print "Left A"
Locate, 10 : Print "Right D"
Locate, 10 : Print "Top W"
Locate, 10 : Print "Down X"
Locate, 10 : Print ""
Locate, 10 : Print "Fire G"
Locate, 10 : Print ""
Locate, 10 : Print ""
Sleep 2
Locate, 10 : Print "Press ANY key to start the game..."
Sleep
End Sub
Sub bye()
Color(1, 15)
CLS
Locate 15, 1
Locate, 30 : Print " Goodbye. "
Sleep 1
End Sub
' *** global vars & inits
Type planet
myName As String * 100
x As Integer
y As Integer
cargo As Integer
price As Integer
End Type
Dim shield As Integer = 100
Dim cargo As Integer = 0
Dim money As Integer = 100
Dim ship As String = "~*~**~*"
'Dim galaxy(24, 5, 3) As Integer
' *** planets
Dim planets(5) As planet
Randomize Timer
For i As Integer = 1 To 5
planets[i].x = Int(RND * 12) + 1
planets[i].y = Int(RND * 5) + 1
planets[i].cargo = Int(RND * 125) + 1
planets[i].price = Int(RND * 15) + 10
Next
planets[1].myName = "Earth"
planets[2].myName = "Tauris"
planets[3].myName = "Ceta"
planets[4].myName = "Orion"
planets[5].myName = "Mardoa"
planets[1].x = 2
planets[1].y = 2
' ***
Dim myX As Integer = 1
Dim myY As Integer = 1
Dim poX As Integer = +1
Dim poY As Integer = +1
Dim enemy As Integer = 0
' ***
Sub header()
CLS
Locate 10, 1
Color(15, 0)
Locate, 10 : Print " SPACE "
Locate, 10 : Print "_________________________________"
End Sub
sub footer
Locate, 10 : Print "_________________________________"
Locate, 10 : Print ""
Locate, 10 : Print "Shield " + shield
Locate, 10 : Print "---------------------------------"
Locate, 10 : Print "Cargo #" + cargo + " Money $" + money
location()
navigation()
'kkk()
'print "****************************************"
End Sub
Sub fly()
For i As Integer = 1 To 10
header()
'Print "i=" + i
Locate, 10 : Print Right(". . . . . . ", 35 - i)
Locate, 10 : Print Right(". . . . . . . " , 35 - i)
Locate, 10 : Print Right(". . . . . . .", 35 - i)
Locate, 10 : Print Mid(" |-###-> ", 34 - i)
Locate, 10 : Print Right(". . . . . . ", 35 - i)
Locate, 10 : Print Right(". . . . . . . " , 35 - i)
Locate, 10 : Print Right(". . . . . . .", 35 - i)
footer()
'Sleep 1
Next
End Sub
Sub intercepting()
header()
Locate, 10 : Print ""
Locate, 10 : Print ""
Locate, 10 : Print ""
Locate, 10 : Print " Intercepting... "
Locate, 10 : Print ""
Locate, 10 : Print ""
Locate, 10 : Print ""
footer()
Sleep 2
' ***
enemy = 10
' ***
header()
Locate, 10 : Print ". . . . "
Locate, 10 : Print ". . . . "
Locate, 10 : Print ". . ."
Locate, 10 : Print " |-###-> " + ship
Locate, 10 : Print ". . . . "
Locate, 10 : Print ". . . . "
Locate, 10 : Print ". . . ."
footer()
End Sub
Sub visiting(i As Integer)
header()
Locate, 10 : Print ""
Locate, 10 : Print ""
Locate, 10 : Print ""
Locate, 10 : Print " Approaching " + planets[i].myName
Locate, 10 : Print ""
Locate, 10 : Print ""
Locate, 10 : Print ""
Sleep 2
bb:
header()
Locate, 10 : Print ""
Locate, 10 : Print "Welcome to " + planets[i].myName
Locate, 10 : Print ""
Locate, 10 : Print "I hope you have had a nice stay in space."
Locate, 10 : Print "How can I help you?"
Locate, 10 : Print "Would you like to buy or sell cargo?"
Locate, 10 : Print ""
Locate, 10 : Print "Press [s] to sell for $" + planets[i].price
Locate, 10 : Print "Press [b] to buy for $" + planets[i].price
Locate, 10 : Print ""
Locate, 10 : Print "Press [x] to leave this planet"
Locate, 10 : Print ""
Locate, 10 : Print "You have got $" + money
Locate, 10 : Print "Your Cargo #" + cargo
Dim k As String
Dim d As Integer
Do While True
k = Inkey
Select Case k
Case "s"
Locate 27, 10 : Input "How much to sell"; d
If d > cargo Then d = cargo
money = money + d * planets[i].price
cargo = cargo - d
Locate 28, 10 : Print "You are welome."
Sleep 1
GoTo bb
Case "b"
Locate 27, 10 : Input "How much to buy"; d
If d * planets[i].price > money Then d = money / planets[i].price
money = money - d * planets[i].price
cargo = cargo + d
Locate 28, 10 : Print "Nice to meet you."
Sleep 1
GoTo bb
Case "x"
myX = myX + 1
Exit Sub
End Select
Loop
End Sub
Sub location()
Locate 10, 1
Locate, 50 : Print " Galaxy "
Locate, 50 : Print "_ _ _ _ _ _ _ _ _ _ _ _ "
Locate, 50 : Print " "
Locate, 50 : Print " "
Locate, 50 : Print " "
Locate, 50 : Print " "
Locate, 50 : Print " "
Locate, 50 : Print "_ _ _ _ _ _ _ _ _ _ _ _ "
Static b As Boolean
For i As Integer = 1 To 5
Locate 11 + planets[i].y, 49 + planets[i].x : Print "*"
Next
b = Not b
If b Then Color(15, 0) Else Color(0, 15)
Locate 11 + myY, 49 + myX : Print "x"
Color(15, 0)
End Sub
Sub visit
For i As Integer = 1 To 5
If myX = planets[i].x And myY = planets[i].y Then
visiting(i)
End If
Next
End Sub
Sub navigation()
Locate 20, 1
Locate, 50 : Print " Navigation "
Locate, 50 : Print ""
Locate, 50 : Print " . "
Locate, 50 : Print " "
Locate, 50 : Print " . . . "
Locate, 50 : Print " "
Locate, 50 : Print " . "
' Print "poX=" & poX : Print "poY=" & poY
If poX = 1 And poY = 1 Then Locate 25, 62
Else If poX = 1 And poY = 0 Then Locate 24, 62
Else If poX = 1 And poY = -1 Then Locate 23, 62
Else If poX = 0 And poY = -1 Then Locate 23, 60
Else If poX = -1 And poY = -1 Then Locate 23, 58
Else If poX = -1 And poY = 0 Then Locate 24, 58
Else If poX = 0 And poY = 0 Then Locate 24, 60
Else If poX = 0 And poY = 1 Then Locate 25, 60
Else If poX = -1 And poY = 1 Then Locate 25, 58
Print "#"
End Sub
Sub move()
moveX(poX)
moveY(poY)
End Sub
Sub moveX(x As Integer)
myX = myX + x
if myX > 12 myX = 1
End Sub
Sub moveY(y As Integer)
myY = myY + y
if myY > 5 myY = 1
End Sub
Sub hit()
enemy = enemy - 1
End Sub
Sub fire()
Select Case Int(RND * 5) + 1
Case 1
hit()
Case Else
End Select
End Sub
Sub kkk()
Static k As String
Static t As Integer
t = Timer
Do While True
k = Inkey
Select Case k
Case "a"
poX = poX - 1 : If poX < -1 Then poX = -1
Exit Sub
Case "d"
poX = poX + 1 : If poX > 1 Then poX = 1
Exit Sub
Case "x"
poY = poY + 1 : If poY > 1 Then poY = 1
Exit Sub
Case "w"
poY = poY - 1 : If poY < -1 Then poY = -1
Exit Sub
Case "g"
fire()
Exit Sub
Case Else
If t + 1 < Timer Then Exit Sub
End Select
Loop
End Sub
Sub main()
' main event loop
Randomize Timer
fly()
Do While True
Select Case Int(RND * 5) + 1
Case 1
intercepting()
Case 2
For i As Integer = 1 To 5
planets[i].cargo = planets[i].cargo + Int(RND * 15) + 1
planets[i].price = planets[i].price + Int(RND * (100 - planets[i].cargo))
If planets[i].price < 0 Then planets[i].price = planets[i].price * -1
Next
Case Else
fly()
End Select
' ***
move()
visit()
' ***
Sleep 1
Loop
End Sub
'visiting(1)
'intro()
main()
'bye()
Option VeryOldBasic 1 REM 2 REM CLASSIC ASCII SPOCK 3 REM CONVERTED TO TRS-80 BASIC ON 4/02 BY ANTHONY WOOD 4 REM CLS 10 DATA";;-;;-;---;-;;;-;---B-BB??O8@@@@@@@@@@@@@@@@@@@@@@@8IB-;:;':'''''';-/+==?/BB-B-" 20 DATA"''''''''''''''''.;-/*O@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@8XB;'::::::'';B/???/B--;--" 30 DATA"'''::''''''':':':;/I@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@O=-;::':''';;-;---;;;;--" 40 DATA"'''''''''''''''''O@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@#I?''''''';;-B;;;;;;;;" 50 DATA"''''''''''''''-/N@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@8OB;;;;;;;;;;;;;;;--" 60 DATA":'''''''''''BI@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@8+B;;;;;;;;;-----" 70 DATA"'''''''''''BO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@O*B;;';;;;;-----" 80 DATA"''''''''''-O@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@#O?B;;----BBBB" 90 DATA"''''''''-=@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@S/B-//??/BBB" 100 DATA";'''''''$@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@S=/????/B--" 110 DATA";'''''-I@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@NX+???/BB--" 120 DATA"'''''-X@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@#X=??//BBB" 130 DATA"'''''?N@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@UI??/BBBB" 140 DATA"''''/S@@@@@$*IIO8#ON@@@@@@@@@@@@@@@@@@@@@@@@@@@@@$N@@@@@@@@@@@@@@@@@@@@S?B-----" 150 DATA"''''/$@@@@#S*I$$88OON@@@@@@@@@@@@@@@@@@@@@@@@@@@NON@@@@@@@@@@@@@@@@@@@@$=B-----" 160 DATA"::::/#@@NOZ@@@@@@$N8SOSN#@@@@@@@@@@@@@@@##N@@@@@NN@@@@@@@@@@@@@@@@@@@@@@@**B;--" 170 DATA"::::B$@@S*#@@@@@@@@@8OOSSN$@@@###@@@@##@$O$NNN@@@@@@@@@@@@@@@@@@@@@@@@@@@@*B;--" 180 DATA"::::/#@@OS@@@@@@@@@@@@@8OO=IOON$$8N@N$#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@S?'';" 190 DATA"::::=@@@8$@@@@@@@@@@@@@@@N$8$S###$8@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@NI;''" 200 DATA"::::O@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*;''" 210 DATA":::-N@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@O-''" 220 DATA"::'+@@@@@@#O/=8@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@8/;'" 230 DATA"::'*@@@@@@NO/;-*?O==BOX@#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@#@@@@@@@@@@@@@@N+;;" 240 DATA":::S@@@@@@NOB'...::..:::.:.../;==8I$I=/OINO@*X=N8@N@####N#####@@@@@@@@@@@@@@S?B" 250 DATA"::BO@@@@@@N*-'..........:....:.:.;'''::'';'BB;;-BB+/OXNN#N#####@@@@@@@@@@@@@8?-" 260 DATA":-8@@@@@@@8?:;ISI':.....:...............'..'';-B-;BB/=O8N@@@@##@@@@@@@@@@@@@XB;" 270 Data ":-$@##@@@@S-:'BS$*I;;:'.........:.:...':::';;-';--/?*X$#@@@@@#N@@@@@@@@@@@@@O=-" 280 DATA"::O@N$@@@#?..'-B-OO@N$NSS?/......'...::':'':--=IO$@@@@@@@@@#$###@@@@@@@@@@@@@@O" 290 DATA"::I@@N@@@$-:;---BB==$@@@$8O//;B....''.::'':=**NN@@@@@@@@@@##8N##@@@@@@@@@@@@@@$" 300 DATA"::'IN##@@X:.;?+?/++OSN#@@@@@@@S-:..'..-?OSNN@@@@@@@@@@@@@@@@NO$##@@@@@@@@@@@@@N" 310 DATA";'...BS@N?.:;-?SN@@@@@@@@@@SS.... ..:-O@@#@@@@@@@@@@@@@@@@@#NS8#@@@@@@@@@@@@@#*" 320 DATA" I@$B..';+#@@O+@@@@@@@SB .... . B8@@@@@@@@@@@@@@@@@@@@@#8S$@@@@@@@@@@@@@$?" 330 DATA":::/S@#@#I..-/=+I$$@@@@@@@@@@$=.....''?ON##@@@@@@@@@@@@@#@@@#8O##@@@@@@@@@@@@@$" 340 DATA"-+/ -'?N8; .:;+;::?==XX*+;; .... ..:B$@@@@@@@@@O?I@8ON@@@@#N$OX$@@@@@@@@@@@$-" 350 DATA":;B+=B/8X ..''...''B;/'BB; BO@@@@@@@S*?IOOOON@@@@@#NS*O@@@@@@@@@@#I.." 360 DATA"..;;'?I$? ...... ..'; -- .......'/O@@@@@@@?';-B/=**SO$SS8##$OX$@@@@@@@#B::'" 370 DATA"..';::?N+ ..... ..'';-; ........::+$@@@@@@@I:'-B/=**SO$SS8##$OX$@@@@@@@#B::'" 380 DATA"..'-'+$* . . ..';B-; ...... :/S######@@@='.'-B-B?+IIO8N#8OO8@@@@NN8=;::''" 390 DATA"..'-';-*S . . ';-' .... '+8#NN####@@OB.:--B/??IIS$N#8OO$@@@@8$O?-'''" 400 Data "..';::-'I?... .....''' .... :?8@##NNNN@@NX-;;;;;-+*OO8NN@@@@@@@N8S+/B-''" 410 DATA" .;;:BI;++::: ....'.:: .... :BS@@#N$N#@@#S/;''';B+*S8$N$@@@@@@@@#NOB?/-;" 420 DATA" .'; 'B-'B;''' :...... ...... .-O#@@NN8N@@@8+;;-'/X8888$N$@@@@@@@@#O?;;'''" 430 DATA" .'' .:;.';'.'':...... ..... .;XN@@@#N#@@@$IB--B*888$8$N$@@@@@@@@#O-::'::" 440 DATA" .:' . ::'':::'...... ... /='. .:=8@####N@@@@@8*?++*XO$N$N$$@@@@@@@@N*: .:.." 450 DATA" .::'...;:'':::'...... ... *@@=;'?BS#@@@#N@@@@@@#O*I*S8$NNNNNN@@@@@@@@N?...:::" 460 DATA".. :;'...;-':::.......... . .-/?;*#@@@@@@@@@@@@@@@@N$8#NN@#NNNN@@@@@@@@I..:::::" 470 DATA".. :'-.:+S=':::....... .. . .::':'/@@@@@@@@@@@@@@@@@@$N#N#N#NNN@@@@@@@X; .:::::" 480 DATA" :'+';-;'':... .. ..:-=O@@@@@#N#@@@#N$$$$8$8$$$$$ON##OB ......" 490 DATA" ';'::..... :;: ...:'B/+SO@@@##N#@@NN$$$$888$$N$8S8$N? .. ./X8" 500 DATA" '::......': . .::::';--;?XOO*OONNN#@#$$$88888$$N$8B/. .+NN#" 510 DATA" ;'::......:. :..:::::';;-+XOOOXXS8$N@#N$$8$$$88$$$$O' .*8##8" 520 DATA" .. :;'::......:....:. . ... :BIOSOO88N$NNN$$$$$$$N$$$$* :X8NN@@@" 530 DATA" ..... .';'::::...:..::. . ;'/.. .'*IOSSO$$NNNN#8$$$N$$$$N$$= .. '=$###@@@" 540 DATA" ... ';':::...:-/X+SO@#@@@##$@@@@@8$88NNNNN#N$$$$$N$$$$8? 'O$O8$$#@@" 550 DATA" . :;':::. .'/II*BOB+-?SX@N@@@@@@@#$NN#NN#N$$$$$$$N$88? -SOS8NN@@@" 560 DATA" . '::::::'--::''''...:'''/?OO$$@@@@@@@@$$$$$$$$$8$$? BISOO8#@@@@" 570 DATA" . ':::''-;:::;/+X?*/+-??**O8NN#N#@@@@$$$$$$$88NN$? :S88S8N@@@@@" 580 DATA".. ... . ;':::';;;;;-/?IOO#N@@@@@@@@#####@@8$N$N$$$8N##$= +@@#$#@@@@@@" 590 DATA"........... ...;-''''''';;B/??+*IX+XX$#@@@@#@##@@@$$NNNN$$N#@@NI. *@@@#@@@@@@@" 600 DATA"::::'''::::::::';--;';;;';;;;;;--//??*X8N@@@@@@@@@@@##NNN#@@@@#O; $#S=N@@@@@@@" 610 DATA":::::''''::::::';---;;';'''';':':;;-;B/**O8@N@#@@@@@##NN#@@@@@@8B:=#$=;I#@@@@@@" 620 DATA" . .. ......... ..;----;'::::::::';;';B/+II=+//O8NNN$@@@@@@@@@$**NSXB. .++@@@@@" 630 DATA" ................';;;BB;':::'''';;--;;/??IX**IXON##N##@@@@@@@@#NXI#NSB. ./@@@@@" 640 DATA" . . ...........'-;---/+BB-BB/B////?+***XOOSON#N@@@@@@@@@@@@@#N8S@@@? .;8@N#N" 650 DATA".............. ..';;;;;B?++/++I===I=XXOXXXSO$$#NN@@@@@@@@@@@@@##@#@@@8B .:I@$OO" 660 DATA" .. '?;''''''+8N8#$#N#N@N#$NN###N#@@@@@@@@@###@@@@@@@@@@@@O=''+XOO" 670 DATA" . . . -O/'::':';+S@@@@@@@@@@@@@###@@@@@@@@@@#N#@@@@@@@@@@@@@@#O*-+OX" 680 DATA" ...?#SB.:''';-?/8#8@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@$IIO" 690 DATA" . .. BN@S;.:'';-B=++/*8@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OXO" 700 DATA" . .....-O@@#8/':'-BBB;;-B*O@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@N8$N$" 710 DATA" . .. ...B8@@@@O*;;-B?B---?=O#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@N$N##" 720 DATA" .. . . ....=@@@@@@@@N@N@#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@#@" 730 DATA" . .. . ....=#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@#@" 790 DATA"END" 5 CLS : Print, "Printing Classic Spock" 6 Read L$ : If L$ = "END" Then Print : End k = k + 1 If k = 35 Then Sleep 2 9 Print L$ : GoTo 6
OPTION OLDBASIC CLS 'PAINT (0, 0), 8 LINE (0, 0)-(639, 200), 0, BF FOR n = 1 TO 200: x = RND * 630: y = RND * 198: LINE (x, y)-(x, y), 15 NEXT FOR n = 1 TO 17000: x = RND * 639: y = RND * 190 + 200: LINE (x, y)-(x, y), 15 NEXT gr = 100: x = 300: y = 250: col = 15: schleife gr = 70: x = 300: y = 170: schleife gr = 40: x = 300: y = 110: schleife gr = 15: x = 225: y = 150: schleife gr = 15: x = 375: y = 150: schleife gr = 5: x = 285: y = 100: col = 0: schleife gr = 5: x = 315: y = 100: schleife gr = 5: x = 300: y = 110: col = 4: schleife gr = 5: x = 300: y = 150: col = 0: schleife gr = 5: y = 160: schleife gr = 5: y = 170: schleife LINE (255, 65)-(345, 85), 8, BF LINE (280, 65)-(320, 30), 8, BF END SUB schleife FOR n = 1 TO gr STEP .05 LINE (x, y)-(x, y), col 'CIRCLE (x, y), n, col NEXT END SUB
' DLL USING (new style)
' Warning! If you use predeclared DECLARE statements of VB6, be aware
' that the size of the datatypes differs between VB6 and KBasic,
' namely Long in VB6 must be Integer in KBasic! You have to change it.
' zunächst die benötigten API-Deklarationen
Class comdlg32 Alias Lib "comdlg32.dll"
Static Function ChooseColor_Dlg Alias "ChooseColorA"_
(lpcc As CHOOSECOLOR_TYPE) As Integer
Type CHOOSECOLOR_TYPE
lStructSize As Integer
hwndOwner As Integer
hInstance As Integer
rgbResult As Integer
lpCustColors As Integer
flags As Integer
lCustData As Integer
lpfnHook As Integer
lpTemplateName As String
End Type
' Anwender kann alle Farben wählen
Const CC_ANYCOLOR = &H100
' Nachrichten können "abgefangen" werden
Const CC_ENABLEHOOK = &H10
' Dialogbox Template
Const CC_ENABLETEMPLATE = &H20
' Benutzt Template, ignoriert aber den Template-Namen
Const CC_ENABLETEMPLATEHANDLE = &H40
' Vollauswahl aller Farben anzeigen
Const CC_FULLOPEN = &H2
' Deaktiviert den Button zum Öffnen der Dialogbox-Erweiterung
Const CC_PREVENTFULLOPEN = &H4
' Vorgabe einer Standard-Farbe
Const CC_RGBINIT = &H1
' Hilfe-Button anzeigen
Const CC_SHOWHELP = &H8
' nur Grundfarben auswählbar
Const CC_SOLIDCOLOR = &H80
End Class
Class kernel32 Alias Lib "kernel32.dll"
Public Static Function CloseHandle(ByVal hObject As Integer) As Integer
Public Static Function OpenProcess (ByVal dwDesiredAccess As Integer,_
ByVal bInheritHandle As Integer,_
ByVal dwProcessId As Integer) As Integer
Public Static Function WaitFor Alias "WaitForSingleObject"(ByVal hHandle As Integer,_
ByVal dwMilliseconds As Integer) As Integer
Public Const INFINITE = &HFFFF
Public Const SYNCHRONIZE = &H100000
End Class
'Warten bis Anwendung beendet
Public Sub AppStartAndWait(ByVal sFile As String)
'Parameterbeschreibung
'sFile: Anwendung, die gestartet werden soll
Dim lHandle As Integer
Dim lRet As Integer
Dim lRetVal As Integer
lRetVal = Shell(sFile)
lHandle = kernel32.OpenProcess(kernel32.SYNCHRONIZE, 0, lRetVal)
If lHandle <> 0 Then
lRet = kernel32.WaitFor(lHandle, kernel32.INFINITE)
kernel32.CloseHandle(lHandle)
End If
End Sub
Dim CC_T As comdlg32.CHOOSECOLOR_TYPE, Retval As Integer
Dim BDF(16) As Integer
'Dim k As String
'CC_T.lpTemplateName = AddressOf(k)
'CC_T.lpTemplateName = "fdgfg"
'Print CC_T.lpTemplateName
'Einige Farben vordefinieren (Benutzerdefinierte Farben)
BDF(0) = RGB(255, 255, 255)
BDF(1) = RGB(125, 125, 125)
BDF(2) = RGB(90, 90, 90)
'Print Len(CC_T) 'Strukturgröße
With CC_T
.lStructSize = Len(CC_T) 'Strukturgröße
.hInstance = 0'App.hInstance 'Anwendungs-Instanz
.hwndOwner = 0 'Me.hWnd 'Fenster-Handle
.flags = comdlg32.CC_RGBINIT Or comdlg32.CC_ANYCOLOR Or comdlg32.CC_FULLOPEN Or comdlg32.CC_PREVENTFULLOPEN 'Flags
.rgbResult = RGB(0, 255, 0) 'Farbe voreinstellen
.lpCustColors = AddressOf(BDF(0)) 'Benutzerdefinierte Farben zuweisen
End With
Retval = comdlg32.ChooseColor_Dlg(CC_T) 'Dialog anzeigen
If Retval <> 0 Then
MsgBox Hex$(CC_T.rgbResult) 'gewählte Farbe als Hintergrund setzen
Else
MsgBox "Das Auswählen einer Farbe ist fehlgeschlagen," & _
"oder Sie haben Abbrechen gedrückt", kbCritical, "Fehler"
End If
'AppStartAndWait("edit")
' DLL USING (old style)
' Warning! If you use predeclared DECLARE statements of VB6, be aware
' that the size of the datatypes differs between VB6 and KBasic,
' namely Long in VB6 must be Integer in KBasic! You have to change it.
' Play midi file using the windows api. Not portable!
' Be sure that the midi files are correctly named to the install path of KBasic
' in this example!
Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA"_
(ByVal lpszCommand As String, ByVal lpszReturnString As String, _
ByVal cchReturnLength As Integer, ByVal hwndCallback As Integer) As Integer
Dim s As String
Dim k As String
Dim r As Integer
k = Space(1024)
r = mciSendString("close all", k, Len(k), 0)
Randomize Timer
Select Case Int(RND * 4) + 1
Case 1
s = "Open c:\kbasic15\examples\test\mond_1.mid Type sequencer Alias MUSIC"
Case 2
s = "Open c:\kbasic15\examples\test\mond_3.mid Type sequencer Alias MUSIC"
Case 3
s = "Open c:\kbasic15\examples\test\pathetique_1.mid Type sequencer Alias MUSIC"
Case 4
s = "Open c:\kbasic15\examples\test\pathetique_2.mid Type sequencer Alias MUSIC"
End Select
r = mciSendString(s, k, Len(k), 0)
If r = 0 Then
r = mciSendString("play MUSIC from 0", k, Len(k), 0)
End If
' DLL USING (old style)
' Warning! If you use predeclared DECLARE statements of VB6, be aware
' that the size of the datatypes differs between VB6 and KBasic,
' namely Long in VB6 must be Integer in KBasic! You have to change it.
' Play wav file using the windows api. Not portable!
' Be sure that the wav files are correctly named to the install path of KBasic
' in this example!
Declare Function PlaySound Lib "winmm.dll" Alias "PlaySoundA"_
(lpszName As String, ByVal hModule As Integer, ByVal dwFlags As Integer) As Integer
Dim s As String
Randomize Timer
Select Case Int(RND * 2) + 1
Case 1
s = "c:\kbasic14\ide\gong.wav"
Case 2
s = "c:\kbasic14\ide\neon_light.wav"
End Select
Dim r = PlaySound(s, 0, 0)