Este outro exemplo pare ser melhor
#include "inkey.ch"
#include "getexit.ch"
#translate :cValor => :cargo\[1\]
#translate :nPos => :cargo\[2\]
#translate :nLen => :cargo\[3\]
#translate :nDec => :cargo\[4\]
#translate :nPLen => :cargo\[5\]
#translate :nPDec => :cargo\[6\]
#define _GET_INSERT_ON ""
#define _GET_INSERT_OFF ""
#define _GET_INVD_DATE 9
#define _GET_RANGE_FROM 10
#define _GET_RANGE_TO 11
#define K_UNDO K_CTRL_U
STATIC sbFormat
STATIC slUpdated := .F.
STATIC slKillRead
STATIC slBumpTop
STATIC slBumpBot
STATIC snLastExitState
STATIC snLastPos
STATIC soActiveGet
STATIC scReadProcName
STATIC snReadProcLine
STATIC Vinicio
STATIC Tecla
#define GSV_KILLREAD 1
#define GSV_BUMPTOP 2
#define GSV_BUMPBOT 3
#define GSV_LASTEXIT 4
#define GSV_LASTPOS 5
#define GSV_ACTIVEGET 6
#define GSV_READVAR 7
#define GSV_READPROCNAME 8
#define GSV_READPROCLINE 9
#define GSV_COUNT 9
********************************
FUNCTION ReadModal(GetList,nPos)
********************************
LOCAL oGet
LOCAL aSavGetSysVars
IF ( VALTYPE( sbFormat ) == "B" )
EVAL( sbFormat )
ENDIF
IF (EMPTY(GetList))
SETPOS( MAXROW() - 1, 0 )
RETURN (.F.)
ENDIF
aSavGetSysVars := ClearGetSysVars()
scReadProcName := PROCNAME( 1 )
snReadProcLine := PROCLINE( 1 )
IF !( VALTYPE( nPos ) == "N" .AND. nPos > 0 )
nPos := Settle( Getlist, 0 )
ENDIF
WHILE !( nPos == 0 )
PostActiveGet( oGet := GetList[ nPos ] )
IF ( VALTYPE( oGet:reader ) == "B" )
EVAL( oGet:reader, oGet )
ELSE
GetReader( oGet )
ENDIF
nPos := Settle( GetList, nPos )
ENDDO
RestoreGetSysVars( aSavGetSysVars )
SETPOS( MAXROW() - 1, 0 )
RETURN ( slUpdated )
***************************
PROCEDURE GetReader( oGet )
***************************
LOCAL bApplyKey
IF ( GetPreValidate( oGet ) )
oGet:setFocus()
IF oGet:type == "N"
IF EMPTY( oGet:picture )
oGet:picture = "9999999999"
ENDIF
oGet:cargo = ARRAY( 6 )
CalcLenNum( oGet )
GetCalcImp( oGet )
bApplyKey := { | oGet | GetCalcApplyKey( oGet, Test_ink() ) }
ELSE
bApplyKey := { | oGet | GetApplyKey( oGet, Test_ink() ) }
ENDIF
WHILE ( oGet:exitState == GE_NOEXIT )
IF ( oGet:typeOut )
oGet:exitState := GE_ENTER
ENDIF
WHILE ( oGet:exitState == GE_NOEXIT )
EVAL( bApplyKey, oGet )
ENDDO
IF ( !GetPostValidate( oGet ) )
oGet:exitState := GE_NOEXIT
IF oGet:type == "N"
GetCalcImp( oGet )
ENDIF
ENDIF
ENDDO
oGet:killFocus()
ENDIF
RETURN
**************************
static function test_ink()
**************************
local tecla:=0
tecla:=inkey(3)
Return(tecla)
***********************************
PROCEDURE GetApplyKey( oGet, nKey )
***********************************
LOCAL cKey
LOCAL bKeyBlock
LOCAL dData
IF !( ( bKeyBlock := setkey( nKey ) ) == NIL )
GetDoSetKey( bKeyBlock, oGet )
RETURN
ENDIF
DO CASE
CASE ( nKey == K_UP )
oGet:exitState := GE_UP
CASE ( nKey == K_SH_TAB )
oGet:exitState := GE_UP
CASE ( nKey == K_DOWN )
oGet:exitState := GE_DOWN
CASE ( nKey == K_TAB )
oGet:exitState := GE_DOWN
CASE ( nKey == K_ENTER )
oGet:exitState := GE_ENTER
CASE ( nKey == K_ESC )
IF ( SET( _SET_ESCAPE ) )
oGet:undo()
oGet:exitState := GE_ESCAPE
ENDIF
CASE ( nKey == K_PGUP )
oGet:exitState := GE_WRITE
CASE ( nKey == K_PGDN )
oGet:exitState := GE_WRITE
CASE ( nKey == K_CTRL_HOME )
oGet:exitState := GE_TOP
CASE ( nKey == K_CTRL_END )
oGet:exitState := GE_BOTTOM
CASE ( nKey == K_INS )
SET( _SET_INSERT, !SET( _SET_INSERT ) )
ShowScoreboard()
CASE ( nKey == K_UNDO )
oGet:undo()
CASE ( nKey == K_HOME )
oGet:home()
CASE ( nKey == K_END )
oGet:end()
CASE ( nKey == K_RIGHT )
oGet:right()
CASE ( nKey == K_LEFT )
oGet:left()
CASE ( nKey == K_CTRL_RIGHT )
oGet:wordRight()
CASE ( nKey == K_CTRL_LEFT )
oGet:wordLeft()
CASE ( nKey == K_BS )
oGet:backSpace()
CASE ( nKey == K_DEL )
oGet:delete()
CASE ( nKey == K_CTRL_T )
oGet:delWordRight()
CASE ( nKey == K_CTRL_Y )
oGet:delEnd()
CASE ( nKey == K_CTRL_BS )
oGet:delWordLeft()
OTHERWISE
IF ( nKey >= 32 .AND. nKey <= 255 )
cKey := CHR( nKey )
//inicio mudanca picture @m
IF !EMPTY(oGet:picture)
IF AT("@M",Upper(oGet:picture))>0
cKey := LOWER( cKey )
ENDIF
ENDIF
//Fim mudanca Picture @m
IF ( oGet:type == "N" .AND. ( cKey == "." .OR. cKey == "," ) )
oGet:toDecPos()
ELSEIF ( oGet:type == "D" .AND. ( cKey == "+" .OR. cKey == "-" ) )
dData := oGet:varGet()
IF EMPTY( dData )
dData = DATE()
ENDIF
IF cKey == "+"
oGet:varPut( dData+1 )
ELSE
oGet:varPut( dData-1 )
ENDIF
oGet:updateBuffer()
ELSE
IF ( SET( _SET_INSERT ) )
oGet:insert( cKey )
ELSE
oGet:overstrike( cKey )
ENDIF
IF ( oGet:typeOut )
IF ( SET( _SET_BELL ) )
?? CHR(7)
ENDIF
IF ( !SET( _SET_CONFIRM ) )
oGet:exitState := GE_ENTER
ENDIF
ENDIF
ENDIF
ENDIF
ENDCASE
RETURN
*****************************
FUNCTION GetPreValidate(oGet)
*****************************
LOCAL lSavUpdated,lWhen:=.T.
IF ! (oGet:preBlock==NIL)
lSavUpdated := slUpdated
lWhen := EVAL( oGet:preBlock, oGet )
oGet:display()
ShowScoreBoard()
slUpdated := lSavUpdated
ENDIF
IF ( slKillRead )
lWhen := .F.
oGet:exitState := GE_ESCAPE
ELSEIF ( !lWhen )
oGet:exitState := GE_WHEN
ELSE
oGet:exitState := GE_NOEXIT
END
RETURN ( lWhen )
******************************
FUNCTION GetPostValidate(oGet)
******************************
LOCAL lSavUpdated
LOCAL lValid := .T.
IF ( oGet:exitState == GE_ESCAPE )
RETURN ( .T. )
ENDIF
IF ( oGet:badDate() )
oGet:home()
DateMsg()
ShowScoreboard()
RETURN ( .F. )
ENDIF
IF ( oGet:changed )
oGet:assign()
slUpdated := .T.
ENDIF
oGet:reset()
IF !( oGet:postBlock == NIL )
lSavUpdated := slUpdated
SETPOS( oGet:row, oGet:col + LEN( oGet:buffer ) )
lValid := EVAL( oGet:postBlock, oGet )
SETPOS( oGet:row, oGet:col )
ShowScoreBoard()
oGet:updateBuffer()
slUpdated := lSavUpdated
IF ( slKillRead )
oGet:exitState := GE_ESCAPE
lValid := .T.
ENDIF
ENDIF
RETURN ( lValid )
************************************
PROCEDURE GetDoSetKey(keyBlock,oGet)
************************************
LOCAL lSavUpdated
IF ( oGet:changed )
oGet:assign()
slUpdated := .T.
ENDIF
lSavUpdated := slUpdated
EVAL( keyBlock, scReadProcName, snReadProcLine, ReadVar() )
ShowScoreboard()
oGet:updateBuffer()
slUpdated := lSavUpdated
IF ( slKillRead )
oGet:exitState := GE_ESCAPE
ENDIF
RETURN
***************************************
STATIC FUNCTION Settle( GetList, nPos )
***************************************
LOCAL nExitState
IF ( nPos == 0 )
IF LASTKEY()=K_UP
nExitState := GE_UP
nPos = LEN( GetList ) + 1
ELSE
nExitState := GE_DOWN
ENDIF
ELSE
nExitState := GetList[ nPos ]:exitState
ENDIF
IF ( nExitState == GE_ESCAPE .or. nExitState == GE_WRITE )
RETURN ( 0 )
ENDIF
IF !( nExitState == GE_WHEN )
snLastPos := nPos
slBumpTop := .F.
slBumpBot := .F.
ELSE
nExitState := snLastExitState
ENDIF
DO CASE
CASE ( nExitState == GE_UP )
nPos--
CASE ( nExitState == GE_DOWN )
nPos++
CASE ( nExitState == GE_TOP )
nPos:= 1
slBumpTop:= .T.
nExitState:= GE_DOWN
CASE ( nExitState == GE_BOTTOM )
nPos:= LEN( GetList )
slBumpBot:= .T.
nExitState := GE_UP
CASE ( nExitState == GE_ENTER )
nPos++
ENDCASE
IF ( nPos == 0 )
IF ( !ReadExit() .and. !slBumpBot )
slBumpTop := .T.
nPos := snLastPos
nExitState := GE_DOWN
ENDIF
ELSEIF ( nPos == len( GetList ) + 1 ) // Bumped bottom
IF ( !ReadExit() .and. !( nExitState == GE_ENTER ) .and. !slBumpTop )
slBumpBot := .T.
nPos := snLastPos
nExitState := GE_UP
ELSE
nPos := 0
ENDIF
ENDIF
snLastExitState := nExitState
IF !( nPos == 0 )
GetList[ nPos ]:exitState := nExitState
ENDIF
RETURN ( nPos )
**************************************
STATIC PROCEDURE PostActiveGet( oGet )
**************************************
GetActive( oGet )
ReadVar( GetReadVar( oGet ) )
ShowScoreBoard()
RETURN
*********************************
STATIC FUNCTION ClearGetSysVars()
*********************************
LOCAL aSavSysVars[ GSV_COUNT ]
aSavSysVars[ GSV_KILLREAD ] := slKillRead
aSavSysVars[ GSV_BUMPTOP ] := slBumpTop
aSavSysVars[ GSV_BUMPBOT ] := slBumpBot
aSavSysVars[ GSV_LASTEXIT ] := snLastExitState
aSavSysVars[ GSV_LASTPOS ] := snLastPos
aSavSysVars[ GSV_ACTIVEGET ] := GetActive( NIL )
aSavSysVars[ GSV_READVAR ] := ReadVar( "" )
aSavSysVars[ GSV_READPROCNAME ] := scReadProcName
aSavSysVars[ GSV_READPROCLINE ] := snReadProcLine
slKillRead := .F.
slBumpTop := .F.
slBumpBot := .F.
snLastExitState := 0
snLastPos := 0
scReadProcName := ""
snReadProcLine := 0
slUpdated := .F.
RETURN ( aSavSysVars )
*************************************************
STATIC PROCEDURE RestoreGetSysVars( aSavSysVars )
*************************************************
slKillRead := aSavSysVars[ GSV_KILLREAD ]
slBumpTop := aSavSysVars[ GSV_BUMPTOP ]
slBumpBot := aSavSysVars[ GSV_BUMPBOT ]
snLastExitState := aSavSysVars[ GSV_LASTEXIT ]
snLastPos := aSavSysVars[ GSV_LASTPOS ]
GetActive( aSavSysVars[ GSV_ACTIVEGET ] )
ReadVar( aSavSysVars[ GSV_READVAR ] )
scReadProcName := aSavSysVars[ GSV_READPROCNAME ]
snReadProcLine := aSavSysVars[ GSV_READPROCLINE ]
RETURN
**********************************
STATIC FUNCTION GetReadVar( oGet )
**********************************
LOCAL cName := UPPER( oGet:name )
LOCAL i
IF !( oGet:subscript == NIL )
FOR i := 1 TO LEN( oGet:subscript )
cName += "[" + LTRIM( STR( oGet:subscript[i] ) ) + "]"
NEXT
END
RETURN ( cName )
**************************
PROCEDURE __SetFormat( b )
**************************
sbFormat := IF( VALTYPE( b ) == "B", b, NIL )
RETURN
**********************
PROCEDURE __KillRead()
**********************
slKillRead := .T.
RETURN
***********************
FUNCTION GetActive( g )
***********************
LOCAL oldActive := soActiveGet
IF ( PCOUNT() > 0 )
soActiveGet := g
ENDIF
RETURN ( oldActive )
******************
FUNCTION Updated()
******************
RETURN slUpdated
*************************
FUNCTION ReadExit( lNew )
*************************
RETURN ( SET( _SET_EXIT, lNew ) )
***************************
FUNCTION ReadInsert( lNew )
***************************
RETURN ( SET( _SET_INSERT, lNew ) )
#define SCORE_ROW 1
#define SCORE_COL 66
*********************************
STATIC PROCEDURE ShowScoreboard()
*********************************
LOCAL nRow
LOCAL nCol
IF ( SET( _SET_SCOREBOARD ) )
nRow := ROW()
nCol := COL()
SETPOS( SCORE_ROW, SCORE_COL )
DISPOUT( IF( SET( _SET_INSERT ), NationMsg(_GET_INSERT_ON),;
NationMsg(_GET_INSERT_OFF)) )
SETPOS( nRow, nCol )
ENDIF
RETURN
**************************
STATIC PROCEDURE DateMsg()
**************************
LOCAL nRow
LOCAL nCol
IF ( SET( _SET_SCOREBOARD ) )
nRow := ROW()
nCol := COL()
SETPOS( SCORE_ROW, SCORE_COL )
SETPOS( nRow, nCol )
WHILE ( NEXTKEY() == 0 )
END
SETPOS( SCORE_ROW, SCORE_COL )
SETPOS( nRow, nCol )
ENDIF
RETURN
*****************************************
FUNCTION RangeCheck( oGet, junk, lo, hi )
*****************************************
LOCAL cMsg, nRow, nCol
LOCAL xValue
IF ( !oGet:changed )
RETURN ( .T. )
ENDIF
xValue := oGet:varGet()
IF ( xValue >= lo .and. xValue <= hi )
RETURN ( .T. )
ENDIF
IF ( SET(_SET_SCOREBOARD) )
cMsg := NationMsg(_GET_RANGE_FROM) + LTRIM( TRANSFORM( lo, "" ) ) + NationMsg(_GET_RANGE_TO) + LTRIM( TRANSFORM( hi, "" ) )
IF ( LEN( cMsg ) > MAXCOL() )
cMsg := SUBSTR( cMsg, 1, MAXCOL() )
ENDIF
nRow := ROW()
nCol := COL()
SETPOS( SCORE_ROW, MIN( 60, MAXCOL() - LEN( cMsg ) ) )
DISPOUT( cMsg )
SETPOS( nRow, nCol )
WHILE ( NEXTKEY() == 0 )
END
SETPOS( SCORE_ROW, MIN( 60, MAXCOL() - LEN( cMsg ) ) )
DISPOUT( SPACE( LEN( cMsg ) ) )
SETPOS( nRow, nCol )
ENDIF
RETURN ( .F. )
**************************
FUNCTION ReadKill( lKill )
**************************
LOCAL lSavKill := slKillRead
IF ( PCOUNT() > 0 )
slKillRead := lKill
ENDIF
RETURN ( lSavKill )
********************************
FUNCTION ReadUpdated( lUpdated )
********************************
LOCAL lSavUpdated := slUpdated
IF ( PCOUNT() > 0 )
slUpdated := lUpdated
ENDIF
RETURN ( lSavUpdated )
************************
FUNCTION ReadFormat( b )
************************
LOCAL bSavFormat := sbFormat
IF ( PCOUNT() > 0 )
sbFormat := b
ENDIF
RETURN ( bSavFormat )
*************************************
procedure GetCalcApplyKey(oGet, nKey)
*************************************
local cKey
local bKeyBlock
local cTemp
local nTemp
local nf:= 0
IF (bKeyBlock := SetKey(nKey)) <> NIL
GetDoSetKey(bKeyBlock, oGet)
RETURN
ENDIF
DO CASE
CASE nKey == K_UP
oGet:exitState := GE_UP
CASE nKey == K_SH_TAB
oGet:exitState := GE_UP
CASE nKey == K_DOWN
oGet:exitState := GE_DOWN
CASE nKey == K_TAB
oGet:exitState := GE_DOWN
CASE nKey == K_ENTER
oGet:exitState := GE_ENTER
CASE nKey == K_ESC
IF Set(_SET_ESCAPE)
oGet:undo()
GetCalcImp( oGet )
oGet:exitState := GE_ESCAPE
ENDIF
CASE nKey == K_PGUP
oGet:exitState := GE_WRITE
CASE nKey == K_PGDN
oGet:exitState := GE_WRITE
CASE nKey == K_CTRL_HOME
oGet:exitState := GE_TOP
CASE nKey == K_CTRL_W
oGet:exitState := GE_WRITE
CASE nKey == K_UNDO
oGet:undo()
GetCalcImp( oGet )
CASE nKey == K_BS .OR. nKey == K_DEL .OR. nKey == K_LEFT
IF LEN( oGet:cValor ) > 1
IF At( '.', oGet:cValor ) > 0
oGet:nPos--
IF oGet:nPDec > 0
oGet:nPDec--
ENDIF
ELSE
oGet:nPLen--
ENDIF
oGet:clear = .F.
oGet:cValor = LEFT( oGet:cValor, LEN( oGet:cValor ) - 1 )
oGet:varPut( VAL( oGet:cValor ) )
oGet:buffer := Transform( oGet:varGet(), oGet:picture )
oGet:display()
SETPOS( oGet:row,oGet:nPos )
ENDIF
CASE nKey == ASC('-')
oGet:clear = .F.
IF oGet:minus
oGet:minus = .F.
oGet:nPLen--
ELSE
IF oGet:nPLen = oGet:nLen
RETURN
ENDIF
oGet:minus = .T.
oGet:nPLen++
ENDIF
oGet:varPut( IF( oGet:minus, -VAL( oGet:cValor ), VAL( oGet:cValor ) ) )
oGet:buffer := Transform( oGet:varGet(), oGet:picture )
oGet:display()
SETPOS( oGet:row,oGet:nPos )
CASE nKey == ASC('.') .OR. nKey == ASC(',')
IF oGet:nDec > 0 .AND. At( '.', oGet:cValor ) == 0
IF oGet:clear
oGet:clear = .F.
oGet:varPut( 0 )
GetCalcImp( oGet )
ENDIF
oGet:cValor += "."
oGet:nPos++
oGet:display()
SETPOS( oGet:row,oGet:nPos+1) //Daniel +1
ENDIF
OTHERWISE
IF nKey >= Asc('0') .AND. nKey <= Asc('9')
IF oGet:clear
oGet:clear = .F.
oGet:varPut( 0 )
GetCalcImp( oGet )
ENDIF
IF At( '.', oGet:cValor ) > 0
IF oGet:nPDec = oGet:nDec
RETURN
ENDIF
oGet:nPos++
oGet:nPDec++
ELSE
IF oGet:nPLen = oGet:nLen
RETURN
ELSEIF nKey == ASC('0') .AND. oGet:varGet()==0
RETURN
ENDIF
oGet:nPLen++
ENDIF
oGet:cValor += CHR( nKey )
oGet:varPut( IF( oGet:minus, -VAL( oGet:cValor ), VAL( oGet:cValor ) ) )
oGet:buffer := Transform( oGet:varGet(), oGet:picture )
oGet:display()
SETPOS( oGet:row,oGet:nPos )
ENDIF
ENDCASE
nV:= oGet:nLen
If oGet:Type = "N"
nB:= Len(Str(oGet:varget())) -2
nV+= oGet:nDec
Else
nB:= Len(Str(oGet:varget()))
EndIf
IF nV == nB
IF ( !SET( _SET_CONFIRM ) )
oGet:exitState := GE_ENTER
EndIf
ENDIF
RETURN
*********************************
STATIC procedure CalcLenNum(oGet)
*********************************
LOCAL x,nLen:=LEN( oGet:picture)
oGet:nLen := 0
oGet:nDec := 0
IF AT( '.', oGet:picture ) > 0
DO WHILE (x:=SUBSTR( oGet:picture, nLen, 1 )) != '.'
IF x == '9' .OR. x =="#" .OR. x == "*"
oGet:nDec++
ENDIF
nLen--
ENDDO
nLen--
ENDIF
DO WHILE nLen > 0
IF (x:=SUBSTR( oGet:picture, nLen, 1)) == '9' .OR. x == "#" .OR. x == "*"
oGet:nLen++
ENDIF
nLen--
ENDDO
RETURN
*********************************
STATIC procedure GetCalcImp(oGet)
*********************************
LOCAL nLen:=18
oGet:nPos = oGet:col + oGet:decPos - 2
oGet:cValor = STR( oGet:varGet(), nLen, 5 )
IF (oGet:minus := AT( '-', oGet:cValor ) > 0 )
oGet:cValor = STRTRAN( oGet:cValor, '-', ' ' )
ENDIF
DO WHILE ( nLen > 13 .AND. SUBSTR( oGet:cValor, nLen, 1 ) == '0' )
nLen--
ENDDO
IF nLen >= 13
oGet:nPDec = ( nLen - 13 )
IF nLen = 13
nLen--
ENDIF
oGet:nPos += ( nLen - 12 )
ELSE
oGet:nPDec = - 1
ENDIF
oGet:cValor = " " + LTRIM( LEFT( oGet:cValor, nLen ) )
IF AT( '.', oGet:cValor) == 0
oGet:nPLen = LEN( oGet:cValor ) - 2
ELSE
oGet:nPLen = LEN( oGet:cValor ) - oGet:nPDec - 2
ENDIF
IF oGet:minus
oGet:nPLen++
ENDIF
oGet:display()
oGet:buffer := Transform( oGet:varGet(), oGet:picture )
SETPOS( oGet:row,oGet:nPos )
RETURN