I'm offering my listing for simple database program that keeps track of your CD collection.
Could be useful for beginners and can be modified.
! CBs CD Dbase v9k
LIBRARY "TRUEDIAL.TRC"
LIBRARY "StrLib.trc"
DECLARE DEF ShortDate$
LET d$=date$
DIM record$(1 to 1000)
DIM field$(1 to 3)
LET field$(1)="Composer: "
LET field$(2)="Title: "
LET field$(3)="Comment: "
OPEN #1: name "CDinfo.Dat", create newold
CALL load_data
DO
SET CURSOR "off"
CALL menu (choice$)
SELECT CASE choice$
CASE "s"
CALL Search
CASE "a"
CALL Additems
CASE "l"
CALL list_items
CASE "d"
CALL DeleteItem
CASE "q"
EXIT DO
CASE "m"
CALL modify
CASE "c"
CALL ChangeColours
CASE else
CALL mistake
END SELECT
LOOP
CLOSE #1
CLEAR
PRINT
CALL courier
SET CURSOR 18,36
PRINT " Thanks for using CB's Database."
SET CURSOR 20,42
PRINT " Press any key..."
! Subroutines
SUB Menu (choice$)
LET name$ = "Arial"
LET size = 12
LET style$ = "Plain"
CALL SetFont (name$, size, style$)
CLEAR
BOX LINES .34,.62,.30,.90
BOX LINES .34,.62,.40,.80
PLOT TEXT,AT .40,.84: "CD Database : " & ShortDate$(d$) & "20"
PLOT TEXT,AT .40,.75:"(S)earch for a record"
PLOT TEXT,AT .40,.70:"(A)dd records"
PLOT TEXT,AT .40,.65:"(L)ist records"
PLOT TEXT,AT .40,.60:"(D)elete a record"
PLOT TEXT,AT .40,.55:"(Q)uit the program"
PLOT TEXT,AT .40,.50:"(M)odify any record"
PLOT TEXT,AT .40,.45:"(C)hange colours"
PLOT TEXT,AT .40,.35:"Press bracketed letter to choose"
GET KEY key
LET choice$ = lcase$(chr$(key))
END SUB
SUB Search
CLEAR
CALL courier
SET CURSOR "on"
PRINT
PRINT
PRINT tab(9);" ";
INPUT prompt "Enter Search Keyword: ": search1$
LET search1$ = lcase$(search1$) ! Make lower case
CALL findit
PRINT
IF found = 0 then
PRINT tab(10);"No entries found."
ELSE IF found=1 then
PRINT tab(10);found; "entry found."
END IF
IF found > 1 then
PRINT tab(10); found; "entries found."
END IF
CALL PressAnyKey
END SUB
SUB findit
CLEAR
LET line, found = 0
LET count=0
DO while count < number
LET count=count+1
IF pos(lcase$(record$(count)),search1$) > 0 then
PRINT tab(10); record$(count)
PRINT tab(10); "Record number";count
LET tmp=count
LET line = line + 1 ! Stop output after 20 lines
LET found = found + 1 ! Count entries found
IF line >= 20 then
PRINT
CALL PressAnyKey
LET line = 0 ! Reset line counter
END IF
END IF
LOOP
END SUB
SUB Additems
CLEAR
CALL courier
SET #1: POINTER END
LET title$ = "Add entries"
LET message$ = "Use the [TAB] for next entry"
LET buttons$ = "Ok|Quit"
DIM labels$(3), text$(3)
MAT READ labels$
DATA Composer, Title, Comments
DO
MAT text$ = nul$
CALL TD_InputM (title$, message$, buttons$, labels$(), text$(), 1, 1, result)
IF result = 1 then
IF text$(3) <> "" then
LET line$=text$(1) & " : " & text$(2) & " : " & text$(3)
PRINT #1: line$
LET number = number + 1
LET record$(number)=line$
LET added=1
END IF
END IF
IF result = 2 then
PRINT
PRINT
PRINT tab(36);"You just canceled"
PAUSE 1
EXIT DO
END IF
LOOP
END SUB
SUB Yes_no
LET ttle$ = "Confirm action"
LET message$ = "Is this OK?"
CALL TD_Message ( ttle$, message$, "Yes| No", 1, result)
IF result = 1 or result = 2 then EXIT SUB
END SUB
SUB again
LET tile$ = "Record Additions"
LET message$ = "Add another record?"
CALL TD_Message ( tile$, message$, "Yes| No", 1, result)
IF result = 1 or result = 2 then EXIT SUB
END SUB
SUB list_items
CLEAR
CALL courier
LET line = 0
LET count = 1
DO while count < number+1
LET line$ = record$(count)
CALL Parse
PRINT tab(5);"-------------------------------------------"
LET count = count + 1
LET line = line + 1
IF line >= 6 then
PRINT
CALL listmore
IF result = 2 then EXIT SUB
LET line = 0 ! Reset line counter
END IF
LOOP
PRINT
PRINT "count = ";count-1
CALL PressAnyKey
END SUB
SUB listmore
LET tile$ = "Listing records"
LET message$ = "Show more records?"
CALL TD_Message ( tile$, message$, "Yes| No", 1, result)
IF result = 1 or result = 2 then EXIT SUB
END SUB
SUB Parse
LET delim$ = ":"
LET line$ = line$ & ":"
LET start = Ncpos(line$,delim$)
LET fld=1
DO
LET end = Cpos(line$,delim$,start) - 1
LET pr$ = line$[start:end]
PRINT tab(5);
PRINT field$(fld);
PRINT trim$(pr$)
LET fld=fld+1
LET start = Ncpos(line$,delim$,end+1)
IF start = 0 then EXIT DO
LOOP
END SUB
SUB DeleteItem
CALL courier
CLEAR
SET CURSOR 2, 5
PRINT "Record Deletion"
SET CURSOR "on"
SET CURSOR 5, 5
PRINT "Enter record details:"
SET CURSOR 5,27
INPUT prompt "": search1$
LET search1$=trim$(search1$)
LET search1$ = lcase$(search1$) ! Make lower case
CLEAR
LET deleted=0
CALL findit
PRINT
IF found = 0 then
PRINT tab(36); search1$;" not found."
ELSE
CALL remove
END IF
IF result = 1 then
PRINT tab(36); search1$;" deleted."
CALL save_data
END IF
END SUB
SUB remove
IF found>1 then
PRINT tab(10);"Which one? Enter its number:";
INPUT del
LET tmp=del
END IF
CALL Yes_no
IF result = 2 then EXIT SUB
LET record$(tmp)=""
LET deleted=1
FOR i=tmp to number
LET record$(i)=record$(i+1)
NEXT i
LET number=number-1
END SUB
SUB modify
CALL courier
CLEAR
SET CURSOR 2, 5
PRINT "Modify a Record"
SET CURSOR "on"
SET CURSOR 5, 5
PRINT "Enter record details:"
SET CURSOR 5,27
INPUT prompt "": search1$
LET search1$=trim$(search1$)
LET search1$ = lcase$(search1$) ! Make lower case
CALL findit
PRINT
IF found = 0 then
PRINT search1$;" not found."
ELSE
CALL changeit
END IF
IF b$="y" then
PRINT search1$;" has been changed"
CALL save_data
END IF
END SUB
SUB changeit
CALL courier
LET changed=0
IF found>1 then
PRINT "Change which one? Enter its number:";
INPUT change
LET tmp=change
END IF
CALL Yes_no
IF result = 2 then EXIT SUB
LET temp$=record$(tmp)
LET record$(tmp)=""
DO
SET CURSOR 5,5
PRINT "Composer: "
SET CURSOR 6,5
PRINT "Title: "
SET CURSOR 7,5
PRINT "Comment: "
SET CURSOR 5,14
LINE INPUT prompt "":name$
SET CURSOR 6,11
LINE INPUT prompt "":title$
SET CURSOR 7,13
LINE INPUT prompt "":comment$
CALL Yes_no
IF result = 1 then
LET line$=name$ & ":" & title$ & ":" & comment$
LET record$(tmp)=line$
LET changed=1
EXIT DO
END IF
IF result = 2 then
LET record$(tmp)=temp$
LET changed=0
EXIT DO
END IF
LOOP
END SUB
SUB ChangeColours
CLEAR
LET vkk=0
LET hkk=0
DO
PRINT
PRINT tab(5);"UP amd DOWN arrow keys change the background colour."
PRINT tab(5);"LEFT and RIGHT arrow keys change the text colours."
SET CURSOR 5,5
PRINT "Press Esc to quit."
IF kk <0 then LET kk=0
IF kk >255 then LET kk=255
GET KEY keynum
IF keynum=301 then LET vkk=vkk+1
IF keynum=302 then LET vkk=vkk-1
IF keynum=303 then LET hkk=hkk+1
IF keynum=304 then LET hkk=hkk-1
LET b=vkk
LET f=hkk
SET BACK b
SET COLOR f
CLEAR
LOOP until keynum=27
END SUB
SUB courier
LET name$ = "Courier New"
LET size = 16
LET style$ = "Plain"
CALL SetFont (name$, size, style$)
END SUB
SUB PressAnyKey
PRINT tab(38);"Press any key to continue...."
GET KEY key
END SUB
SUB load_data
LET number=1
DO while more #1
LINE INPUT #1: record$(number)
LET number=number+1
LOOP
LET number=number-1
CALL courier
SET CURSOR 18,36
IF number = 0 then
PRINT "File created ready for entries"
ELSE
PRINT number;"records loaded in memory."
END IF
SET CURSOR 20,39
CALL PressAnyKey
END SUB
SUB save_data
ERASE #1
FOR i=1 to number
PRINT #1 : record$(i)
NEXT i
CALL courier
SET CURSOR 18,36
PRINT tab(38);"File updated"
SET CURSOR 20,39
CALL PressAnyKey
END SUB
SUB mistake
PRINT ""
END SUB
END
EXTERNAL SUB SetFont (name$, size, style$)
DIM v(1)
LET v(1) = size
CALL Object (2, 0, "font name", name$, v())
CALL Object (2, 0, "font size","" , v())
CALL Object (2, 0, "font style", style$, v())
END SUB