Here it is:
*:*********************************************************************
*: Procedure file: PassCard
*: Copyright: (c) 1994, David Powell
*: Data-Train Microcomputing
*: 2824 Ironwood Drive
*: Grand Prairie, TX 75052-4218
*: (972) 988-3227
*: All rights reserved, but released to public, no
*: charge. Just keep my name on it, please, and
*: let me know of any improvements you suggest.
*: Last modified: 09/10/94
*: Purpose: An animated "passcard" for password identification.
*: Platform: DOS only
*: Notes: Recommend changing the name of the Security files
*: to discourage tampering. This is a _DOS procedure
*: because of the high-ASCII characters and FILL TO
*: commands.
*: Calls: CtrGet()
*: : GetMsg()
*: : PassWord
*: Uses: Secure.DBF which it will create, but you will
*: CDX files: Secure.CDX have to populate it. Make a screen.
*:*********************************************************************
PROC PassCard
PUBL gcId, gcPw, gcFull
PRIV ALL LIKE j*
DEFI WIND wGetMsg FROM 23,00 TO 23,79 NONE
DEFI WIND wPass FROM 00,00 TO 16,21 NONE
STOR "" TO gcId, gcPw, gcFull
jcConf = SET("CONFIRM")
jcCurs = SET("CURSOR")
jcEsc = SET("ESCAPE")
jcTalk = SET("TALK")
jnSel = SELE()
IF ! FILE("Secure.DBF") && Here's the structure
CREATE TABLE Secure ;
( name C(5), password C(9), salute C(10), ;
fullname C(30), rights C(250) )
INDE ON name TAG name
ENDI
IF USED("Secure")
SELE Secure
ELSE
SELE 0
USE Secure
ENDI
SET ORDE TO name
SET TALK OFF
SET ESCA ON
SET CURS ON
SET CONF ON
ON ESCA QUIT && Don't want to play? Get out.
DIME acard[7] && Passcard display array
acard[1] = " "+CHR(213)+REPL(CHR(205),12)+CHR(184)+" "
acard[2] = " "+CHR(179)+" "+DTOC(DATE())+" "+CHR(179)+" "
acard[3] = " "+CHR(179)+" "+TIME() +" "+CHR(179)+" "
acard[4] = " "+CHR(195)+REPL(CHR(196),12)+CHR(180)+" "
acard[5] = " "+CHR(179)+" Your ID? "+CHR(179)+" "
acard[6] = " "+CHR(179)+" "+CHR(179)+" "
acard[7] = " "+CHR(212)+REPL(CHR(205),12)+CHR(190)+" "
ACTI WIND wPass
MOVE WIND wPass TO 03,30 CENTER && FP2.0 didn't have CENTER
FOR j = 1 TO 7
@ j,02 SAY REPL(CHR(219),16)
NEXT
FOR j = 8 TO 15
@ j,00 SAY REPL(CHR(219),20)
NEXT
@ 08,20 SAY CHR(220)
FOR j = 9 TO 15
@ j,20 SAY CHR(219)
NEXT
@ 16,01 SAY REPL(CHR(223),20)
@ 08,00 FILL TO 15,19 COLO BR/B && FPW ignores FILL TO
FOR i = 1 TO 7
@ i,02 SAY acard[i] COLO B/W
NEXT
FOR i = 8 TO 16
@ i,20 FILL TO i,20 COLO N/B
NEXT
@ 16,01 FILL TO 16,20 COLO N/B
DO WHIL .T.
FOR i = 1 TO 3
isHere = .F.
STOR "" TO gcId, gcFull, lcGotIt
@ 08,01 SAY SPAC(18) COLO N/BG
@ 06,04 SAY SPAC(12) COLO N/W
=CtrGet(@gcId,06,04,12)
gcId = UPPE(gcId)
isHere = SEEK(gcId,"Secure")
IF isHere
lcGotIt = Secure.password
gcFull = ALLT(Secure.fullname)
EXIT
ENDI
@ 08,01 SAY " I don't know you " COLO N/BG
=INKE(.5)
NEXT
SET ESCA OFF
aCard[6] = PADC(gcId,16)
FOR j = 1 TO 7
@ j,02 SAY SPAC(16) COLO W/B
FOR i = 1 TO 7 - j
@ j+i,02 SAY aCard[i] COLO B/W
NEXT
=INKE(.05)
NEXT
ACTI SCRE
=GetMsg("Input your password now")
SET ESCA OFF
ACTI WIND wPass
@ 10,03 TO 12,16 COLO BG+/BR
@ 11,05 SAY SPAC(10)
gcPw = ""
DO password WITH gcPw, 10
DEAC WIND wGetMsg
IF ALLT(UPPE(gcPw)) = ALLT(UPPE(lcGotIt))
EXIT
ELSE
@ 08,01 SAY " Please try again " COLO N/BG
=INKE(.05)
gcPw = ""
aCard[6] = " "+CHR(179)+" "+CHR(179)+" "
FOR i = 10 TO 12
@ i,03 SAY SPAC(14) COLO BG+/BR
NEXT
FOR j = 8 TO 1 STEP -1
FOR i = 8 - j TO 1 STEP -1
@ j+i-1,02 SAY aCard[i] COLO B/W
NEXT
=INKE(.05)
NEXT
ENDI
ENDD
FOR i = 10 TO 12
@ i,03 SAY SPAC(14) COLO N/BR
NEXT
@ 11,06 SAY "Welcome!" COLO BG+/RB
gcWhen = IIF(LEFT(TIME(),2)<"12","Morning", ;
IIF(LEFT(TIME(),2)<"18","Afternoon","Evening"))
@ 13,03 SAY PADC("Good "+gcWhen,14) COLO BG+/RB
@ 14,03 SAY PADC(ALLT(salute),14) COLO BG+/RB
=INKE(2) && Adjust delay, if needed
RELE WIND wPass && Let's return the environment
SET TALK &jcTalk
SET ESCA &jcEsc
SET CONF &jcConf
SET CURS &jcCurs
SELE (jnSel)
RELE ALL LIKE j*
=SYS(12) && Free up some memory
RETU && EOP: PassCard
*!*********************************************************************
*! Function: CtrGet()
*! Called by: PassCard.PRG
*! Purpose: Centers the user's input on the designated coordinates
*!*********************************************************************
FUNC CtrGet
PARA lcRetVal, lnRow, lnCol, lnWid
PRIV lcRetVal, lnKey, lnRow, lnCol, lnWid, lnC
PUSH KEY CLEA
lnKey = 32 && Seed lnKey for loop
lnC = lnCol + INT(lnWid/2) -1
DO WHIL lnKey != 13 AND lnKey != 27 && Accept until ENTER is pressed
lnKey = INKE(0)
DO CASE
CASE lnKey = 27
QUIT && Escape?! OK, fine.
CASE ISAL(CHR(lnKey)) OR (lnKey >= 32 AND lnKey <= 126)
lcRetVal = lcRetVal + CHR(lnKey)
CASE lnKey = 19 OR lnKey = 127 OR lnKey = 7
lcRetVal = SUBS(lcRetVal,1,LEN(lcRetVal)-1)
ENDC
IF LEN(lcRetVal) >= lnWid
lnKey = 13
ENDI
@ lnRow,lnCol SAY PADC(lcRetVal,lnWid) COLO R/W
ENDD
POP KEY
RETU lcRetVal && EOF: CtrGet()
*!***********************************************************************
*! Procedure: PassWord
*! Called by: PassCard
*!***********************************************************************
PROC PassWord
PARA gcPw, lnWid
PRIV lnWid, lnKey
SET ESCA ON
PUSH KEY CLEA
IF PARA() < 2 && If no width passed,
lnWid = 9 && use password length of 9
ENDI
lnKey = 0
@ 11,05 SAY ""
DO WHIL lnKey != 13 AND lnKey != 27 && Accept until ENTER or ESC
lnKey = INKE(0)
DO CASE
CASE lnKey = 27
QUIT
CASE ISAL(CHR(lnKey)) OR (lnKey >= 32 AND lnKey <= 126)
gcPw = gcPw + CHR(lnKey)
CASE lnKey = 19 OR lnKey = 127 OR lnKey = 7
gcPw = SUBS(gcPw,1,LEN(gcPw)-1)
ENDC
IF LEN(gcPw) >= lnWid
lnKey = 13
ENDI
@ 11,05 SAY PADC(REPL(CHR(02),LEN(gcPw)),10)
ENDD
POP KEY
RETU gcPw && EOP: PassWord
*!*********************************************************************
*! Function: GetMsg
*! Author: David Powell, 26-May-1994
*! Purpose: Replacement for MESS clause of GET in order to
*! standardize the colors and placement of the text
*!*********************************************************************
FUNC GetMsg
PARA lcMsg
IF ! WEXI("wGetMsg")
DEFI WIND wGetMsg FROM 23,00 TO 23,79 NONE
ENDI
IF ! EMPT(lcMsg)
ACTI WIND wGetMsg
@ 00,00 SAY PADC(lcMsg,80) COLO N/BG
ENDI
RETU .T. && EOF: GetMsg()
-------------------------------------------------------------------
I admit, it could be better commented. But, you get the idea, right?
David in Dallas.
--- Maximus/2 3.01
---------------
* Origin: * MacSavvy OS/2 BBS * Dallas, Texas * 972-250-4479 * (1:124/1208)
|