Hi Danny, I saw both your examples and noted that Clear Gets would it make a differance but only when retating GETs. So I decided to make some tests based in your indications but was not good results. Then I changed from array to variables (I never liked to used it at Gets) and also let all get together but with this time, I have include GetSys.prg (do you remember old Clipper demand for t ?). So when I have included... BINGO ! I have noted that is not necessary to call any othe function thru SETKEY and not other than include Getsys.prg. Is very good to meet here good professionals which stll keeping a good knowledge of xBase (Clipper/Harbour). And I glad to share with all of you !dhaine_adp wrote:I think its problem with GT. Below is another implementation of the sample
Here are a workable examples for CONSOLE mode:
Code: Select all
REQUEST HB_GT_WIN_DEFAULT
Function Main()
Local cItem1:=Space(5), cItem2:=SPACE(10), nItem3:=0
SETMODE ( 25, 80 )
SETCURSOR(1)
*SET SCOREBOARD OFF
SETCOLOR ( "W+/B, GR+/R, N, GR+/N, GR+/R" )
CLS
@ 0,0 SAY "Code:" get cItem1 PICTURE "@!"
@ 1,0 SAY "Description:" get cItem2 PICTURE "@!"
@ 2,0 SAY "Unit Cost:" get nItem3 PICTURE "@ZB9,999.999"
Read
Return NilCode: Select all
/***
* Getsys.prg
* Standard Clipper 5.2 GET/READ Subsystem
*
* Copyright (c) 1991-1993, Computer Associates International, Inc.
* All rights reserved.
*
* This version adds the following public functions:
* ReadKill( [] ) --> lKill
* ReadUpdated( [] ) --> lUpdated
* ReadFormat( [] ) --> bFormat | NIL
*
* NOTE: compile with /m /n /w
*/
#include "Inkey.ch"
#include "Getexit.ch"
#include "Common.ch"
/***
* Nation Message Constants
* These constants are used with the NationMsg() function.
* The parameter can range from 1-12 and returns the national
* version of the system message.
*/
#define _GET_INSERT_ON 7 // "Ins"
#define _GET_INSERT_OFF 8 // " "
#define _GET_INVD_DATE 9 // "Invalid Date"
#define _GET_RANGE_FROM 10 // "Range: "
#define _GET_RANGE_TO 11 // " - "
#define K_UNDO K_CTRL_U
//
// State variables for active READ
//
STATIC sbFormat
STATIC slUpdated := .F.
STATIC slKillRead
STATIC slBumpTop
STATIC slBumpBot
STATIC snLastExitState
STATIC snLastPos
STATIC soActiveGet
STATIC scReadProcName
STATIC snReadProcLine
//
// Format of array used to preserve state variables
//
#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
/***
*
* ReadModal()
*
* Standard modal READ on an array of GETs
*
* Esta funcao foi alterada, permitindo passar uma funcao a ser
* executada dentro do get (FFuncao) quando o usuario ficar sem
* pressionar uma tecla pelo periodo de x minutos (FInkey)
*
* Para utilizar este recurso utilize a funcao ReadModal em vez do
* comando READ da seguinte forma:
* ReadModal(GetList, 0, 'Funcao', nTempo)
* Getlist := {}
*
*/
FUNCTION ReadModal( GetList, nPos, FFuncao, FInkey )
LOCAL oGet
Local mVerValid
Local iPos
LOCAL aSavGetSysVars, MCursor := SetCursor()
If FInkey = Nil
FInkey = 1
EndIf
IF ( VALTYPE( sbFormat ) == "B" )
EVAL( sbFormat )
ENDIF
IF ( EMPTY( GetList ) )
// S'87 compatibility
SETPOS( MAXROW() - 1, 0 )
RETURN (.F.) // NOTE
ENDIF
// Preserve state variables
aSavGetSysVars := ClearGetSysVars()
// Set these for use in SET KEYs
scReadProcName := PROCNAME( 1 )
snReadProcLine := PROCLINE( 1 )
// Set initial GET to be read
IF !( VALTYPE( nPos ) == "N" .AND. nPos > 0 )
nPos := Settle( Getlist, 0 )
ENDIF
SetCursor(IIf(ReadInsert(), 1, 3))
WHILE !( nPos == 0 )
// Get next GET from list and post it as the active GET
PostActiveGet( oGet := GetList[ nPos ] )
// Read the GET
IF ( VALTYPE( oGet:reader ) == "B" )
EVAL( oGet:reader, oGet ) // Use custom reader block
ELSE
GetReader( oGet, FFuncao, FInkey, GetList ) // Use standard reader
ENDIF
iPos = nPos
// Move to next GET based on exit condition
nPos := Settle( GetList, nPos )
If Empty(nPos) .and. LastKey() # 27// Esta prestes a sair do Get
For iPos := iPos+1 To Len(GetList)
If !Empty(GetList[iPos]:PreBlock)
mVerValid := EVAL(GetList[iPos]:PreBlock)
Else
mVerValid := .T.
Endif
If !Empty(GetList[iPos]:PostBlock) .and. ValType(mVerValid) == 'L' .and. mVerValid
PostActiveGet( oGet := GetList[ iPos ] )
mVerValid := EVAL( GetList[iPos]:PostBlock)
If ValType(mVerValid) == 'L' .and. !mVerValid
nPos = iPos
Exit
Endif
Endif
Next
Endif
ENDDO
// Restore state variables
RestoreGetSysVars( aSavGetSysVars )
// S'87 compatibility
SETPOS( MAXROW() - 1, 0 )
SetCursor(MCursor)
RETURN ( slUpdated )
/***
*
* GetReader()
*
* Standard modal read of a single GET
*
*/
PROCEDURE GetReader( oGet, FFuncao, FInkey, GetList )
Local __tecla, x, TRow, TCol
If FInkey = Nil
FInkey = 1
EndIf
// Read the GET if the WHEN condition is satisfied
IF ( GetPreValidate( oGet ) )
// Activate the GET for reading
oGet:setFocus()
WHILE ( oGet:exitState == GE_NOEXIT )
// Check for initial typeout (no editable positions)
IF ( oGet:typeOut )
oGet:exitState := GE_ENTER
ENDIF
// Apply keystrokes until exit
WHILE ( oGet:exitState == GE_NOEXIT )
SetCursor(IIf(ReadInsert(), 1, 3))
If !Empty(FFuncao)
Do While (__Tecla := Inkey(FInkey)) = 0
TRow = Row()
TCol = Col()
x := &(FFuncao)
SetPos(TRow,TCol)
EndDo
GetApplyKey( oGet, __Tecla, GetList )
Else
// antes de mecher com a funcao IDLE OSLIB
// GetApplyKey( oGet, inkey( 0 ), GetList )
// Nao tinha o comando OL_Yield()
GetApplyKey( oGet, inkey( .10 ), GetList )
// OL_Yield()
EndIf
ENDDO
// Disallow exit if the VALID condition is not satisfied
IF ( !GetPostValidate( oGet ) )
oGet:exitState := GE_NOEXIT
ENDIF
ENDDO
// De-activate the GET
oGet:killFocus()
ENDIF
RETURN nil
/***
*
* GetApplyKey()
*
* Apply a single INKEY() keystroke to a GET
*
* NOTE: GET must have focus.
*
*/
PROCEDURE GetApplyKey( oGet, nKey, GetList )
LOCAL cKey
LOCAL bKeyBlock
// Check for SET KEY first
IF !( ( bKeyBlock := setkey( nKey ) ) == NIL )
GetDoSetKey( bKeyBlock, oGet )
RETURN // NOTE
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_TOP
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 ) )
SetCursor(IIf(ReadInsert(), 1,3))
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 )
IF ( oGet:type == "N" .AND. ( cKey == "." .OR. cKey == "," ) )
oGet:toDecPos()
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 nil
/***
*
* GetPreValidate()
*
* Test entry condition (WHEN clause) for a GET
*
*/
FUNCTION GetPreValidate( oGet )
LOCAL lSavUpdated
LOCAL 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 // Provokes ReadModal() exit
ELSEIF ( !lWhen )
oGet:exitState := GE_WHEN // Indicates failure
ELSE
oGet:exitState := GE_NOEXIT // Prepares for editing
ENDIF
RETURN ( lWhen )
/***
*
* GetPostValidate()
*
* Test exit condition (VALID clause) for a GET
*
* NOTE: Bad dates are rejected in such a way as to preserve edit buffer
*
*/
FUNCTION GetPostValidate( oGet )
LOCAL lSavUpdated
LOCAL lValid := .T.
IF ( oGet:exitState == GE_ESCAPE )
RETURN ( .T. ) // NOTE
ENDIF
IF (oGet:type = 'D')
If Len(StrTran(oGet:Buffer,' ','')) = 6
// Monta o ano corrente
oGet:Buffer := Alltrim(oGet:Buffer)+StrZero(Year(mScrDate),4)
ElseIf Len(StrTran(oGet:Buffer,' ','')) = 4 .or. Len(StrTran(oGet:Buffer,' ','')) = 3
oGet:Buffer := StrZero(Val(Left(oGet:Buffer,2)),2)+'/'+StrZero(Month(mScrDate),2)+'/'+StrZero(Year(mScrDate),4)
// oGet:Buffer := Left(oGet:Buffer,2)+'/'+StrZero(Month(mScrDate),2)+'/'+StrZero(Year(mScrDate),4)
EndIf
EndIf
IF ( oGet:badDate() )
oGet:home()
DateMsg()
ShowScoreboard()
RETURN ( .F. ) // NOTE
ENDIF
// If editing occurred, assign the new value to the variable
IF ( oGet:changed )
oGet:assign()
slUpdated := .T.
ENDIF
// Reform edit buffer, set cursor to home position, redisplay
oGet:reset()
// Check VALID condition if specified
IF !( oGet:postBlock == NIL )
lSavUpdated := slUpdated
// S'87 compatibility
SETPOS( oGet:row, oGet:col + LEN( oGet:buffer ) )
lValid := EVAL( oGet:postBlock, oGet )
// Reset S'87 compatibility cursor position
SETPOS( oGet:row, oGet:col )
ShowScoreBoard()
oGet:updateBuffer()
slUpdated := lSavUpdated
IF ( slKillRead )
oGet:exitState := GE_ESCAPE // Provokes ReadModal() exit
lValid := .T.
ENDIF
ENDIF
RETURN ( lValid )
/***
*
* GetDoSetKey()
*
* Process SET KEY during editing
*
*/
PROCEDURE GetDoSetKey( keyBlock, oGet )
LOCAL lSavUpdated
// If editing has occurred, assign variable
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 // provokes ReadModal() exit
ENDIF
RETURN NIL
/***
* READ services
*/
/***
*
* Settle()
*
* Returns new position in array of Get objects, based on:
* - current position
* - exitState of Get object at current position
*
* NOTES: return value of 0 indicates termination of READ
* exitState of old Get is transferred to new Get
*
*/
STATIC FUNCTION Settle( GetList, nPos )
LOCAL nExitState
IF ( nPos == 0 )
nExitState := GE_DOWN
ELSE
nExitState := GetList[ nPos ]:exitState
ENDIF
IF ( nExitState == GE_ESCAPE .or. nExitState == GE_WRITE )
RETURN ( 0 ) // NOTE
ENDIF
IF !( nExitState == GE_WHEN )
// Reset state info
snLastPos := nPos
slBumpTop := .F.
slBumpBot := .F.
ELSE
// Re-use last exitState, do not disturb state info
nExitState := snLastExitState
ENDIF
//
// Move
//
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
//
// Bounce
//
IF ( nPos == 0 ) // Bumped top
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
// Record exit state
snLastExitState := nExitState
IF !( nPos == 0 )
GetList[ nPos ]:exitState := nExitState
ENDIF
RETURN ( nPos )
/***
*
* PostActiveGet()
*
* Post active GET for ReadVar(), GetActive()
*
*/
STATIC PROCEDURE PostActiveGet( oGet )
GetActive( oGet )
ReadVar( GetReadVar( oGet ) )
ShowScoreBoard()
RETURN NIL
/***
*
* ClearGetSysVars()
*
* Save and clear READ state variables. Return array of saved values
*
* NOTE: 'Updated' status is cleared but not saved (S'87 compatibility)
*/
STATIC FUNCTION ClearGetSysVars()
LOCAL aSavSysVars[ GSV_COUNT ]
// Save current sys vars
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
// Re-init old ones
slKillRead := .F.
slBumpTop := .F.
slBumpBot := .F.
snLastExitState := 0
snLastPos := 0
scReadProcName := ""
snReadProcLine := 0
slUpdated := .F.
RETURN ( aSavSysVars )
/***
*
* RestoreGetSysVars()
*
* Restore READ state variables from array of saved values
*
* NOTE: 'Updated' status is not restored (S'87 compatibility)
*
*/
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 NIL
/***
*
* GetReadVar()
*
* Set READVAR() value from a GET
*
*/
STATIC FUNCTION GetReadVar( oGet )
LOCAL cName := UPPER( oGet:name )
LOCAL i
// The following code includes subscripts in the name returned by
// this FUNCTIONtion, if the get variable is an array element
//
// Subscripts are retrieved from the oGet:subscript instance variable
//
// NOTE: Incompatible with Summer 87
//
IF !( oGet:subscript == NIL )
FOR i := 1 TO LEN( oGet:subscript )
cName += "[" + LTRIM( STR( oGet:subscript[i] ) ) + "]"
NEXT
ENDIF
RETURN ( cName )
/***
* System Services
*/
/***
*
* __SetFormat()
*
* SET FORMAT service
*
*/
PROCEDURE __SetFormat( b )
sbFormat := IF( VALTYPE( b ) == "B", b, NIL )
RETURN NIL
/***
*
* __KillRead()
*
* CLEAR GETS service
*
*/
PROCEDURE __KillRead()
slKillRead := .T.
RETURN NIL
/***
*
* GetActive()
*
* Retrieves currently active GET object
*/
FUNCTION GetActive( g )
LOCAL oldActive := soActiveGet
IF ( PCOUNT() > 0 )
soActiveGet := g
ENDIF
RETURN ( oldActive )
/***
*
* Updated()
*
*/
FUNCTION Updated()
RETURN slUpdated
/***
*
* ReadExit()
*
*/
FUNCTION ReadExit( lNew )
RETURN ( SET( _SET_EXIT, lNew ) )
/***
*
* ReadInsert()
*
*/
FUNCTION ReadInsert( lNew )
RETURN ( SET( _SET_INSERT, lNew ) )
/***
* Wacky Compatibility Services
*/
// Display coordinates for SCOREBOARD
#define SCORE_ROW 0
#define SCORE_COL 60
/***
*
* ShowScoreboard()
*
*/
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 NIL
/***
*
* DateMsg()
*
*/
STATIC PROCEDURE DateMsg()
LOCAL nRow
LOCAL nCol
IF ( SET( _SET_SCOREBOARD ) )
nRow := ROW()
nCol := COL()
SETPOS( SCORE_ROW, SCORE_COL )
DISPOUT( NationMsg(_GET_INVD_DATE) )
SETPOS( nRow, nCol )
WHILE ( NEXTKEY() == 0 )
ENDDO
SETPOS( SCORE_ROW, SCORE_COL )
DISPOUT( SPACE( LEN( NationMsg(_GET_INVD_DATE) ) ) )
SETPOS( nRow, nCol )
ENDIF
RETURN NIL
/***
*
* RangeCheck()
*
* NOTE: Unused second param for 5.00 compatibility.
*
*/
FUNCTION RangeCheck( oGet, junk, lo, hi )
LOCAL cMsg, nRow, nCol
LOCAL xValue
IF ( !oGet:changed )
RETURN ( .T. ) // NOTE
ENDIF
xValue := oGet:varGet()
IF ( xValue >= lo .and. xValue <= hi )
RETURN ( .T. ) // NOTE
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 )
ENDDO
SETPOS( SCORE_ROW, MIN( 60, MAXCOL() - LEN( cMsg ) ) )
DISPOUT( SPACE( LEN( cMsg ) ) )
SETPOS( nRow, nCol )
ENDIF
RETURN ( .F. )
/***
*
* ReadKill()
*
*/
FUNCTION ReadKill( lKill )
LOCAL lSavKill := slKillRead
IF ( PCOUNT() > 0 )
slKillRead := lKill
ENDIF
RETURN ( lSavKill )
/***
*
* ReadUpdated()
*
*/
FUNCTION ReadUpdated( lUpdated )
LOCAL lSavUpdated := slUpdated
IF ( PCOUNT() > 0 )
slUpdated := lUpdated
ENDIF
//RETURN ( lSavUpdated )
RETURN ( .T. )
/***
*
* ReadFormat()
*
*/
FUNCTION ReadFormat( b )
LOCAL bSavFormat := sbFormat
IF ( PCOUNT() > 0 )
sbFormat := b
ENDIF
RETURN ( bSavFormat )I hope to have been helpfully for our friends !
)
