home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Shareware Overload
/
ShartewareOverload.cdr
/
database
/
dba1286.zip
/
DEMO.PRG
< prev
next >
Wrap
Text File
|
1986-11-04
|
3KB
|
146 lines
*Filename: demo.PRG
*Program:
*Author:J. Ari Kornfeld
*Date :2-11-86
*Notes :Uses files: DEMO.DBF, DEMO.NTX, HELP.DBF, HELP.NTX
* CONSTANT DEFINITIONS
* SpecExit = PgUp, PgDn, ^PgUp, ^PgDn, Esc
SpecExit = CHR(18)+CHR(3)+CHR(31)+CHR(30)+CHR(27)
Esc = CHR(27)
* frame for a window (and it fills the window with blanks)
frame = CHR(201)+CHR(205)+CHR(187)+CHR(186)+CHR(188)+CHR(205)+CHR(200);
+CHR(186)+" "
* Standard colors: Normal, Help, Error and RO (Read-Only fields)
* NormHilite set the non-hi color to imitate the hilite color
NormColor = "W+/ , /W"
NormHilite = " /W"
HelpColor = "GR+"
ErrorColor = "BG+"
ROColor = "B+"
FrameColor = "R+"
SET DELETED ON
SET EXACT ON
SET COLOR TO &NormColor
SET CONFIRM ON
SET BELL OFF
USE Demo INDEX Demo ALIAS Names
DO DispSay
Mparcel = 99999
Mparcel = Mparcel + 1
Msupplier = SPACE(LEN(Names->id))
Mdate = DATE()
Mquantity = 0
Mweight = 0.00
DO DispGet
READ
RETURN
PROCEDURE DispSay
CLEAR
@ 2,47 SAY "Parcel No.:"
@ 3,8 SAY "Supplier's ID Code:"
@ 5,8 SAY "Company Name:"
@ 6,8 SAY "Address:"
@ 9,43 SAY "Date Received:"
@ 10,8 SAY "Quantity:"
@ 12,8 SAY "Weight:"
@ 12,43 SAY "Average Weight:"
RETURN
PROCEDURE DispSay2
PRIVATE lastcol, color
* Company info
SET COLOR TO &NormHilite
@ 3,30 SAY Names->id
SET COLOR TO &ROcolor
@ 5,24 SAY Names->company
@ 6,24 SAY Names->address
lastcol = COL()
@ 7,24 SAY TRIM(Names->city)+", "+TRIM(Names->state)+" "+TRIM(names->zip);
+" "+TRIM(names->country)
IF COL() < lastcol
@7,COL() SAY SPACE(lastcol - COL())
ENDIF
SET COLOR TO &NormColor
@ 7,COL()
RETURN
PROCEDURE DispGet
SET COLOR TO &ROcolor
@ 2,61 SAY Mparcel PICTURE "999999"
SET COLOR TO &NormColor
@ 3,30 GET Msupplier PICTURE "@!" VALID ValSup()
@ 9,59 GET Mdate
@ 10,19 GET Mquantity VALID ValQuan(Mquantity)
@ 12,19 GET Mweight PICTURE "@Z" VALID ValAveW(Mweight, Mquantity)
RETURN
FUNCTION ValSup
PRIVATE ok
IF LEN(TRIM(Msupplier)) = 0
SET COLOR TO &FrameColor
SAVE SCREEN
@1,38, 4,70 BOX frame
SET COLOR TO &ErrorColor
@2,40 SAY " This field must be filled."
@3,40 SAY "Press any key to continue."
DO WHILE INKEY() = 0
ENDDO
RESTORE SCREEN
SET COLOR TO &NormColor
ok = .f.
ELSE
SEEK Msupplier
IF EOF()
DO CloseMat WITH Msupplier, [DispSay2], [c:demo.ntx]
Msupplier = id
ENDIF
DO DispSay2
ok = IF(LASTKEY() = 27, .F., .T.)
ENDIF
RETURN (ok)
FUNCTION ValQuan
PARAMETER Mquantity
PRIVATE ok
IF Mquantity < 1 .OR. Mquantity > 99
SET COLOR TO &FrameColor
SAVE SCREEN
@1,38, 4,70 BOX frame
SET COLOR TO &ErrorColor
@2,40 SAY " RANGE: 1 to 99"
@3,40 SAY "Press any key to continue."
DO WHILE INKEY() = 0
ENDDO
RESTORE SCREEN
SET COLOR TO &NormColor
ok = .f.
ELSE
ok = .t.
ENDIF
RETURN (ok)
FUNCTION ValAveW
PARAMETERS Mweight, Mquantity
PRIVATE ok
DO CASE
CASE Mweight < 0.01 .or. Mweight > 999.99
SET COLOR TO &FrameColor
SAVE SCREEN
@1,38, 4,70 BOX frame
SET COLOR TO &ErrorColor
@2,40 SAY " RANGE: 0.01 to 999.99"
@3,40 SAY "Press any key to continue."
DO WHILE INKEY() = 0
ENDDO
RESTORE SCREEN
ok = .f.
OTHERWISE
SET COLOR TO &ROcolor
@12,59 SAY Mweight/Mquantity PICTURE "999.99"
ok = .t.
ENDCASE
SET COLOR TO &NormColor
RETURN (ok)