home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
mail.altrad.com
/
2015.02.mail.altrad.com.tar
/
mail.altrad.com
/
TEST
/
COMMERC_72_53
/
PROGS
/
RMALIB.PRG
< prev
next >
Wrap
Text File
|
2014-04-10
|
22KB
|
860 lines
* Programme: RMALIB.PRG
* Auteur...: R M ALCOCK
* Date.....: 11:40:43 31/08/1993
* Copyright: (c) 1992, R M ALCOCK, Tous droits réservés
* Notes....: PROCEDURE FILE
*
PROCEDURE RMALIB
#include "Inkey.ch"
#include "box.ch"
#include "appevent.ch"
#include "dcdialog.ch"
#if __XPP__
* #include "express.ch"
* # include "DCMSG.CH"
#endif
#command DEFAULT <param> TO <val> [, <paramn> TO <valn> ];
=> ;
<param> := IIF(<param> = NIL, <val>, <param> ) ;
[; <paramn> := IIF(<paramn> = NIL, <valn>, <paramn> ) ]
*
RETURN
**************************************************
* NETWORK FUNCTIONS
*
*
FUNCTION NET_USE
LOCAL m1,m
PARAMETERS msel, mfile, mex_use, mwait, mind, mali
*
SELECT (msel)
IF NET_USEE (mfile, mex_use, mwait, mali)
m=AT(",",mind)
IF m=0
DO WHILE .T.
SET INDEX TO &mind
IF mind="".OR. .NOT. EMPTY(INDEXKEY(1))
EXIT
ENDIF
ENDDO
ELSE
* THERE ARE TWO INDEXES
m1 = alltrim(substr(mind,1,m-1))
mind = alltrim(substr(mind,m+1))
DO WHILE .T.
SET INDEX TO &m1,&mind
IF .NOT. EMPTY(INDEXKEY(1)) .AND. .NOT. EMPTY(INDEXKEY(2))
EXIT
ENDIF
ENDDO
ENDIF
ELSE
QUIT
ENDIF
RETURN (.T.)
*
FUNCTION NET_USEE
LOCAL forever,mrow,mcol
PARAMETERS file, ex_use, wait, ali
*forever = (wait = 0)
forever = .T.
DO WHILE (forever .OR. wait > 0)
*
IF ex_use && exclusive
IF LEN(ali) <> 0
USE &file EXCLUSIVE ALIAS &ali
ELSE
USE &file EXCLUSIVE
ENDIF
ELSE && shared
IF LEN(ali) <> 0
USE &file ALIAS &ali
ELSE
USE &file
ENDIF
ENDIF
*
IF .NOT. NETERR() && USE succeeds
RETURN (.T.)
ENDIF
mrow=row()
mcol=col()
@ 0,0 say "VEROUILLAGE "+file
INKEY(1) && wait 1 second
wait = wait - 1
@ 0,0 say SPACE(20)
@ mrow,mcol say ""
ENDDO
RETURN (.F.) && USE fails
* End - NET_USE
*
*
FUNCTION FIL_LOCK
LOCAL forever,mrow,mcol
PARAMETERS wait
*
IF Pcount()=0
wait=0
ENDIF
forever = (wait = 0)
DO WHILE (forever .OR. wait > 0)
*
IF FLOCK()
RETURN (.T.) && locked
ENDIF
mrow=row()
mcol=col()
@ 0,0 say "VER. FLOCK "+ALIAS()
INKEY(1) && wait 1 second
wait = wait - 1
@ 0,0 say SPACE(20)
@ mrow,mcol say ""
*
ENDDO
RETURN (.F.) && not locked
* End - FIL_LOCK
*
*
FUNCTION REC_LOCK
LOCAL forever,mrow,mcol
PARAMETERS wait
*
IF Pcount()=0
wait=0
ENDIF
*forever = (wait = 0)
forever = .T.
DO WHILE (forever .OR. wait > 0)
*
IF RLOCK()
RETURN (.T.) && locked
ENDIF
*
mrow=row()
mcol=col()
@ 0,0 say "VER. ENR. "+ALIAS()
INKEY(1) && wait 1 second
wait = wait - 1
@ 0,0 say SPACE(20)
@ mrow,mcol say ""
ENDDO
RETURN (.F.) && not locked
* End - REC_LOCK
*
FUNCTION ADD_REC
LOCAL forever,mrow,mcol
PARAMETERS wait
*
IF Pcount()=0
wait=0
ENDIF
*forever = (wait = 0)
forever = .T.
DO WHILE (forever .OR. wait > 0)
*
APPEND BLANK
IF .NOT. NETERR()
RETURN .T.
ENDIF
mrow=row()
mcol=col()
@ 0,0 say "VER. APP. "+ALIAS()
INKEY(1) && wait 1 second
wait = wait - 1
@ 0,0 say SPACE(20)
@ mrow,mcol say ""
ENDDO
RETURN (.F.) && not locked
* End ADD_REC
*
***********************************************
*
* GENERAL FUNCTIONS
*
FUNCTION CONFIRM ( Mrow, MCol, MDefault, Mtexte )
*RETURNS .T. if Y
* .F. if N
// Define constants
*
LOCAL nStart, The_Mess:={}
DEFAULT MTexte to "CONFIRMATION"
DEFAULT MDefault to "N"
nStart:=IIF ( MDefault="N", 2, 1)
AAdd (The_Mess, MTexte)
RETURN DC_MsgBox ( , , The_Mess, "",,, .T., nStart)
*************
FUNCTION PAD && Makes up a numeric string to fixed length
LOCAL MM1,MM2
PARAMETERS MS,N && by adding leading zeros
MM1=REPLICATE("0",N)
MM2=LTRIM(RTRIM(MS))
MM2=SUBSTR(MM1,1,N-LEN(MM2))+MM2
RETURN MM2
*
*************
*
procedure win
LOCAL Sc:=SETCOLOR()
parameters t,l,b,r,abuff,mtext,btext
abuff=savescreen(t,l,b,r)
DEFAULT btext TO "Esc pour terminer", mtext TO ""
Do HLON
@ t,l clear to b,r
@ t,l to b,r double
@ t,(1+l+r-len(mtext))/2 say mtext
@ b,(1+l+r-len(btext))/2 SAY btext
SETCOLOR(Sc)
return
*
procedure wout
LOCAL Sc:=SETCOLOR()
parameters t,l,b,r,abuff
restscreen (t,l,b,r,ABUFF)
*FT_POPVID() // Restore all video settings
SETCOLOR(Sc)
return
*
****************************************
*
*
PROCEDURE HLON && Set highlight on
LOCAL a,b,c
c=setcolor()
b=at("/",c)-1
a=substr(c,1,b)+ "+" +substr(c, b+1, len(c)-b)
setcolor(a)
RETURN
*
PROCEDURE HLOFF && Set highlight off
PARAMETERS LCD
SET COLOR TO ("W/B,W/R+,,,W/R")
RETURN
*
*
*********
*
FUNCTION PASSWD (MROW,MCOL,P_Array)
*
LOCAL MPW,I,LEV,C
*
I=3
DO WHILE I>0
CLEAR TYPEAHEAD
I=I-1
MPW=""
@ MROW,MCOL CLEAR TO MROW,MCOL+25
@ MROW,MCOL SAY "MOT DE PASSE ? "
DO WHILE .T.
C=INKEY(0)
DO CASE
CASE C=13
EXIT
CASE C>31.AND.C<127
@ ROW(),COL() SAY "*"
MPW=MPW+CHR(C)
CASE (C=8.OR.C=19).AND.LEN(MPW)>0 && Backspace or left arrow
@ROW(),COL()-1 SAY " "
@ROW(),COL()-1 SAY ""
MPW=SUBSTR(MPW,1,LEN(MPW)-1)
ENDCASE
ENDDO
IF EMPTY(MPW)
RETURN 0
ENDIF
MPW=LTRIM(UPPER(MPW))
FOR LEV=1 TO LEN(P_Array)
IF MPW=P_Array[LEV]
RETURN LEV
ENDIF
NEXT
ENDDO
RETURN 0
*
*********
FUNCTION RMAMENU
LOCAL WID,MREPLY,L,R,LM,Top,nOrder
PARAMETERS TSTRING, MR, LCD
*
* The correct database must be selected !
* The FUNCTION returns the CODE of the selected item.
* RETOUR is always the first choice and it returns " "
*
DEFAULT LCD TO .F.
nOrder=INDEXORD()
IF nOrder <> 0
SEEK MR
SET ORDER TO 0
MREPLY=RECNO()+1 // File is indexed
ENDIF
CLEAR
SET ESCAPE OFF
*
*CALCULATE WIDTH OF MENU; It is either the width of the lines or the width
* of the header string. Add 16 to give an eight
* character border
*SET UP COORDINATES; L and R are left and right columns;LM=Left Margin
*
WID=16+IIF(LEN(TSTRING)>LEN(CODE)+LEN(LIBELLE)+3,;
LEN(TSTRING),;
LEN(CODE)+LEN(LIBELLE)+3)
IF WID>80
L=0
R=79
LM=(80-(WID-10))/2
ELSE
L=40-WID/2
R=40+WID/2
LM=L+8
ENDIF
* CALCULATE LENGTH OF MENU, TRY TO FIT ONTO SCREEN
LLONG=RECCOUNT()
Top=IIF(LLONG<18,3,1)
@ Top-1,L TO Top+LLONG+3,R DOUBLE // Outer Box
@ Top+1,L+1 TO Top+1,R-1 DOUBLE // Line under Heading
DO HLON
@ Top,40-LEN(TSTRING)/2 SAY TSTRING
DO HLOFF WITH LCD
@ Top+2,LM PROMPT "R E T O U R"+SPACE(LEN(CODE)+LEN(LIBELLE)-8)
*
GO TOP
DO WHILE .NOT. EOF()
@ ROW()+1,LM PROMPT CODE+" - "+LIBELLE
SKIP
ENDDO
MENU TO MREPLY
IF MREPLY>1.AND.MREPLY<LLONG+2
GO MREPLY-1
MREPLY=CODE
ELSE
MREPLY=" "
ENDIF
SET ESCAPE ON
SET ORDER TO nOrder
RETURN MREPLY
*
*****************************
*
FUNCTION TEXT_ALARM (MT)
LOCAL Abuff[1],MRow,Mcol,Mc,Ml,Mr
Abuff=""
MRow=ROW()
MCol=COL()
Mc=SETCOLOR()
Ml = IIF(MRow>12,MRow-6,MRow+3)
Mr = 37-LEN(MT)/2
DO WIN WITH Ml,Mr,Ml+2,Mr+5+LEN(MT),Abuff,"","Tapez Esc"
SETCOLOR("W+/R")
@ Ml+1,Mr+3 SAY MT
CLEAR TYPEAHEAD
DO WHILE INKEY()<>27
ENDDO
DO WOUT WITH Ml,Mr,Ml+2,Mr+5+LEN(MT),Abuff
SETCOLOR(Mc)
@ MRow,MCol SAY ""
RETURN .T.
*
*---------------------------------------------------
*
FUNCTION ALARM (MT)
LOCAL Abuff[1],MRow,Mcol,Mc,Ml,Mr
MsgBox( MT, "" )
RETURN .T.
*
*****************************
*
PROCEDURE KEYSOFF
set key K_F2 to
set key K_F3 to
set key K_F4 to
set key K_F5 to
set key K_F6 to
set key K_F7 to
set key K_F8 to
set key K_F9 to
set key K_ENTER to
return
*
************************
*
* General FUNCTION (used with VALID clause) to check the existance
* of a specified reference (X) in a specified database (Fname)
*
* X and Fname should both be passed as character strings
*
FUNCTION X_REF (X,Fname)
LOCAL Msel, Mret
Msel=SELECT()
SELECT &Fname
SEEK X
Mret=FOUND()
SELECT (Msel)
RETURN Mret
/* ------------------------------------------------------------------- */
/* $DOC$
* $FUNCNAME$
* RA_BRWSWHL()
*
* Browse an indexed database limited to a while condition
*
* FT_BRWSWHL( <aFields>, <bWhileCond>, <cKey>, ;
* [ <nFreeze> ], [ <cColorList> ], ;
* [ <nTop> ], [ <nLeft> ],[ <nBottom> ], [ <nRight> ], ;
* [ <nTexttop> ], [ <nTextbott> ] -> nRecno
* $ARGUMENTS$
* <aFields> is array of field blocks of fields you want to display.
* Example to set up last name and first name in array:
* aFields := {}
* AADD(aFields, {"Last Name" , {||Names->Last} } )
* AADD(aFields, {"First Name", {||Names->First} } )
*
* <bWhileCond> is the limiting WHILE condition as a block.
* Example 1: { ||Names->Last == "JONES" }
* Example 2: { ||Names->Last == "JONES" .AND. Names->First == "A" }
*
* <cKey> is the key to find top condition of WHILE.
* cLast := "JONES "
* cFirst := "A"
* Example 1: cKey := cLast
* Example 2: cKey := cLast + cFirst
*
* <nFreeze> is number of fields to freeze in TBrowse. Defaults
* to 0 if not passed.
*
* <cColorList> is a list of colors for the TBrowse columns.
* The 1st color is the background, (2nd=GET - has no effect) the
* 3rd is the colour of the columns and 4th is the "select" combination
* (5th is Unselected Get - not used)
*
* Thus if you pass a cColorList, you MUST pass at least 4 colors.
* Defaults to "BG/B, W+/R, BG/B, W+/R, N/BG" if not passed.
*
* <nTop>, <nLeft>, <nBottom>, <nRight> are the coordinates of
* the area to display the TBrowse in. Defaults to 2, 2,
* MAXROW() - 2, MAXCOL() - 2 with shadowed box, i.e. full screen.
*
* nTexttop and nTextbott are the two texts for the WIN progedure
*
* $RETURNS$
* nRecno is the number of the record selected by the <Enter> key.
* -1 is returned if there are no records matching the WHILE condition
* 0 is returned if <Esc> is pressed instead of an <Enter>
*/
FUNCTION RA_BRWSWHL(aFields, bWhileCond, cKey, nFreeze, cColorList,;
nTop, nLeft, nBottom, nRight, nTexttop, nTextbott)
LOCAL b, column, cType, i
LOCAL cHead, bField, abuff
LOCAL cColorSave, cColorBack, nCursSave
LOCAL lMore, nEvent, nPassRec
LOCAL aScrollBar
LOCAL MP1,MP2,oXbp
*
PRIVATE nRec, RecPos:=1
DEFAULT nFreeze TO 0, ;
cColorList TO "BG/B, W+/R, BG/B, W+/R, N/BG",;
nTop TO 0, ;
nLeft TO 0, ;
nBottom TO MaxRow() - 1, ;
nRight TO MaxCol() - 1
SEEK cKey
IF .NOT. FOUND() .OR. LASTREC() == 0
RETURN(-1)
ENDIF
COUNT TO nRec WHILE Eval(bWhileCond)
SEEK cKey
/* save old screen and colors */
cColorSave := SetColor(cColorList)
/* make new browse object */
b := TBrowseDB(nTop+1, nLeft+1, nBottom-1, nRight-2)
/* default heading and column separators */
b:headSep := "═╤═"
b:colSep := " │ "
/* add custom 'TbSkipWhil' (to handle passed condition) */
b:skipBlock := {|x| TbSkipWhil(x, bWhileCond)}
/* Set up substitute goto top and goto bottom */
/* with While's top and bottom records */
b:goTopBlock := {|| TbWhileTop(cKey)}
b:goBottomBlock := {|| TbWhileBot(cKey)}
/* colors */
* b:colorSpec := cColorList
/* add a column for each field in the current workarea */
FOR i = 1 TO LEN(aFields)
cHead := aFields[i, 1]
bField := aFields[i, 2]
/* make the new column */
column := TBColumnNew( cHead, bField )
column:defColor := {3, 4}
b:addColumn(column)
NEXT
/* freeze columns */
IF nFreeze <> 0
b:freeze := nFreeze
ENDIF
/* save old screen and colors */
* cColorSave := SetColor(cColorList)
DO WIN WITH nTop,nLeft,nBottom,nRight,abuff,nTexttop,nTextbott
/* Background Color Is Based On First Color In Passed cColorList*/
* cColorBack := IF(',' $ cColorList, ;
* SUBSTR(cColorList, 1, AT(',', cColorList) - 1), cColorList )
* SetColor(cColorBack)
* @ nTop+1, nLeft+1 CLEAR TO nBottom-1, nRight-1
* SetColor(cColorSave)
nCursSave := SetCursor(0)
aScrollBar := ScrollBarNew( nTop+1, nRight, nBottom-1)
aScrollBar := ScrollBarDisplay( aScrollBar )
aScrollBar := ScrollBarUpdate( aScrollBar, RecPos, nRec,.T.) // Force disp.
lMore := .t.
DO WHILE (lMore)
/* stabilize the display */
DO WHILE .NOT. b:stabilize()
IF (nEvent := NextAppEvent( @mp1, @mp2, @oXbp )) > xbe_None .AND. ;
(nEvent <> xbeM_Motion )
nEvent := AppEvent( @mp1, @mp2, @oXbp )
EXIT
ENDIF
ENDDO
IF ( b:stable )
/* display is stable */
IF ( b:hitTop .OR. b:hitBottom )
Tone(125, 0)
ENDIF
// Make sure that the current record is showing
// up-to-date data in case we are on a network.
b:refreshCurrent()
DO WHILE .NOT. b:stabilize()
ENDDO
aScrollBar := ScrollBarUpdate( aScrollBar, RecPos, nRec)
/* everything's done; just wait for a key */
nEvent := xbeM_Motion // filter out event
DO WHILE nEvent == xbeM_Motion // "mouse is moved"
nEvent := AppEvent( @mp1, @mp2, @oXbp, 0 )
IF nEvent == xbeM_Motion .AND. Set( _SET_HANDLEEVENT )
oXbp:HandleEvent( nEvent, mp1, mp2 )
ENDIF
ENDDO
ENDIF
/* process key */
DO CASE
// Mouse movements on scrollbar
CASE nEvent = xbeM_LbClick .AND. mp1[2]=nRight .and. mp1[1]=nBottom - 1
b:down()
CASE nEvent = xbeM_LbClick .AND. mp1[2]=nRight .and. mp1[1]=nTop + 1
b:up()
CASE nEvent = xbeM_LbClick .AND. mp1[2]=nRight .and. mp1[1]=nTop + 2
b:Pageup()
CASE nEvent = xbeM_LbClick .AND. mp1[2]=nRight .and. mp1[1]=nBottom - 2
b:PageDown()
CASE ( nEvent == xbeK_DOWN ) .OR. ;
( nEvent = xbeM_Wheel .AND. mp2[2] = -120)
b:down()
CASE ( nEvent == xbeK_UP ) .OR. ;
( nEvent = xbeM_Wheel .AND. mp2[2] = 120)
b:up()
CASE ( nEvent == xbeK_PGDN )
b:pageDown()
CASE ( nEvent == xbeK_PGUP )
b:pageUp()
CASE ( nEvent == xbeK_CTRL_PGUP )
b:goTop()
CASE ( nEvent == xbeK_CTRL_PGDN )
b:goBottom()
CASE ( nEvent == xbeK_RIGHT )
b:right()
CASE ( nEvent == xbeK_LEFT )
b:left()
CASE ( nEvent == xbeK_HOME )
b:home()
CASE ( nEvent == xbeK_END )
b:_end()
CASE ( nEvent == xbeK_CTRL_LEFT )
b:panLeft()
CASE ( nEvent == xbeK_CTRL_RIGHT )
b:panRight()
CASE ( nEvent == xbeK_CTRL_HOME )
b:panHome()
CASE ( nEvent == xbeK_CTRL_END )
b:panEnd()
CASE ( nEvent == xbeK_ESC .OR. nEvent == xbeM_RbClick)
nPassRec := 0
lMore := .f.
CASE ( nEvent == xbeK_RETURN .OR. nEvent == xbeK_F9 .OR. nEvent = xbeM_LbClick)
nPassRec := RECNO()
lMore := .f.
OTHERWISE
TBHandleEvent( b, nEvent, mp1, mp2, oXbp)
ENDCASE
ENDDO // for WHILE (lmore)
/* restore old screen */
DO WOUT WITH nTop,nLeft,nBottom,nRight,abuff
SetCursor(nCursSave)
SetColor(cColorSave)
RETURN (nPassRec)
/* -------------------------------------------------------------------- */
STATIC FUNCTION TbSkipWhil(n, bWhileCond)
LOCAL i := 0
IF n == 0 .OR. LASTREC() == 0
SKIP 0 // significant on a network
ELSEIF ( n > 0 .AND. RECNO() <> LASTREC() + 1)
DO WHILE ( i < n )
SKIP 1
IF ( EOF() .OR. .NOT. Eval(bWhileCond) )
SKIP -1
RecPos = nRec
EXIT
ENDIF
i++
RecPos = RecPos + 1
ENDDO
ELSEIF ( n < 0 )
DO WHILE ( i > n )
SKIP -1
IF ( BOF() )
RecPos = 1
EXIT
ELSEIF .NOT. Eval( (bWhileCond) )
SKIP
RecPos = 1
EXIT
ENDIF
i--
RecPos = RecPos - 1
ENDDO
ENDIF
RETURN (i)
* EOFcn TbSkipWhil()
/* -------------------------------------------------------------------- */
STATIC FUNCTION TbWhileTop(cKey)
SEEK cKey
RecPos = 1
RETURN NIL
/* -------------------------------------------------------------------- */
STATIC FUNCTION TbWhileBot(cKey)
#include "set.ch"
LOCAL cSoftSave := SET(_SET_SOFTSEEK, .t.)
SEEK LEFT(cKey, LEN(cKey) -1) + CHR( ASC( RIGHT(cKey,1) ) +1)
SET(_SET_SOFTSEEK, cSoftSave)
SKIP -1
RecPos= nRec
RETURN NIL
* Scrolbar SYSTEM
* Implements a scroll bar that can be updated as the cursor moves down
* in a TBrowse object, ACHOICE(), DBEDIT(), or MEMOEDIT().
*
// The elements in aTab
#define TB_ROWTOP 1
#define TB_COLTOP 2
#define TB_ROWBOTTOM 3
#define TB_COLBOTTOM 4
#define TB_COLOR 5
#define TB_POSITION 6
#define TB_ELEMENTS 6
// The Up and Down arrows, highlight and background char's for the thumb tab
#define TB_UPARROW CHR( 24 )
#define TB_DNARROW CHR( 25 )
#define TB_HIGHLIGHT CHR( 178 )
#define TB_BACKGROUND CHR( 176 )
* ScrollBarNew( <nTopRow>, <nTopColumn>, <nBottomRow>,
* <cColorString>, <nInitPosition> ) --> aScrollBar
*
* Create a new scroll bar array with the specified coordinates
*
FUNCTION ScrollBarNew( nTopRow, nTopColumn, nBottomRow, ;
cColorString, nInitPosition )
LOCAL aScrollBar := ARRAY( TB_ELEMENTS )
aScrollBar[ TB_ROWTOP ] := nTopRow
aScrollBar[ TB_COLTOP ] := nTopColumn
aScrollBar[ TB_ROWBOTTOM ] := nBottomRow
aScrollBar[ TB_COLBOTTOM ] := nTopColumn
// Set the default color to White on Black if none specified
IF cColorString == NIL
cColorString := "W/N"
ENDIF
aScrollBar[ TB_COLOR ] := cColorString
// Set the starting position
IF nInitPosition == NIL
nInitPosition := 1
ENDIF
aScrollBar[ TB_POSITION ] := nInitPosition
RETURN aScrollBar
* ScrollBarDisplay( <aScrollBar> ) --> aScrollBar
* Display a scoll bar array to the screen
*
FUNCTION ScrollBarDisplay( aScrollBar )
LOCAL cOldColor, nRow
cOldColor := SETCOLOR( aScrollBar[ TB_COLOR ] )
// Draw the arrows
@ aScrollBar[ TB_ROWTOP ], aScrollBar[ TB_COLTOP ] SAY TB_UPARROW
@ aScrollBar[ TB_ROWBOTTOM ], aScrollBar[ TB_COLBOTTOM ] SAY TB_DNARROW
// Draw the background
FOR nRow := (aScrollBar[ TB_ROWTOP ] + 1) TO (aScrollBar[ TB_ROWBOTTOM ] - 1)
@ nRow, aScrollBar[ TB_COLTOP ] SAY TB_BACKGROUND
NEXT
SETCOLOR( cOldColor )
RETURN aScrollBar
* ScrollBarUpdate( <aScrollBar>, <nCurrent>, <nTotal>,
* <lForceUpdate> ) --> aScrollBar
*
* Update scroll bar array with new tab position and redisplay tab
*
FUNCTION ScrollBarUpdate( aScrollBar, nCurrent, nTotal, lForceUpdate )
LOCAL cOldColor, nNewPosition
LOCAL nScrollHeight := (aScrollBar[TB_ROWBOTTOM] - 1) - ;
(aScrollBar[TB_ROWTOP])
IF nTotal < 1
nTotal := 1
ENDIF
IF nCurrent < 1
nCurrent := 1
ENDIF
IF nCurrent > nTotal
nCurrent := nTotal
ENDIF
IF lForceUpdate == NIL
lForceUpdate := .F.
ENDIF
cOldColor := SETCOLOR( aScrollBar[ TB_COLOR ] )
// Determine the new position
nNewPosition := ROUND( (nCurrent / nTotal) * nScrollHeight, 0 )
// Resolve algorithm oversights
nNewPosition := IF( nNewPosition < 1, 1, nNewPosition )
nNewPosition := IF( nCurrent == 1, 1, nNewPosition )
nNewPosition := IF( nCurrent >= nTotal, nScrollHeight, nNewPosition )
// Overwrite the old position (if different), then draw in the new one
IF nNewPosition <> aScrollBar[ TB_POSITION ] .OR. lForceUpdate
@ (aScrollBar[ TB_POSITION ] + aScrollBar[ TB_ROWTOP ]), ;
aScrollBar[ TB_COLTOP ] SAY TB_BACKGROUND
@ (nNewPosition + aScrollBar[ TB_ROWTOP ]), aScrollBar[ TB_COLTOP ] SAY ;
TB_HIGHLIGHT
aScrollBar[ TB_POSITION ] := nNewPosition
ENDIF
SETCOLOR( cOldColor )
RETURN aScrollBar
//
//-----------------------------------------------------
//
FUNCTION UNINOM(Root)
//
// Returns a unique name for use in a network environment
// under WINDOWS where a "local" filename is necessary
// ROOT could be (for instance) "C:\AA": UNINOM will add 6 characters
LOCAL A,B,I
A=TIME()
B=(((MONTH(DATE())*31;
+DAY(DATE()))*24;
+VAL(SUBSTR(A,1,2)))*60;
+VAL(SUBSTR(A,4,2)))*60;
+VAL(SUBSTR(A,7,2));
FOR I=1 TO 6
Root=Root+CHR(65+MOD(B,25))
B=INT(B/25)
NEXT I
RETURN Root
//
//-----------------------------------------------------
//
FUNCTION SYSDATE
Local Mdate
// used in lots of places to prevent errors at month end
// mainly in facturation, promos, but not in bons
Mdate= IIF(DATE()>MDAT_MAX,MDAT_MAX,DATE())
RETURN Mdate
*******