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)