Shareware Overload/ShartewareOverload.cdr/database/dgenius.zip/DGENI001.PRG

Text File | 1987-01-31 | 13KB | 609 lines

* System....: dGENIUS
* Program...: dGENI001.prg
* Date......: 01/26/87
* Version...: 1.0(x4)
* Author....: Brian Corll
* Notes.....: This is the database maker procedure file.


Procedure Get_title

Public dbfname
clear
set colo to gr+/n,w/b+
set safe off
set scor on
set conf on
set talk off



dbfname=space(8)

@ 1,0 say "This program allows you to create a new database file ;
quickly and easily."
@ 3,0 say "You will begin by giving your database file a name."
@ 5,0 say "The name can be no more than eight letters long."
@ 7,0 say "Enter the name here:" get dbfname picture "!!!!!!!!"
read

if dbfname="        "
   do while dbfname="        "
    set colo to r+/n
    ? chr(7),chr(7)
    @ 7,0 say "Please ENTER A NAME!:" get dbfname picture "!!!!!!!!"
    read
  enddo while dbfname="        "
endif dbfname="        "


sayname=trim(dbfname)
set colo to gr+/n,w/b+

@ 9,0 say "The name you have chosen for your database file is "+sayname+" ."
yesno=space(1)
@ 11,0 say "Is this name correct? (Y or N)" get yesno picture "!"
read


if yesno="N"
clear
 do while yesno="N"
  dbfname=space(8)
  @ 7,0 say "Enter the correct name here:" get dbfname picture "!!!!!!!!"
  read
  sayname=trim(dbfname)
  @ 9,0 say "The new name for your database file is "+sayname+" ."
  @ 11,0 say "Is this name correct? (Y or N)" get yesno picture "!"
  read
  if yesno="Y"
  return
  else
  loop
  endif yesno="Y"
 enddo while yesno="N"
else
return
endif yesno="N"


Procedure Fields

Parameters dbfname

clear
use skeleton
zap

Public no_fields
no_fields=0


@ 1,0 say "How many items do you want to be in each record"
@ 3,0 say "in your database file? (The maximum is 128.)" get no_fields ;
picture "@Z 999" range 1,128
read

a=0


do while a<=no_fields
mname=space(10)

a=a+1
if a>no_fields
     return
else
endif a>no_fields


mlen=0
mdec=0

append blank
zz=ltrim(str(no_fields))

clear
@ 1,0 say "FIELD NUMBER "+ltrim(str(a))+" of "+zz+" fields."
@ 2,0 say "Enter a name (10 spaces or less) for this item:" get mname ;
picture "!!!!!!!!!!"
set colo to r+/n
@ 3,0 say "There may not be any spaces in the name."
@ 4,0 say "The name must begin with a letter."
read
@ 4,0 clear
set colo to g+/n
@ 4,0 say "VERIFYING ENTRY....."
set colo to gr+/n,w/b+
if .not. isalpha(substr(mname,1,1))
   do while .not. isalpha(substr(mname,1,1))
   ? chr(7)
   @ 3,0 clea to 4,79
   mname=space(10)
   @ 3,0 say "THE FIRST CHARACTER OF THE NAME MUST BE A LETTER!"
   set colo to gr+/n,w/b+
   @ 4,0 say "Enter the name again:" get mname picture "!!!!!!!!"
   read
   enddo while .not. isalpha(substr(mname,1,1))
else
endif .not. isalpha(substr(mname,1,1))

lm=len(trim(mname))
x=1
do while x<=lm
   if x<lm .and. substr(mname,x,1)=" " .and. substr(mname,x+1,1)<>" "
      do while x<lm .and. substr(mname,x,1)=" " .and. substr(mname,x+1,1)<>" "
      ? chr(7)
      @ 3,0 clea to 4,79
      set colo to r+/n
      @ 3,0 say trim(upper(mname))+":CHARACTER NUMBER "+ltrim(str(x))+" IS BLANK!"
      mname=space(10)
      set colo to gr+/n,w/b+
      @ 4,0 say "Enter the name again:" get mname picture "!!!!!!!!"
      read
      x=x+1
      enddo
  else
  x=x+1
  endif
if x>lm
exit
else
endif
enddo while x<=lm



@ 3,0 clear
@ 4,0 clear
set colo to r+/n
@ 3,0 say "The field name is "+trim(mname)+"."
aok=space(1)
set colo to gr+/n,w/b+
@ 4,0 say "Is this field name correct? (Y or N)" get aok picture "!"
read
if aok="Y"
repl field_name with mname
else
do while aok="N"
newname=space(10)
@ 4,0 clear
@ 4,0 say "Enter correct name:" get newname picture "!!!!!!!!!!"
read
@ 3,0 clear to 4,79
set colo to r+/n
@ 3,0 say "The field name is "+trim(newname)+"."
@ 4,0 say "Is this name correct now?" get aok picture "!"
read
if aok="Y"
repl field_name with newname
exit
else
loop
endif
enddo while aok="N"
endif aok="Y"


chosen=space(1)
set colo to gr+/n,w/b,*r
@ 4,0 clear
@ 4,0 say "What type of information do you want to be in this field?"
@ 5,5 say "1. Character-alphabetic or any other characters."
@ 6,5 say "2. Numeric-numbers with or without decimal places."
@ 7,5 say "3. Logical-yes or no(Y or N), true or false (T or F)"
@ 8,5 say "4. Date-always select this type for any date field!"
@ 9,5 get chosen picture "9"
@ 9,7 say "<<Enter Selection"
read

do case

case chosen="1"
repl field_type with "C"
@ 12,0 say "How many spaces do you need for the information in this field?"
@ 13,0 say "Enter a number between 1 and 254:"get mlen ;
picture "@Z 999" range 1,254
read
repl field_len with mlen

case chosen="2"
repl field_type with "N"
@ 12,0 say "How many spaces do you need for the information in this field?"
@ 14,0 say "Include any decimal places and the decimal point."
@ 16,0 say "Enter a number between 1 and 19:" get mlen ;
picture "@Z 99" range 1,19
read
firstans=space(1)
@ 18,0 say "Do you want decimal places in this number (Y or N)?" get firstans ;
picture "!"
read

if firstans="Y"
@ 20,0 say "How many decimal places do you want?"
@ 22,0 say "Enter a number between 1 and 15:" get mdec ;
picture "@Z 99" range 1,15
read
repl field_dec with mdec
repl field_len with mlen
else
repl field_len with mlen
endif

case chosen="3"
repl field_type with "L"
repl field_len with 1

case chosen="4"
repl field_type with "D"
repl field_len with 8

otherwise
? chr(7)
aa=1
do while aa<=20
set colo to r+/n
@ 11,5 say "INVALID NUMBER! TRY AGAIN!"
aa=aa+1
if aa>20
set colo to gr+/n,w/b+
exit
else
endif
enddo

endcase
enddo while a<=no_fields

Procedure Structure

 clear
 store reccount() to rec1
  go top
 a=0
 x=2

 do while a<=rec1 .and. x<=23
 a=a+1
 x=x+1
 if rec1>20
    @ 1,0 say "There are too many fields in your database file to display"
    @ 2,0 say "on the screen. I'll print them out for you."
    @ 3,0 say "Please be sure that the printer is ready."
    wait
    set prin on
    rn=0

    do while .not.eof()
       rn=rn+1
       ?        "Name of Field          Length of Field     Type of Field      Decimal Places"
       ? space(5)+ltrim(str(rn))+space(3)+field_name+space(3)+field_len+space(3)+field_type+space(3)+field_dec
       skip
    enddo
    clear
    yesno=space(1)
    @ 1,0 say "Are all fields correct? (Y/N)" get yesno picture "!"
    read
    if yesno="N"
    do while yesno="N"

    which_one=0
    @ 2,0 say "Which field is incorrect?" get which_one range 1,rec1
    read
    go which_one
    clea
    @ 1,0 say "Name of Field"
    @ 1,15 say "Length of Field"
    @ 1,35 say "Type of Field"
    @ 1,55 say "Decimal Places"
    @ 2,0 get field_name
    @ 2,15 get field_len
    @ 2,35 get field_type picture "!"
    if field_type="C"
    @ 2,36 say "(haracter)"
    endif
    if field_type="N"
    @ 2,36 say "(umeric)"
    endif
    if field_type="L"
    @ 2,36 say "(ogical)"
    endif
    if field_type="M"
    @ 2,36 say "(emo)"
    endif
    if field_type="D"
    @ 2,36 say"(ate)"
    endif
    @ 3,15 say "Options:"
    @ 4,15 say "C(haract.)-1 to 254"
    @ 5,15 say "N(umeric)-1 to 19"
    @ 3,35 say "Options:"
    @ 4,35 say "C(haracter)"
    @ 5,35 say "N(umeric)"
    @ 6,35 say "D(ate)"
    @ 7,35 say "L(ogical)"
    @ 8,35 say "M(emo)"
    @ 2,55 get field_dec
    @ 3,55 say "Options:"
    @ 4,55 say "1 to 16 spaces"
    read

   if field_type="N" .and. field_len>19
    do while field_len>19
     ? chr(7)
     @ 4,15 clear
     @ 5,15 clea
     set colo to r+/n,w/r
     @ 4,15 say "Length of Field must be less than or equal"
     @ 5,15 say "to 19 if type of field is N(umeric)!"
     @ 2,15 get field_len
     read
    enddo
   endif field_type="N" .and. field_len>19

   if field_type="C" .and. field_len>254
    do while field_len>254
     ? chr(7)
     @ 4,15 clear
     @ 5,15 clear
     set colo to r+/n,w/r
     @ 4,15 say "Length of Field must be less than or equal"
     @ 5,15 say "to 254 if Type of Field is C(haracter)!"
     @ 2,15 get field_len
     read
    enddo while field_len>254
  endif field_type="C" .and. field_len>254

  if field_type="D"
   repl field_len with 8
  endif field_type="D"

  if field_type="L"
   repl field_len with 1
  endif field_type="L"

  if field_type="M"
   repl field_len with 10
  endif field_type="M"

  @ 24,0 say "Is this structure correct? (Y/N)" get yesno picture "!"
  read
  if yesno="Y"
   do exit with dbfname
  endif

  if yesno="N"
  loop
  endif

 enddo while yesno="N"
 endif yesno="N"


else
endif rec1>20

 @ 1,0 say "Here is the completed structure of the "+dbfname ;
+" database file."
 set colo to g+/n
 @ 2,0 say "Name of Field"
 @ 2,15 say "Length of Field"
 @ 2,35 say "Type of Field"
 @ 2,55 say "Decimal Places"

set colo to gr+/n,w/b+
 @ x,0 say ltrim(str(a))+". "+field_name
 @ x,15 say field_len

 if field_type="C"
 @ x,35 say "Character"
 endif field_type="C"


 if field_type="N"
 @ x,35 say "Numeric"
 @ x,55 say field_dec
 endif field_type="N"

 if field_type="D"
 @ x,35 say "Date"
 endif field_type="D"

 if field_type="L"
 @ x,35 say "Logical"
 endif field_type="L"

 if field_type="M"
 @ x,35 say "Memo"
 endif field_type="M"

 if a=rec1
 exit
 else
 skip
 endif a=rec1


enddo while a<=rec1 .and. x<=23


thirdans=space(1)
@ 24,0 say "Is this structure correct? (Y or N)" get thirdans picture "!"
read

if thirdans="Y"
   return
endif

if thirdans="N"

do while thirdans="N"

which_one=space(3)
@ 24,0 clear
@ 24,0 say "Which number is incorrect?" get which_one
read
a=val(which_one)
go a
clea
@ 1,0 say "Name of Field"
@ 1,15 say "Length of Field"
@ 1,35 say "Type of Field"
@ 1,55 say "Decimal Places"
@ 2,0 get field_name
@ 2,15 get field_len
@ 2,35 get field_type picture "!"
  if field_type="C"
  @ 2,36 say "(haracter)"
  endif
  if field_type="N"
  @ 2,36 say "(umeric)"
  endif
  if field_type="L"
  @ 2,36 say "(ogical)"
  endif
  if field_type="M"
  @ 2,36 say "(emo)"
  endif
  if field_type="D"
  @ 2,36 say"(ate)"
  endif
@ 3,15 say "Options:"
@ 4,15 say "C(haract.)-1 to 254"
@ 5,15 say "N(umeric)-1 to 19"
@ 3,35 say "Options:"
@ 4,35 say "C(haracter)"
@ 5,35 say "N(umeric)"
@ 6,35 say "D(ate)"
@ 7,35 say "L(ogical)"
@ 8,35 say "M(emo)"
@ 2,55 get field_dec
@ 3,55 say "Options:"
@ 4,55 say "1 to 16 spaces"
read

if field_type="N" .and. field_len>19
   do while field_len>19
   ? chr(7)
   @ 4,15 clear
   @ 5,15 clea
   set colo to r+/n,w/r
   @ 4,15 say "Length of Field must be less than or equal"
   @ 5,15 say "to 19 if type of field is N(umeric)!"
   @ 2,15 get field_len
   read
   enddo
endif field_type="C" .and. field_len>254

if field_type="C" .and. field_len>254
   do while field_len>254
   ? chr(7)
   @ 4,15 clear
   @ 5,15 clear
   set colo to r+/n,w/r
   @ 4,15 say "Length of Field must be less than or equal"
   @ 5,15 say "to 254 if Type of Field is C(haracter)!"
   @ 2,15 get field_len
   read
   enddo while field_len>254
endif field_type="C" .and. field_len>254

if field_type="D"
   repl field_len with 8
endif field_type="D"

if field_type="L"
   repl field_len with 1
endif field_type="L"

if field_type="M"
   repl field_len with 10
endif field_type="M"

clea
go top


@ 1,0 say "Here is the completed structure of the "+dbfname ;
+" database file."
set colo to gr+/n,w/b

@ 2,0 say "Name of Field"
@ 2,15 say "Length of Field"
@ 2,35 say "Type of Field"
@ 2,55 say "Decimal Places"

a=0
x=2
rec1=reccount()

do while a<=rec1 .and. x<=23

 a=a+1
 x=x+1
 @ x,0 say ltrim(str(a))+". "+field_name
 @ x,15 say field_len
  if field_type="C"
   @ x,35 say "Character"
  endif
  if field_type="N"
   @ x,35 say "Numeric"
   @ x,55 say field_dec
  endif
  if field_type="D"
   @ x,35 say "Date"
  endif
  if field_type="L"
   @ x,35 say "Logical"
  endif
  if field_type="M"
   @ x,35 say "Memo"
  endif
skip
if eof()
exit
else
endif
enddo while a<=rec1 .and. x<=23

thirdans=space(1)
@ 24,0 say "Are all fields correct now? (Y/N)" get thirdans picture "!"
read
 if upper(thirdans)="N"
  loop
 else
 exit
 endif
enddo while thirdans="N"
return


Procedure Exit
Parameters dbfname

@ 23,0 clea to 24,79
set colo to r+/n
@ 24,0 say "Just a moment....."
create &dbfname from skeleton
clos data

clear
set colo to bg+/n
@ 1,0 say "Place a diskette in drive A."
@ 3,0 say "I'll make a copy of your database file."
wait "Press any key when you're ready...."
newname=trim(dbfname)
run copy c:\dbase\&newname..dbf a:/v
run del c:\dbase\&newname..dbf

clear
set defa to e
set colo to g+/n
@ 1,0 say "Copy has been completed and verified."
wait "Press any key to return to dGENIUS."
return