home *** CD-ROM | disk | FTP | other *** search
/ mail.altrad.com / 2015.02.mail.altrad.com.tar / mail.altrad.com / TEST / COMMERC_72_53OLD / PROGS / RMALIB.PRG < prev    next >
Text File  |  2014-04-02  |  22KB  |  860 lines
  1. * Programme: RMALIB.PRG
  2. * Auteur...: R M ALCOCK
  3. * Date.....: 11:40:43  31/08/1993
  4. * Copyright: (c) 1992, R M ALCOCK, Tous droits réservés
  5. * Notes....: PROCEDURE FILE
  6. *
  7. PROCEDURE RMALIB
  8.  
  9. #include "Inkey.ch"
  10. #include "box.ch"
  11. #include "appevent.ch"
  12. #include "dcdialog.ch"
  13.  
  14. #if __XPP__
  15.  
  16. *   #include "express.ch"
  17. *   # include "DCMSG.CH"
  18.  
  19. #endif
  20.  
  21. #command DEFAULT <param> TO <val> [, <paramn> TO <valn> ];
  22. => ;
  23.          <param> := IIF(<param> = NIL, <val>, <param> ) ;
  24.          [; <paramn> := IIF(<paramn> = NIL, <valn>, <paramn> ) ]
  25. *
  26. RETURN
  27. **************************************************
  28. * NETWORK FUNCTIONS
  29. *
  30. *
  31. FUNCTION NET_USE
  32. LOCAL m1,m
  33. PARAMETERS msel, mfile, mex_use, mwait, mind, mali
  34. *
  35. SELECT (msel)
  36. IF NET_USEE (mfile, mex_use, mwait, mali)
  37.    m=AT(",",mind)
  38.    IF m=0
  39.       DO WHILE .T.
  40.          SET INDEX TO &mind
  41.          IF mind="".OR. .NOT. EMPTY(INDEXKEY(1))
  42.             EXIT
  43.          ENDIF
  44.       ENDDO
  45.    ELSE
  46.       * THERE ARE TWO INDEXES
  47.       m1 = alltrim(substr(mind,1,m-1))
  48.       mind = alltrim(substr(mind,m+1))
  49.       DO WHILE .T.
  50.          SET INDEX TO &m1,&mind
  51.          IF .NOT. EMPTY(INDEXKEY(1)) .AND. .NOT. EMPTY(INDEXKEY(2))
  52.             EXIT
  53.          ENDIF
  54.       ENDDO
  55.    ENDIF
  56. ELSE
  57.    QUIT
  58. ENDIF
  59. RETURN (.T.)
  60. *
  61. FUNCTION NET_USEE
  62. LOCAL forever,mrow,mcol
  63. PARAMETERS file, ex_use, wait, ali
  64. *forever = (wait = 0)
  65. forever = .T.
  66. DO WHILE (forever .OR. wait > 0)
  67. *
  68.    IF ex_use                    && exclusive
  69.       IF LEN(ali) <> 0
  70.          USE &file EXCLUSIVE ALIAS &ali
  71.       ELSE
  72.          USE &file EXCLUSIVE
  73.       ENDIF
  74.    ELSE                         && shared
  75.       IF LEN(ali) <> 0
  76.          USE &file ALIAS &ali
  77.       ELSE
  78.          USE &file
  79.       ENDIF
  80.    ENDIF
  81.    *
  82.    IF .NOT. NETERR()            && USE succeeds
  83.       RETURN (.T.)
  84.    ENDIF
  85.    mrow=row()
  86.    mcol=col()
  87.    @ 0,0 say "VEROUILLAGE "+file
  88.    INKEY(1)                     && wait 1 second
  89.    wait = wait - 1
  90.    @ 0,0 say SPACE(20)
  91.    @ mrow,mcol say ""
  92. ENDDO
  93. RETURN (.F.)                    && USE fails
  94. * End - NET_USE
  95. *
  96. *
  97. FUNCTION FIL_LOCK
  98. LOCAL forever,mrow,mcol
  99. PARAMETERS wait
  100. *
  101. IF Pcount()=0
  102.    wait=0
  103. ENDIF
  104. forever = (wait = 0)
  105. DO WHILE (forever .OR. wait > 0)
  106. *
  107.    IF FLOCK()
  108.       RETURN (.T.)              && locked
  109.    ENDIF
  110.    mrow=row()
  111.    mcol=col()
  112.    @ 0,0 say "VER. FLOCK "+ALIAS()
  113.    INKEY(1)                     && wait 1 second
  114.    wait = wait - 1
  115.    @ 0,0 say SPACE(20)
  116.    @ mrow,mcol say ""
  117. *
  118. ENDDO
  119. RETURN (.F.)                    && not locked
  120. * End - FIL_LOCK
  121. *
  122. *
  123. FUNCTION REC_LOCK
  124. LOCAL forever,mrow,mcol
  125. PARAMETERS wait
  126. *
  127. IF Pcount()=0
  128.    wait=0
  129. ENDIF
  130. *forever = (wait = 0)
  131. forever = .T.
  132. DO WHILE (forever .OR. wait > 0)
  133.    *
  134.    IF RLOCK()
  135.       RETURN (.T.)              && locked
  136.    ENDIF
  137.    *
  138.    mrow=row()
  139.    mcol=col()
  140.    @ 0,0 say "VER. ENR. "+ALIAS()
  141.    INKEY(1)                     && wait 1 second
  142.    wait = wait - 1
  143.    @ 0,0 say SPACE(20)
  144.    @ mrow,mcol say ""
  145. ENDDO
  146. RETURN (.F.)                    && not locked
  147. * End - REC_LOCK
  148. *
  149. FUNCTION ADD_REC
  150. LOCAL forever,mrow,mcol
  151. PARAMETERS wait
  152. *
  153. IF Pcount()=0
  154.    wait=0
  155. ENDIF
  156. *forever = (wait = 0)
  157. forever = .T.
  158. DO WHILE (forever .OR. wait > 0)
  159. *
  160.    APPEND BLANK
  161.    IF .NOT. NETERR()
  162.       RETURN .T.
  163.    ENDIF
  164.    mrow=row()
  165.    mcol=col()
  166.    @ 0,0 say "VER. APP. "+ALIAS()
  167.    INKEY(1)                     && wait 1 second
  168.    wait = wait - 1
  169.    @ 0,0 say SPACE(20)
  170.    @ mrow,mcol say ""
  171. ENDDO
  172. RETURN (.F.)                    && not locked
  173. * End ADD_REC
  174. *
  175. ***********************************************
  176. *
  177. * GENERAL FUNCTIONS
  178. *
  179. FUNCTION CONFIRM ( Mrow, MCol, MDefault, Mtexte )
  180. *RETURNS .T. if Y
  181. *        .F. if N
  182. // Define constants
  183. *
  184. LOCAL nStart, The_Mess:={}
  185.  
  186. DEFAULT MTexte to "CONFIRMATION"
  187. DEFAULT MDefault to "N"
  188.  
  189. nStart:=IIF ( MDefault="N", 2, 1)
  190. AAdd (The_Mess, MTexte)
  191.  
  192. RETURN DC_MsgBox ( , ,  The_Mess, "",,, .T., nStart) 
  193.  
  194. *************
  195. FUNCTION PAD                  && Makes up a numeric string to fixed length
  196. LOCAL MM1,MM2
  197. PARAMETERS MS,N               && by adding leading zeros
  198. MM1=REPLICATE("0",N)
  199. MM2=LTRIM(RTRIM(MS))
  200. MM2=SUBSTR(MM1,1,N-LEN(MM2))+MM2
  201. RETURN MM2
  202. *
  203. *************
  204. *
  205. procedure win
  206. LOCAL Sc:=SETCOLOR()
  207. parameters t,l,b,r,abuff,mtext,btext
  208. abuff=savescreen(t,l,b,r)
  209. DEFAULT btext TO  "Esc pour terminer", mtext TO ""
  210. Do HLON
  211. @ t,l clear to b,r
  212. @ t,l to b,r double
  213. @ t,(1+l+r-len(mtext))/2 say mtext
  214. @ b,(1+l+r-len(btext))/2 SAY btext
  215. SETCOLOR(Sc)
  216. return
  217. *
  218. procedure wout
  219. LOCAL Sc:=SETCOLOR()
  220. parameters t,l,b,r,abuff
  221. restscreen (t,l,b,r,ABUFF)
  222. *FT_POPVID()                   // Restore all video settings
  223. SETCOLOR(Sc)
  224. return
  225. *
  226. ****************************************
  227. *
  228. *
  229. PROCEDURE HLON                && Set highlight on
  230. LOCAL a,b,c
  231.     c=setcolor()
  232.     b=at("/",c)-1
  233.     a=substr(c,1,b)+ "+" +substr(c, b+1, len(c)-b)
  234.     setcolor(a)
  235. RETURN
  236. *
  237. PROCEDURE HLOFF               && Set highlight off
  238. PARAMETERS LCD
  239. SET COLOR TO ("W/B,W/R+,,,W/R")
  240. RETURN
  241. *
  242. *
  243. *********
  244. *
  245. FUNCTION PASSWD (MROW,MCOL,P_Array)
  246. *
  247. LOCAL MPW,I,LEV,C
  248. *
  249. I=3
  250. DO WHILE I>0
  251.    CLEAR TYPEAHEAD
  252.    I=I-1
  253.    MPW=""
  254.    @ MROW,MCOL CLEAR TO MROW,MCOL+25
  255.    @ MROW,MCOL SAY "MOT DE PASSE ? "
  256.    DO WHILE .T.
  257.       C=INKEY(0)
  258.       DO CASE
  259.       CASE C=13
  260.          EXIT
  261.       CASE C>31.AND.C<127
  262.          @ ROW(),COL() SAY "*"
  263.          MPW=MPW+CHR(C)
  264.       CASE (C=8.OR.C=19).AND.LEN(MPW)>0    && Backspace or left arrow
  265.          @ROW(),COL()-1 SAY " "
  266.          @ROW(),COL()-1 SAY ""
  267.          MPW=SUBSTR(MPW,1,LEN(MPW)-1)
  268.       ENDCASE
  269.    ENDDO
  270.    IF EMPTY(MPW)
  271.       RETURN 0
  272.    ENDIF
  273.    MPW=LTRIM(UPPER(MPW))
  274.    FOR LEV=1 TO LEN(P_Array)
  275.       IF MPW=P_Array[LEV]
  276.          RETURN LEV
  277.       ENDIF
  278.    NEXT
  279. ENDDO
  280. RETURN 0
  281. *
  282. *********
  283. FUNCTION RMAMENU
  284. LOCAL WID,MREPLY,L,R,LM,Top,nOrder
  285. PARAMETERS TSTRING, MR, LCD
  286. *
  287. * The correct database must be selected !
  288. * The FUNCTION returns the CODE of the selected item.
  289. *              RETOUR is always the first choice and it returns "  "
  290. *
  291. DEFAULT LCD TO .F.
  292. nOrder=INDEXORD()
  293. IF nOrder <> 0
  294.    SEEK MR
  295.    SET ORDER TO 0
  296.    MREPLY=RECNO()+1    // File is indexed
  297. ENDIF
  298. CLEAR
  299. SET ESCAPE OFF
  300. *
  301. *CALCULATE WIDTH OF MENU; It is either the width of the lines or the width
  302. *                         of the header string. Add 16 to give an eight
  303. *                         character border
  304. *SET UP COORDINATES;      L and R are left and right columns;LM=Left Margin
  305. *
  306. WID=16+IIF(LEN(TSTRING)>LEN(CODE)+LEN(LIBELLE)+3,;
  307.              LEN(TSTRING),;
  308.              LEN(CODE)+LEN(LIBELLE)+3)
  309. IF WID>80
  310.    L=0
  311.    R=79
  312.    LM=(80-(WID-10))/2
  313. ELSE
  314.    L=40-WID/2
  315.    R=40+WID/2
  316.    LM=L+8
  317. ENDIF
  318. * CALCULATE LENGTH OF MENU, TRY TO FIT ONTO SCREEN
  319. LLONG=RECCOUNT()
  320. Top=IIF(LLONG<18,3,1)
  321. @ Top-1,L TO Top+LLONG+3,R DOUBLE      // Outer Box
  322. @ Top+1,L+1 TO Top+1,R-1 DOUBLE        // Line under Heading
  323. DO HLON
  324. @ Top,40-LEN(TSTRING)/2 SAY TSTRING
  325. DO HLOFF WITH LCD
  326. @ Top+2,LM PROMPT "R E T O U R"+SPACE(LEN(CODE)+LEN(LIBELLE)-8)
  327. *
  328. GO TOP
  329. DO WHILE .NOT. EOF()
  330.    @ ROW()+1,LM PROMPT CODE+" - "+LIBELLE
  331.    SKIP
  332. ENDDO
  333. MENU TO MREPLY
  334. IF MREPLY>1.AND.MREPLY<LLONG+2
  335.    GO MREPLY-1
  336.    MREPLY=CODE
  337. ELSE
  338.    MREPLY="  "
  339. ENDIF
  340. SET ESCAPE ON
  341. SET ORDER TO nOrder
  342. RETURN MREPLY
  343. *
  344. *****************************
  345. *
  346. FUNCTION TEXT_ALARM (MT)
  347. LOCAL Abuff[1],MRow,Mcol,Mc,Ml,Mr
  348. Abuff=""
  349. MRow=ROW()
  350. MCol=COL()
  351. Mc=SETCOLOR()
  352. Ml = IIF(MRow>12,MRow-6,MRow+3)
  353. Mr = 37-LEN(MT)/2
  354. DO WIN WITH Ml,Mr,Ml+2,Mr+5+LEN(MT),Abuff,"","Tapez Esc"
  355. SETCOLOR("W+/R")
  356. @ Ml+1,Mr+3 SAY MT
  357. CLEAR TYPEAHEAD
  358. DO WHILE INKEY()<>27
  359. ENDDO
  360. DO WOUT WITH Ml,Mr,Ml+2,Mr+5+LEN(MT),Abuff
  361. SETCOLOR(Mc)
  362. @ MRow,MCol SAY ""
  363. RETURN .T.
  364. *
  365. *---------------------------------------------------
  366. *
  367. FUNCTION ALARM (MT)
  368. LOCAL Abuff[1],MRow,Mcol,Mc,Ml,Mr
  369. MsgBox( MT, "" ) 
  370. RETURN .T.
  371. *
  372. *****************************
  373. *
  374. PROCEDURE KEYSOFF
  375. set key K_F2 to
  376. set key K_F3 to
  377. set key K_F4 to
  378. set key K_F5 to
  379. set key K_F6 to
  380. set key K_F7 to
  381. set key K_F8 to
  382. set key K_F9 to
  383. set key K_ENTER to
  384. return
  385. *
  386. ************************
  387. *
  388. * General FUNCTION (used with VALID clause) to check the existance
  389. * of a specified reference (X) in a specified database (Fname)
  390. *
  391. * X and Fname should both be passed as character strings
  392. *
  393. FUNCTION X_REF (X,Fname)
  394. LOCAL Msel, Mret
  395. Msel=SELECT()
  396. SELECT &Fname
  397. SEEK X
  398. Mret=FOUND()
  399. SELECT (Msel)
  400. RETURN Mret
  401.  
  402. /* ------------------------------------------------------------------- */
  403.  
  404. /*  $DOC$
  405.  *  $FUNCNAME$
  406.  *     RA_BRWSWHL()
  407.  *
  408.  *     Browse an indexed database limited to a while condition
  409.  *
  410.  *     FT_BRWSWHL( <aFields>, <bWhileCond>, <cKey>,                  ;
  411.  *                 [ <nFreeze> ], [ <cColorList> ], ;
  412.  *                 [ <nTop> ], [ <nLeft> ],[ <nBottom> ], [ <nRight> ], ;
  413.  *                 [ <nTexttop> ], [ <nTextbott> ] -> nRecno
  414.  *  $ARGUMENTS$
  415.  *     <aFields> is array of field blocks of fields you want to display.
  416.  *        Example to set up last name and first name in array:
  417.  *        aFields := {}
  418.  *        AADD(aFields, {"Last Name" , {||Names->Last}  } )
  419.  *        AADD(aFields, {"First Name", {||Names->First} } )
  420.  *
  421.  *     <bWhileCond> is the limiting WHILE condition as a block.
  422.  *        Example 1: { ||Names->Last == "JONES" }
  423.  *        Example 2: { ||Names->Last == "JONES" .AND. Names->First == "A"  }
  424.  *
  425.  *     <cKey> is the key to find top condition of WHILE.  
  426.  *        cLast  := "JONES     "
  427.  *        cFirst := "A"
  428.  *        Example 1: cKey := cLast
  429.  *        Example 2: cKey := cLast + cFirst
  430.  *
  431.  *     <nFreeze> is number of fields to freeze in TBrowse.  Defaults
  432.  *     to 0 if not passed.
  433.  *
  434.  *     <cColorList> is a list of colors for the TBrowse columns.
  435.  *     The 1st color is the background, (2nd=GET - has no effect) the
  436.  *     3rd is the colour of the columns and 4th is the "select" combination
  437.  *     (5th is Unselected Get - not used)
  438.  *
  439.  *     Thus if you pass a cColorList, you MUST pass at least 4 colors.
  440.  *     Defaults to "BG/B, W+/R, BG/B, W+/R, N/BG" if not passed.
  441.  *
  442.  *     <nTop>, <nLeft>, <nBottom>, <nRight> are the coordinates of
  443.  *     the area to display the TBrowse in.  Defaults to 2, 2,
  444.  *     MAXROW() - 2, MAXCOL() - 2 with shadowed box, i.e. full screen.
  445.  *
  446.  *     nTexttop and nTextbott are the two texts for the WIN progedure
  447.  *
  448.  *  $RETURNS$
  449.  *     nRecno is the number of the record selected by the <Enter> key.
  450.  *     -1 is returned if there are no records matching the WHILE condition
  451.  *      0 is returned if <Esc> is pressed instead of an <Enter>
  452.  */
  453.  
  454. FUNCTION RA_BRWSWHL(aFields, bWhileCond, cKey, nFreeze, cColorList,;
  455.                     nTop, nLeft, nBottom, nRight, nTexttop, nTextbott)
  456.    LOCAL b, column, cType, i
  457.    LOCAL cHead, bField, abuff
  458.    LOCAL cColorSave, cColorBack, nCursSave
  459.    LOCAL lMore, nEvent, nPassRec
  460.    LOCAL aScrollBar
  461.    LOCAL MP1,MP2,oXbp
  462.    *
  463.    PRIVATE nRec, RecPos:=1
  464.  
  465.    DEFAULT nFreeze TO 0, ;
  466.            cColorList TO "BG/B, W+/R, BG/B, W+/R, N/BG",;
  467.            nTop       TO 0, ;
  468.            nLeft      TO 0, ;
  469.            nBottom    TO MaxRow() - 1, ;
  470.            nRight     TO MaxCol() - 1
  471.  
  472.    SEEK cKey
  473.    IF .NOT. FOUND() .OR. LASTREC() == 0
  474.       RETURN(-1)
  475.    ENDIF
  476.  
  477.    COUNT TO nRec WHILE Eval(bWhileCond)
  478.    SEEK cKey
  479.  
  480.    /* save old screen and colors */
  481.     cColorSave := SetColor(cColorList)
  482.  
  483.    /* make new browse object */
  484.    b := TBrowseDB(nTop+1, nLeft+1, nBottom-1, nRight-2)
  485.  
  486.    /* default heading and column separators */
  487.    b:headSep := "═╤═"
  488.    b:colSep  := " │ "
  489.  
  490.    /* add custom 'TbSkipWhil' (to handle passed condition) */
  491.    b:skipBlock := {|x| TbSkipWhil(x, bWhileCond)}
  492.  
  493.    /* Set up substitute goto top and goto bottom */
  494.    /* with While's top and bottom records        */
  495.    b:goTopBlock    := {|| TbWhileTop(cKey)}
  496.    b:goBottomBlock := {|| TbWhileBot(cKey)}
  497.  
  498.    /* colors */
  499. *   b:colorSpec := cColorList
  500.  
  501.    /* add a column for each field in the current workarea */
  502.    FOR i = 1 TO LEN(aFields)
  503.       cHead  := aFields[i, 1]
  504.       bField := aFields[i, 2]
  505.  
  506.       /* make the new column */
  507.       column := TBColumnNew( cHead, bField )
  508.       column:defColor := {3, 4}
  509.       b:addColumn(column)
  510.    NEXT
  511.  
  512.    /* freeze columns */
  513.    IF nFreeze <> 0
  514.       b:freeze := nFreeze
  515.    ENDIF
  516.  
  517.    /* save old screen and colors */
  518. *   cColorSave := SetColor(cColorList)
  519.  
  520.    DO WIN WITH nTop,nLeft,nBottom,nRight,abuff,nTexttop,nTextbott
  521.  
  522.    /* Background Color Is Based On First Color In Passed cColorList*/
  523. *   cColorBack := IF(',' $ cColorList, ;
  524. *      SUBSTR(cColorList, 1, AT(',', cColorList) - 1), cColorList )
  525.  
  526. *   SetColor(cColorBack)
  527. *   @ nTop+1, nLeft+1 CLEAR TO nBottom-1, nRight-1
  528. *   SetColor(cColorSave)
  529.  
  530.    nCursSave := SetCursor(0)
  531.    aScrollBar := ScrollBarNew( nTop+1, nRight, nBottom-1)
  532.    aScrollBar := ScrollBarDisplay( aScrollBar )
  533.    aScrollBar := ScrollBarUpdate( aScrollBar, RecPos, nRec,.T.) // Force disp.
  534.  
  535.    lMore := .t.
  536.    DO WHILE (lMore)
  537.       /* stabilize the display */
  538.       DO WHILE .NOT. b:stabilize()
  539.          IF (nEvent := NextAppEvent( @mp1, @mp2, @oXbp )) > xbe_None .AND. ;
  540.             (nEvent <> xbeM_Motion )
  541.             nEvent := AppEvent( @mp1, @mp2, @oXbp )
  542.             EXIT
  543.          ENDIF
  544.       ENDDO   
  545.  
  546.       IF ( b:stable )
  547.          /* display is stable */
  548.          IF ( b:hitTop .OR. b:hitBottom )
  549.             Tone(125, 0)
  550.          ENDIF
  551.  
  552.          // Make sure that the current record is showing
  553.          // up-to-date data in case we are on a network.
  554.          b:refreshCurrent()
  555.          DO WHILE .NOT. b:stabilize()
  556.          ENDDO
  557.          
  558.          aScrollBar := ScrollBarUpdate( aScrollBar, RecPos, nRec)
  559.  
  560.          /* everything's done; just wait for a key */
  561.  
  562.          nEvent := xbeM_Motion       // filter out event 
  563.          DO WHILE nEvent == xbeM_Motion  // "mouse is moved" 
  564.             nEvent := AppEvent( @mp1, @mp2, @oXbp, 0 ) 
  565.             IF nEvent == xbeM_Motion .AND. Set( _SET_HANDLEEVENT )
  566.                oXbp:HandleEvent( nEvent, mp1, mp2 )
  567.             ENDIF
  568.          ENDDO 
  569.  
  570.       ENDIF
  571.  
  572.       /* process key */
  573.       DO CASE
  574.          // Mouse movements on scrollbar     
  575.          CASE nEvent = xbeM_LbClick .AND. mp1[2]=nRight .and. mp1[1]=nBottom - 1
  576.             b:down()
  577.          CASE nEvent = xbeM_LbClick .AND. mp1[2]=nRight .and. mp1[1]=nTop + 1
  578.             b:up()
  579.          CASE nEvent = xbeM_LbClick .AND. mp1[2]=nRight .and. mp1[1]=nTop + 2
  580.            b:Pageup()
  581.          CASE nEvent = xbeM_LbClick .AND. mp1[2]=nRight .and. mp1[1]=nBottom - 2
  582.             b:PageDown()
  583.  
  584.          CASE ( nEvent == xbeK_DOWN ) .OR. ;
  585.                 ( nEvent = xbeM_Wheel .AND. mp2[2] = -120)
  586.             b:down()
  587.  
  588.          CASE ( nEvent == xbeK_UP ) .OR. ;
  589.                 ( nEvent = xbeM_Wheel .AND. mp2[2] = 120)
  590.             b:up()
  591.  
  592.          CASE ( nEvent == xbeK_PGDN )
  593.             b:pageDown()
  594.  
  595.          CASE ( nEvent == xbeK_PGUP )
  596.             b:pageUp()
  597.  
  598.          CASE ( nEvent == xbeK_CTRL_PGUP )
  599.             b:goTop()
  600.  
  601.          CASE ( nEvent == xbeK_CTRL_PGDN )
  602.             b:goBottom()
  603.  
  604.          CASE ( nEvent == xbeK_RIGHT )
  605.             b:right()
  606.  
  607.          CASE ( nEvent == xbeK_LEFT )
  608.             b:left()
  609.  
  610.          CASE ( nEvent == xbeK_HOME )
  611.             b:home()
  612.  
  613.          CASE ( nEvent == xbeK_END )
  614.             b:_end()
  615.  
  616.          CASE ( nEvent == xbeK_CTRL_LEFT )
  617.             b:panLeft()
  618.  
  619.          CASE ( nEvent == xbeK_CTRL_RIGHT )
  620.             b:panRight()
  621.  
  622.          CASE ( nEvent == xbeK_CTRL_HOME )
  623.             b:panHome()
  624.  
  625.          CASE ( nEvent == xbeK_CTRL_END )
  626.             b:panEnd()
  627.  
  628.          CASE ( nEvent == xbeK_ESC .OR. nEvent == xbeM_RbClick)
  629.             nPassRec := 0
  630.             lMore := .f.
  631.  
  632.          CASE ( nEvent == xbeK_RETURN .OR. nEvent == xbeK_F9 .OR. nEvent = xbeM_LbClick)
  633.             nPassRec := RECNO()
  634.             lMore := .f.
  635.  
  636.          OTHERWISE
  637.             TBHandleEvent( b, nEvent, mp1, mp2, oXbp)    
  638.       ENDCASE
  639.    ENDDO  // for WHILE (lmore)
  640.  
  641.    /* restore old screen */
  642.    DO WOUT WITH nTop,nLeft,nBottom,nRight,abuff
  643.    SetCursor(nCursSave)
  644.    SetColor(cColorSave)
  645.  
  646. RETURN (nPassRec)
  647.  
  648. /* -------------------------------------------------------------------- */
  649.  
  650. STATIC FUNCTION TbSkipWhil(n, bWhileCond)
  651.    LOCAL i := 0
  652.    IF n == 0 .OR. LASTREC() == 0
  653.       SKIP 0  // significant on a network
  654.  
  655.    ELSEIF ( n > 0 .AND. RECNO() <> LASTREC() + 1)
  656.       DO WHILE ( i < n )
  657.          SKIP 1
  658.          IF ( EOF() .OR. .NOT. Eval(bWhileCond) )
  659.             SKIP -1
  660.             RecPos = nRec
  661.             EXIT
  662.          ENDIF
  663.          i++
  664.          RecPos = RecPos + 1
  665.       ENDDO
  666.  
  667.    ELSEIF ( n < 0 )
  668.       DO WHILE ( i > n )
  669.          SKIP -1
  670.          IF ( BOF() )
  671.             RecPos = 1
  672.             EXIT
  673.          ELSEIF .NOT. Eval( (bWhileCond) )
  674.             SKIP
  675.             RecPos = 1
  676.             EXIT
  677.          ENDIF
  678.          i--
  679.          RecPos = RecPos - 1
  680.       ENDDO
  681.    ENDIF
  682. RETURN (i)
  683. * EOFcn TbSkipWhil()
  684.  
  685. /* -------------------------------------------------------------------- */
  686.  
  687. STATIC FUNCTION TbWhileTop(cKey)
  688.    SEEK cKey
  689.    RecPos = 1
  690. RETURN NIL
  691.  
  692. /* -------------------------------------------------------------------- */
  693.  
  694. STATIC FUNCTION TbWhileBot(cKey)
  695.    #include "set.ch"
  696.    LOCAL cSoftSave := SET(_SET_SOFTSEEK, .t.)
  697.    SEEK LEFT(cKey, LEN(cKey) -1) + CHR( ASC( RIGHT(cKey,1) ) +1)
  698.    SET(_SET_SOFTSEEK, cSoftSave)
  699.    SKIP -1
  700.    RecPos= nRec
  701. RETURN NIL
  702.  
  703. *  Scrolbar SYSTEM
  704. *  Implements a scroll bar that can be updated as the cursor moves down
  705. *  in a TBrowse object, ACHOICE(), DBEDIT(), or MEMOEDIT().
  706. *
  707. // The elements in aTab
  708. #define  TB_ROWTOP         1
  709. #define  TB_COLTOP         2
  710. #define  TB_ROWBOTTOM      3
  711. #define  TB_COLBOTTOM      4
  712. #define  TB_COLOR          5
  713. #define  TB_POSITION       6
  714.  
  715. #define  TB_ELEMENTS       6
  716.  
  717. // The Up and Down arrows, highlight and background char's for the thumb tab
  718. #define  TB_UPARROW        CHR(  24 )
  719. #define  TB_DNARROW        CHR(  25 )
  720. #define  TB_HIGHLIGHT      CHR( 178 )
  721. #define  TB_BACKGROUND     CHR( 176 )
  722.  
  723. *  ScrollBarNew( <nTopRow>, <nTopColumn>, <nBottomRow>, 
  724. *     <cColorString>, <nInitPosition> ) --> aScrollBar
  725. *  
  726. *  Create a new scroll bar array with the specified coordinates
  727. *
  728. FUNCTION ScrollBarNew( nTopRow, nTopColumn, nBottomRow, ;
  729.                         cColorString, nInitPosition )
  730.  
  731.    LOCAL aScrollBar := ARRAY( TB_ELEMENTS )
  732.  
  733.    aScrollBar[ TB_ROWTOP ]    := nTopRow
  734.    aScrollBar[ TB_COLTOP ]    := nTopColumn
  735.    aScrollBar[ TB_ROWBOTTOM ] := nBottomRow
  736.    aScrollBar[ TB_COLBOTTOM ] := nTopColumn
  737.  
  738.    // Set the default color to White on Black if none specified
  739.    IF cColorString == NIL
  740.       cColorString := "W/N"
  741.    ENDIF
  742.    aScrollBar[ TB_COLOR ]     := cColorString
  743.  
  744.    // Set the starting position
  745.    IF nInitPosition == NIL
  746.       nInitPosition := 1
  747.    ENDIF
  748.    aScrollBar[ TB_POSITION ]  := nInitPosition
  749.  
  750.    RETURN aScrollBar
  751.  
  752. *  ScrollBarDisplay( <aScrollBar> ) --> aScrollBar
  753. *  Display a scoll bar array to the screen
  754. *
  755. FUNCTION ScrollBarDisplay( aScrollBar )
  756.    LOCAL cOldColor, nRow
  757.  
  758.    cOldColor := SETCOLOR( aScrollBar[ TB_COLOR ] )
  759.  
  760.    // Draw the arrows
  761.    @ aScrollBar[ TB_ROWTOP ], aScrollBar[ TB_COLTOP ] SAY TB_UPARROW
  762.    @ aScrollBar[ TB_ROWBOTTOM ], aScrollBar[ TB_COLBOTTOM ] SAY TB_DNARROW
  763.  
  764.    // Draw the background
  765.    FOR nRow := (aScrollBar[ TB_ROWTOP ] + 1) TO (aScrollBar[ TB_ROWBOTTOM ] - 1)
  766.       @ nRow, aScrollBar[ TB_COLTOP ] SAY TB_BACKGROUND
  767.    NEXT
  768.  
  769.    SETCOLOR( cOldColor )
  770.  
  771.    RETURN aScrollBar
  772.  
  773. *  ScrollBarUpdate( <aScrollBar>, <nCurrent>, <nTotal>,
  774. *     <lForceUpdate> ) --> aScrollBar
  775. *
  776. *  Update scroll bar array with new tab position and redisplay tab
  777. *
  778. FUNCTION ScrollBarUpdate( aScrollBar, nCurrent, nTotal, lForceUpdate )
  779.  
  780.    LOCAL cOldColor, nNewPosition
  781.    LOCAL nScrollHeight := (aScrollBar[TB_ROWBOTTOM] - 1) - ;
  782.          (aScrollBar[TB_ROWTOP])
  783.  
  784.    IF nTotal < 1
  785.       nTotal := 1
  786.    ENDIF
  787.  
  788.    IF nCurrent < 1
  789.       nCurrent := 1
  790.    ENDIF
  791.  
  792.    IF nCurrent > nTotal
  793.       nCurrent := nTotal
  794.    ENDIF
  795.  
  796.    IF lForceUpdate == NIL
  797.       lForceUpdate := .F.
  798.    ENDIF
  799.  
  800.    cOldColor := SETCOLOR( aScrollBar[ TB_COLOR ] )
  801.  
  802.    // Determine the new position
  803.    nNewPosition := ROUND( (nCurrent / nTotal) * nScrollHeight, 0 )
  804.  
  805.    // Resolve algorithm oversights
  806.    nNewPosition := IF( nNewPosition < 1, 1, nNewPosition )
  807.    nNewPosition := IF( nCurrent == 1, 1, nNewPosition )
  808.    nNewPosition := IF( nCurrent >= nTotal, nScrollHeight, nNewPosition )
  809.  
  810.    // Overwrite the old position (if different), then draw in the new one
  811.    IF nNewPosition <> aScrollBar[ TB_POSITION ] .OR. lForceUpdate
  812.       @ (aScrollBar[ TB_POSITION ] + aScrollBar[ TB_ROWTOP ]), ;
  813.          aScrollBar[ TB_COLTOP ] SAY TB_BACKGROUND
  814.       @ (nNewPosition + aScrollBar[ TB_ROWTOP ]), aScrollBar[ TB_COLTOP ] SAY ;
  815.         TB_HIGHLIGHT
  816.       aScrollBar[ TB_POSITION ] := nNewPosition
  817.    ENDIF
  818.  
  819.    SETCOLOR( cOldColor )
  820.  
  821.    RETURN aScrollBar
  822. //
  823. //-----------------------------------------------------
  824. //
  825. FUNCTION UNINOM(Root)
  826. //
  827. // Returns a unique name for use in a network environment
  828. // under WINDOWS where a "local" filename is necessary
  829. // ROOT could be (for instance) "C:\AA": UNINOM will add 6 characters
  830.  
  831. LOCAL A,B,I
  832.  
  833. A=TIME()
  834. B=(((MONTH(DATE())*31;
  835.      +DAY(DATE()))*24;
  836.      +VAL(SUBSTR(A,1,2)))*60;
  837.      +VAL(SUBSTR(A,4,2)))*60;
  838.      +VAL(SUBSTR(A,7,2));
  839.  
  840. FOR I=1 TO 6
  841.    Root=Root+CHR(65+MOD(B,25))
  842.    B=INT(B/25)
  843. NEXT I
  844. RETURN Root
  845.  
  846. //
  847. //-----------------------------------------------------
  848. //
  849. FUNCTION SYSDATE
  850.  
  851. Local Mdate
  852. // used in lots of places to prevent errors at month end
  853. // mainly in facturation, promos, but not in bons
  854.  
  855. Mdate= IIF(DATE()>MDAT_MAX,MDAT_MAX,DATE())
  856.  
  857. RETURN Mdate
  858. *******
  859.  
  860.