home *** CD-ROM | disk | FTP | other *** search
/ PC World 2002 June / PCWorld_2002-06_cd.bin / Software / Komercni / xbase / express / exd17208.r04 / exp17 / X2clip / X2clip.prg < prev   
Text File  |  2002-01-30  |  20KB  |  891 lines
  1. /*
  2.  ╓──────────────────────────────────────────────────────────╖
  3.  ║  Program..: X2CLIP.PRG                                   ║
  4.  ║  Author...:  Roger J. Donnay                             ║
  5.  ║  Notice...: (c) DONNAY Software Designs 1987-1999        ║
  6.  ║  Date.....: Apr 20, 1999                                 ║
  7.  ║  Notes....: Xbase++ to Clipper Interface                 ║
  8.  ╙──────────────────────────────────────────────────────────╜
  9.  
  10.   Note:  This is part of the Clipper application
  11. */
  12.  
  13. #INCLUDE "inkey.CH"
  14. #include "DCXTOC.CH"
  15.  
  16. REQUEST COMIX
  17. REQUEST DBFCDX
  18. REQUEST DBFNTX
  19.  
  20. EXTERN achoice,acopy,adel,adir,afields,afill,ains,ampm,strzero,;
  21.        alltrim,ascan,asort,bin2i,bin2l,bin2w,;
  22.        curdir,dbedit,dbfilter,descend,diskspace,doserror,;
  23.        dbrelation,dbrselect,readinsert,setcancel,readexit,;
  24.        errorlevel,fclose,fcreate,ferror,fopen,fread,freadstr,;
  25.        fseek,fwrite,gete,hardcr,header,i2bin,isalpha,;
  26.        indexext,indexord,islower,isupper,isprinter,;
  27.        l2bin,lupdate,memoedit,memoline,memoread,memotran,;
  28.        memowrit,mlcount,mlpos,neterr,nextkey,left,alias,;
  29.        rat,savescreen,scroll,right,recsize,errorsys,netname,;
  30.        setcolor,setprc,soundex,strtran,stuff,tone,memory
  31.  
  32. FUNCTION DC_X2Clip( nHandle, cDefault, nTimeOut )
  33.  
  34. LOCAL nSaveArea := Select(), aStructure, i, nMaxCount, ;
  35.       nSeconds, bErrorBlock, aData
  36.  
  37. Inkey(1)
  38.  
  39. IF Valtype(nHandle) = 'C'
  40.    nHandle := Val(nHandle)
  41. ENDIF
  42.  
  43. nHandle := IIF(Valtype(nHandle)='N',nHandle,0 )
  44. nTimeOut := IIF(Valtype(nTimeOut)='N',nTimeOut,5 )
  45.  
  46. IF !Empty(cDefault)
  47.    Set(_SET_DEFAULT,cDefault)
  48. ENDIF
  49. CLOSE ALL
  50.  
  51. IF nHandle = 0
  52.    CLS
  53.    ? 'This program must be passed a valid Handle.'
  54.    ? 'It is designed for interaction with an Xbase++ program.'
  55.    ? 'See the eXPress++ documentation for more information.'
  56.    QUIT
  57. ENDIF
  58.  
  59. IF !File('X2Clip.Dbf')
  60.   aStructure := { ;
  61.    { 'OPERATION',   'N',     2, 0 },;
  62.    { 'DEFAULT',     'C',   100, 0 },;
  63.    { 'PATH',        'C',   100, 0 },;
  64.    { 'DATABASE',    'C',   100, 0 },;
  65.    { 'INDEX',       'C',   100, 0 },;
  66.    { 'RDD',         'C',    10, 0 },;
  67.    { 'SHARED',      'L',     1, 0 },;
  68.    { 'TAG',         'C',    10, 0 },;
  69.    { 'KEY',         'C',   254, 0 },;
  70.    { 'RECORD',      'N',    10, 0 },;
  71.    { 'WHILE',       'C',  4000, 0 },;
  72.    { 'FOR',         'C',  4000, 0 },;
  73.    { 'EVERY',       'N',    12, 3 },;
  74.    { 'DATE',        'D',     8, 0 },;
  75.    { 'TIME',        'C',     8, 0 },;
  76.    { 'ERRORCODE',   'N',     4, 0 },;
  77.    { 'UNIQUE',      'L',     1, 0 },;
  78.    { 'DESCEND',     'L',     1, 0 },;
  79.    { 'CURRCOUNT',   'N',    10, 0 },;
  80.    { 'MESSAGE',     'C',   254, 0 },;
  81.    { 'DATA',        'C',  4000, 0 },;
  82.    { 'PROGRAM',     'C',    10, 0 },;
  83.    { 'VERBOSE',     'L',     1, 0 },;
  84.    { 'INTERPRET',   'C',   254, 0 },;
  85.    { 'ACTIVE',      'L',     1, 0 },;
  86.    { 'DONE',        'L',     1, 0 },;
  87.    { 'MAXCOUNT',    'N',    12, 0 },;
  88.    { 'USER1',       'C',   254, 0 },;
  89.    { 'USER2',       'C',   254, 0 },;
  90.    { 'USER3',       'C',   254, 0 },;
  91.    { 'USER4',       'C',   254, 0 },;
  92.    { 'NEXT',        'N',    10, 0 },;
  93.    { 'REST',        'L',     1, 0 },;
  94.    { 'DELETED',     'L',     1, 0 } }
  95.  
  96.  
  97.   dbCreate( 'X2Clip.DBF', aStructure, 'DBFNTX' )
  98.   SELE 200
  99.   USE X2Clip VIA 'DBFNTX' SHARED
  100.   FOR i := 1 TO 50
  101.     APPEND BLANK
  102.   NEXT
  103.   CLOSE
  104. ENDIF
  105.  
  106. ? 'Opening Handle #' + Alltrim(Str(nHandle))
  107.  
  108. DO WHILE Inkey(.1) # K_ESC
  109.  
  110.   IF !_DbSel('X2CLIP')
  111.      SELE 200
  112.      USE X2Clip SHARED VIA "DBFNTX"
  113.      GO nHandle
  114.      IF _RecLock(5)
  115.        REPL X2CLIP->done WITH .t., ;
  116.             X2CLIP->operation WITH XC_DONE
  117.        COMMIT
  118.        UNLOCK
  119.      ENDIF
  120.      SELE (nSaveArea)
  121.      nSeconds := Seconds()
  122.   ENDIF
  123.  
  124.   X2Clip->(dbGoTo(nHandle))
  125.  
  126.   SELE (nSaveArea)
  127.   ? Alias(), X2Clip->maxcount
  128.  
  129.   IF !Empty(Alias()) .AND. X2Clip->maxcount < 0
  130.      nMaxCount := RecCount()
  131.      SELE X2Clip
  132.      IF _RecLock(5)
  133.         REPL X2Clip->maxcount WITH nMaxCount
  134.         COMMIT
  135.         UNLOCK
  136.      ENDIF
  137.      SELE (nSaveArea)
  138.      nSeconds := Seconds()
  139.   ENDIF
  140.  
  141.   IF X2Clip->operation = XC_EXIT
  142.  
  143.     SELE (nSaveArea)
  144.     IF !Empty(Alias()) .AND. Alias() # 'X2CLIP'
  145.       ? 'Closing ' + Alias(), X2CLIP->done, X2CLIP->active
  146.       Inkey(1)
  147.     ENDIF
  148.     SELE SELECT('X2CLIP')
  149.     IF _RecLock(5)
  150.       REPL X2CLIP->done WITH .t., ;
  151.            X2CLIP->active WITH .f.
  152.     ENDIF
  153.     CLOSE ALL
  154.     EXIT
  155.  
  156.   ELSEIF X2Clip->operation = XC_OPENDATA
  157.  
  158.     SELE (nSaveArea)
  159.     OpenData( nHandle, cDefault )
  160.     nSaveArea := Select()
  161.     Done( nHandle, cDefault )
  162.  
  163.   ELSEIF X2Clip->operation = XC_OPENINDEX
  164.  
  165.     SELE (nSaveArea)
  166.     OpenIndex( nHandle, cDefault )
  167.     Done( nHandle, cDefault )
  168.  
  169.   ELSEIF X2Clip->operation = XC_PROGRAM
  170.  
  171.     bErrorBlock := ErrorBlock({|e|FileError(e,X2CLIP->program,nHandle,cDefault)})
  172.     aData := _Str2Ar(X2Clip->data)
  173.     SELE x2clip
  174.     IF _Reclock(5)
  175.       REPL X2CLIP->data WITH ''
  176.       COMMIT
  177.       UNLOCK
  178.     ENDIF
  179.     SELE (nSaveArea)
  180.     IF X2CLIP->verbose
  181.       ? 'Calling custom program: ' + X2Clip->program
  182.     ENDIF
  183.     DO &(X2Clip->program) WITH aData, nHandle, cDefault
  184.     Done( nHandle, cDefault )
  185.     ErrorBlock(bErrorBlock)
  186.  
  187.   ELSEIF X2Clip->operation = XC_CREATEINDEX
  188.  
  189.     SELE (nSaveArea)
  190.     CreateIndex( nHandle, cDefault )
  191.     Done( nHandle, cDefault )
  192.  
  193.   ELSEIF X2Clip->operation = XC_COPYDATA
  194.  
  195.     SELE (nSaveArea)
  196.     CopyData( nHandle, cDefault )
  197.     Done( nHandle, cDefault )
  198.  
  199.   ELSEIF X2Clip->operation = XC_CLOSEDATA
  200.  
  201.     SELE (nSaveArea)
  202.     CLOSE
  203.     Done( nHandle, cDefault )
  204.  
  205.   ENDIF
  206.  
  207.   FT_IamIdle()
  208.  
  209. ENDDO
  210.  
  211. RETURN nil
  212.  
  213. /* ---------------------- */
  214.  
  215. STATIC FUNCTION OpenData( nHandle, cDefault )
  216.  
  217. LOCAL cDatabase, cDefaultDir, bErrorBlock, nError, ;
  218.       cSaveDefault := Set(_SET_DEFAULT), cRdd, lShared, ;
  219.       nSaveArea, lVerbose, cSavePath := Set(_SET_PATH), cPath
  220.  
  221. BEGIN SEQUENCE
  222.  
  223. bErrorBlock := ErrorBlock({|e|FileError(e,cDatabase,nHandle,cDefault)})
  224.  
  225. cDefaultDir := Alltrim(X2CLIP->default)
  226. cDatabase := Alltrim(X2CLIP->database)
  227. cPath := Alltrim(X2CLIP->path)
  228. cRdd := Alltrim(X2CLIP->rdd)
  229. lShared := X2CLIP->shared
  230. lVerbose := X2CLIP->verbose
  231.  
  232. IF Empty(cDatabase)
  233.   nError := XCERROR_NOFILENAME
  234.   BREAK
  235. ENDIF
  236.  
  237. IF !Empty(cDefaultDir)
  238.   Set(_SET_DEFAULT,cDefaultDir)
  239. ENDIF
  240.  
  241. IF !Empty(cPath)
  242.   Set(_SET_PATH,cPath)
  243. ENDIF
  244.  
  245. IF Empty(cRdd)
  246.   cRdd := 'DBFNTX'
  247. ENDIF
  248.  
  249. nError := 0
  250.  
  251. SELE 0
  252.  
  253. IF lShared
  254.   IF lVerbose
  255.     ? 'USE ' + cDatabase + ' VIA ' + cRdd + ' SHARED'
  256.   ENDIF
  257.   USE (cDatabase) VIA (cRdd) SHARED
  258. ELSE
  259.   IF lVerbose
  260.     ? 'USE ' + cDatabase + ' VIA ' + cRdd
  261.   ENDIF
  262.   USE (cDatabase) VIA (cRdd)
  263. ENDIF
  264.  
  265. END SEQUENCE
  266. ErrorBlock(bErrorBlock)
  267. Set(_SET_DEFAULT,cSaveDefault)
  268. Set(_SET_PATH,cSavePath)
  269.  
  270. IF nError > 0
  271.   nSaveArea := Select()
  272.   SELE X2Clip
  273.   IF _RecLock(2)
  274.     REPL X2Clip->errorcode WITH nError
  275.     COMMIT
  276.     UNLOCK
  277.   ENDIF
  278.   SELE (nSaveArea)
  279. ENDIF
  280.  
  281. RETURN nError
  282.  
  283. /* ---------------------- */
  284.  
  285. STATIC FUNCTION OpenIndex( nHandle, cDefault )
  286.  
  287. LOCAL cIndex, cDefaultDir, bErrorBlock, nError, lVerbose, ;
  288.       cSaveDefault := Set(_SET_DEFAULT), nSaveArea, ;
  289.       cTagName, cPath, cSavePath := Set(_SET_PATH)
  290.  
  291. BEGIN SEQUENCE
  292.  
  293. bErrorBlock := ErrorBlock({|e|FileError(e,cIndex,nHandle,cDefault)})
  294. cDefaultDir := Alltrim(X2CLIP->default)
  295. cPath := Alltrim(X2CLIP->path)
  296. cIndex := Alltrim(X2CLIP->index)
  297. cTagName := Alltrim(X2CLIP->tag)
  298. lVerbose := X2CLIP->verbose
  299.  
  300. IF Empty(cIndex)
  301.   nError := XCERROR_NOFILENAME
  302.   BREAK
  303. ENDIF
  304.  
  305. IF !Empty(cDefaultDir)
  306.   Set(_SET_DEFAULT,cDefaultDir)
  307. ENDIF
  308.  
  309. IF !Empty(cPath)
  310.   Set(_SET_PATH,cPath)
  311. ENDIF
  312.  
  313. nError := 0
  314.  
  315. IF lVerbose
  316.   ? 'SET INDEX TO ' + cIndex + 'ADDITIVE'
  317. ENDIF
  318. SET INDEX TO (cIndex) ADDITIVE
  319. IF !Empty(cTagName)
  320.    OrdSetFocus(cTagName)
  321. ENDIF
  322.  
  323. END SEQUENCE
  324. ErrorBlock(bErrorBlock)
  325. Set(_SET_DEFAULT,cSaveDefault)
  326. Set(_SET_PATH,cSavePath)
  327.  
  328. IF nError > 0
  329.   nSaveArea := Select()
  330.   SELE X2Clip
  331.   IF _RecLock(2)
  332.     REPL X2Clip->errorcode WITH nError
  333.     COMMIT
  334.     UNLOCK
  335.   ENDIF
  336.   SELE (nSaveArea)
  337. ENDIF
  338.  
  339. RETURN nError
  340.  
  341. /* ------------------------- */
  342.  
  343. STATIC FUNCTION CreateIndex( nHandle, cDefault )
  344.  
  345. LOCAL cFor, cWhile, cKey, cTagName, cIndex, lUnique, lDescend, ;
  346.       bFor, bWhile, bErrorBlock := ErrorBlock(), nError := 0, ;
  347.       lCombined, nSaveArea, nEvery, bEval, lVerbose, nMaxCount
  348.  
  349. BEGIN SEQUENCE
  350.  
  351. bErrorBlock := ErrorBlock({|e|FileError(e,cIndex,nHandle,cDefault)})
  352.  
  353. cFor := Alltrim(X2Clip->for)
  354. cWhile := Alltrim(X2Clip->while)
  355. cKey := Alltrim(X2Clip->key)
  356. cTagName := Alltrim(X2Clip->tag)
  357. cIndex := Alltrim(X2Clip->index)
  358. lDescend := X2Clip->descend
  359. lUnique := X2Clip->unique
  360. nEvery := X2Clip->every
  361. lVerbose := X2Clip->verbose
  362. IF !EMPTY(cFor)
  363.   bFor := {|| &(cFor) }
  364. ELSE
  365.   bFor := nil
  366.   cFor := nil
  367. ENDIF
  368.  
  369. IF Empty(cKey)
  370.   nError := XCERROR_NOINDEXKEY
  371.   BREAK
  372. ENDIF
  373.  
  374. IF Empty(cIndex)
  375.   nError := XCERROR_NOFILENAME
  376.   BREAK
  377. ENDIF
  378.  
  379. IF nEvery < 1 .AND. nEvery > 0
  380.    nEvery := Int(nEvery*RecCount())
  381. ELSEIF nEvery = 0
  382.    nEvery := Int(RecCount()/100)
  383. ENDIF
  384.  
  385. bEval := {||DC_XCUpdate(RecNo(),RecCount(),1)}
  386.  
  387. IF lVerbose
  388.    ? 'Creating Index Tag ' + cTagName + ' of ' + cIndex
  389.    ? 'Key:', cKey
  390.    ? 'For:', cFor
  391.    ? 'Alias:', Alias()
  392. ENDIF
  393.  
  394. OrdCondSet( cFor, bFor,.t.,, bEval, nEvery,RecNo(),,,, lDescend )
  395. OrdCreate(cIndex,cTagName,cKey,{||&cKey},IIF(lUnique,.t.,nil))
  396.  
  397. END SEQUENCE
  398. ErrorBlock(bErrorBlock)
  399.  
  400. IF nError > 0
  401.   nSaveArea := Select()
  402.   SELE X2Clip
  403.   IF _RecLock(2)
  404.     REPL X2Clip->errorcode WITH nError
  405.     COMMIT
  406.     UNLOCK
  407.   ENDIF
  408.   SELE (nSaveArea)
  409. ENDIF
  410.  
  411. RETURN nError
  412.  
  413.  
  414. /* ------------------------- */
  415.  
  416. STATIC FUNCTION CopyData( nHandle, cDefault )
  417.  
  418. LOCAL cFor, cWhile, cKey, cFilter, bWhile, bErrorBlock := ErrorBlock(), nError := 0, ;
  419.       nSaveArea, lVerbose, cToFile
  420.  
  421. BEGIN SEQUENCE
  422.  
  423. ? 'COPYING DATA'
  424.  
  425. bErrorBlock := ErrorBlock({|e|FileError(e,cIndex,nHandle,cDefault)})
  426.  
  427. cFileName := Alltrim(X2Clip->database)
  428. cFor := Alltrim(X2Clip->for)
  429. cWhile := Alltrim(X2Clip->while)
  430. cRdd := Alltrim(X2Clip->rdd)
  431. lVerbose := X2Clip->verbose
  432. cToFile := Alltrim(X2Clip->user1)
  433.  
  434. IF !Empty(cFor)
  435.   ? cFor
  436.   SET FILTER TO &(cFor)
  437. ENDIF
  438.  
  439. ? cFileName
  440. ? cToFile
  441.  
  442. COPY TO (cToFile) VIA (cRdd)
  443.  
  444. END SEQUENCE
  445. ErrorBlock(bErrorBlock)
  446.  
  447. IF nError > 0
  448.   nSaveArea := Select()
  449.   SELE X2Clip
  450.   IF _RecLock(2)
  451.     REPL X2Clip->errorcode WITH nError
  452.     COMMIT
  453.     UNLOCK
  454.   ENDIF
  455.   SELE (nSaveArea)
  456. ENDIF
  457.  
  458. RETURN nError
  459.  
  460.  
  461. /* ----------------------- */
  462.  
  463. STATIC FUNCTION Done( nHandle, cDefault )
  464.  
  465. LOCAL cOldDefault := Set(_SET_DEFAULT)
  466.  
  467. IF !_DbSel('X2CLIP')
  468.    IF !Empty(cDefault)
  469.       Set(_SET_DEFAULT,cDefault)
  470.    ENDIF
  471.    USE X2CLIP NEW SHARED VIA "DBFNTX"
  472.    GO nHandle
  473.    Set(_SET_DEFAULT,cOldDefault)
  474. ENDIF
  475.  
  476. IF _RecLock(5)
  477.    REPL X2CLIP->operation WITH XC_DONE, ;
  478.         X2CLIP->done WITH .t., ;
  479.         X2CLIP->default WITH '', ;
  480.         X2CLIP->database WITH '', ;
  481.         X2CLIP->index WITH '', ;
  482.         X2CLIP->rdd WITH '', ;
  483.         X2CLIP->shared WITH .f., ;
  484.         X2CLIP->tag WITH '', ;
  485.         X2CLIP->key WITH '', ;
  486.         X2CLIP->record WITH 0, ;
  487.         X2CLIP->date WITH CTOD('  /  /  '), ;
  488.         X2CLIP->time WITH '', ;
  489.         X2CLIP->while WITH '', ;
  490.         X2CLIP->for WITH '', ;
  491.         X2CLIP->errorcode WITH 0, ;
  492.         X2CLIP->unique WITH .f., ;
  493.         X2CLIP->descend WITH .f., ;
  494.         X2CLIP->currcount WITH 0, ;
  495.         X2CLIP->message WITH '', ;
  496.         X2CLIP->program WITH '', ;
  497.         X2CLIP->interpret WITH '', ;
  498.         X2CLIP->maxcount WITH -1, ;
  499.         X2CLIP->path WITH ''
  500.    COMMIT
  501.    UNLOCK
  502.  
  503. ENDIF
  504.  
  505. RETURN nil
  506.  
  507. /* ------------------- */
  508.  
  509. STATIC FUNCTION FileError( e, cFileName, nHandle, cDefault )
  510.  
  511. LOCAL cErrorInfo, cMoreInfo, nOSCode, aError, ;
  512.       cOldDefault := Set(_SET_DEFAULT)
  513.  
  514. cErrorInfo :=  e:description()+' '+e:operation()+;
  515.                IIF(!EMPTY(e:subsystem()),;
  516.                "  "+e:subsystem() + "[" + LTrim(Str(e:subCode())) + "]",'')+;
  517.                IIF(e:OSCode()>0," OS Code["+LTrim(Str(e:OSCode()))+"]",'')
  518.  
  519.  
  520. ? cErrorInfo
  521.  
  522. cMoreInfo := ''
  523. nOSCode := e:OSCode()
  524. DO CASE
  525.     CASE nOsCode=2
  526.       cMoreInfo := 'File not found.'
  527.     CASE nOsCode=3
  528.       cMoreInfo := 'Path not found.'
  529.     CASE nOsCode=4
  530.       cMoreInfo := 'Out of File Handles.'
  531.     CASE nOsCode=5
  532.       cMoreInfo := 'Access Denied.'
  533.     CASE nOsCode=15
  534.       cMoreInfo := 'Invalid Drive was Specified.'
  535.     CASE nOsCode=21
  536.       cMoreInfo := 'Drive not Ready.'
  537.     CASE nOsCode=32
  538.       cMoreInfo := 'Sharing Violation.'
  539.     OTHERWISE
  540.       nOsCode := 99
  541.       cMoreInfo := 'Unknown'
  542. ENDCASE
  543.  
  544. aError := { nOsCode, cFileName, cErrorInfo, cMoreInfo }
  545.  
  546. IF !_DbSel('X2CLIP')
  547.    Set(_SET_DEFAULT,cDefault)
  548.    USE X2CLIP NEW SHARED VIA "DBFNTX"
  549.    GO nHandle
  550. ENDIF
  551. Set(_SET_DEFAULT,cOldDefault)
  552. Done( nHandle )
  553. IF _RecLock(5)
  554.    REPL X2CLIP->errorcode WITH nOSCode, ;
  555.         X2CLIP->data WITH _Ar2Str(aError), ;
  556.         X2CLIP->active WITH .f.
  557.    COMMIT
  558.    UNLOCK
  559.    QUIT
  560. ENDIF
  561.  
  562. RETURN nil
  563.  
  564. /* -------------------- */
  565.  
  566. FUNCTION DC_XCUpdate( nCurr, nMax, nEvery, aData )
  567.  
  568. LOCAL nSaveArea
  569.  
  570. nCurr := IIF( Valtype(nCurr)='N',nCurr,RecNo() )
  571. nMax := IIF( Valtype(nMax)='N',nMax,RecCount() )
  572. nEvery := Int(IIF( Valtype(nEvery)='N',nEvery,1 ))
  573.  
  574. IF nCurr % nEvery # 0 .AND. nCurr < nMax
  575.   RETURN nil
  576. ENDIF
  577.  
  578. nSaveArea := Select()
  579. SELE X2Clip
  580. IF _RecLock(5)
  581.   REPL X2CLIP->currcount WITH nCurr, ;
  582.        X2CLIP->maxcount WITH nMax, ;
  583.        X2CLIP->every WITH nEvery
  584.   IF Valtype(aData) = 'A'
  585.      REPL X2CLIP->data WITH _Ar2Str(aData)
  586.   ENDIF
  587.   COMMIT
  588.   UNLOCK
  589. ENDIF
  590. SELE (nSaveArea)
  591.  
  592. RETURN nil
  593.  
  594. /* -------------------- */
  595.  
  596. FUNCTION DC_XCReturn( aData )
  597.  
  598. LOCAL nSaveArea  := Select()
  599.  
  600. SELE X2Clip
  601.  
  602. IF _RecLock(5)
  603.   REPL X2CLIP->data WITH _Ar2Str(aData)
  604.   COMMIT
  605.   UNLOCK
  606. ENDIF
  607. SELE (nSaveArea)
  608.  
  609. RETURN nil
  610.  
  611. /* -------------------- */
  612.  
  613. FUNCTION DC_XCOk()
  614.  
  615. RETURN !X2Clip->done
  616.  
  617. /* ------------------- */
  618.  
  619. STATIC FUNCTION _dbsel ( cAlias )
  620.  
  621. LOCAL i
  622.  
  623. cAlias := IIF(Valtype(cAlias)='C',UPPER(cAlias),'')
  624. IF SELECT(cAlias)>0 .AND. !(':'$cAlias)
  625.   SELE SELECT(cAlias)
  626.   RETURN .t.
  627. ENDIF
  628. RETURN .f.
  629.  
  630. /* ------------------- */
  631.  
  632. STATIC FUNCTION _reclock ( nWaitTime )
  633.  
  634. LOCAL  nWait
  635.  
  636. nWaitTime := IIF(Valtype(nWaitTime)='N',nWaitTime,1)
  637. IF DBRLOCK()
  638.   RETURN (.T.)   // locked
  639. ENDIF
  640. DO WHILE .T.
  641.   nWait := nWaitTime
  642.   DO WHILE (nWaitTime=0 .OR. nWait>0)
  643.     IF DBRLOCK()     // locked
  644.       RETURN (.T.)
  645.     ENDIF
  646.     INKEY(.5)     // wait 1/2 second
  647.     nWait  :=  nWait - .5
  648.   ENDDO
  649.   RETURN .F.
  650. ENDDO
  651. RETURN (.F.)      // not locked
  652.  
  653. // ----------------- //
  654.  
  655. STATIC FUNCTION _ar2str ( aArray, lHeader )
  656.  
  657. LOCAL cArray := ''
  658. lHeader := IIF(Valtype(lHeader)='L',lHeader,.f.)
  659. IF lHeader
  660.   cArray := CHR(1)+'Array String:'
  661. ENDIF
  662. _dcStore( aArray, @cArray )
  663. RETURN cArray
  664.  
  665.  
  666. // ----------------- //
  667.  
  668. STATIC FUNCTION _dcStore( xThing, cArray )
  669. LOCAL cItem
  670.  
  671. DO CASE
  672.  
  673.    CASE valtype( xThing ) == "A"
  674.       _dcarray( xThing, @cArray )
  675.  
  676.    OTHERWISE
  677.       cItem := _dcitem( xThing )
  678.       IF Valtype( cItem ) = 'C'
  679.         cArray += cItem
  680.       ENDIF
  681.  
  682. ENDCASE
  683. RETURN  nil
  684.  
  685. // ----------------- //
  686.  
  687. STATIC FUNCTION _dcArray( aArray, cArray )
  688.  
  689. LOCAL i, cItem, cL2bin := l2bin(len(aArray))
  690.  
  691. IF CHR(26)$cL2bin
  692.   cArray += "O"+ DC_l2Dec(len(aArray))
  693. ELSE
  694.   cArray += "A"+ cL2bin
  695. ENDIF
  696. FOR i = 1 TO Len(aArray)
  697.   cItem := _dcitem( aArray[i], @cArray )
  698.   IF Valtype( cItem ) = 'C'
  699.     cArray += cItem
  700.   ENDIF
  701. NEXT i
  702. RETURN nil
  703.  
  704. // ----------------- //
  705.  
  706. STATIC FUNCTION _dcItem ( xItem, cArray )
  707.  
  708. LOCAL cRetVal, cType := Valtype( xItem ), cL2bin
  709.  
  710. DO CASE
  711.  
  712.    CASE cType == "C"
  713.       cL2bin := l2bin( Len( xItem ))
  714.       IF CHR(26)$cL2bin
  715.         cRetVal := "M"+DC_l2Dec( len( xItem)) + xItem
  716.       ELSE
  717.         cRetVal := "C"+cL2bin+xItem
  718.       ENDIF
  719.  
  720.    CASE cType == "N"
  721.       IF '.'$STR(xItem)
  722.         xItem := STR(xItem)
  723.         cRetVal := "F"+l2Bin( len( xItem)) + xItem
  724.       ELSE
  725.         cL2bin := l2bin(xItem)
  726.         IF CHR(26)$cL2bin
  727.           cRetVal := "W"+DC_l2Dec(xItem)
  728.         ELSE
  729.           cRetVal := "N"+l2bin(xItem)
  730.         ENDIF
  731.       ENDIF
  732.  
  733.    CASE cType == "L"
  734.       cRetVal := "L"+if(xItem, "T", "F")
  735.  
  736.    CASE cType == "U"
  737.       cRetVal := "U"
  738.  
  739.    CASE cType == "D"
  740.       cRetVal := "D"+l2bin( xItem - ctod("01/01/70") )
  741.  
  742.    CASE cType == "B"
  743.       cRetVal := "B"
  744.  
  745.    OTHERWISE
  746.       _dcStore( xItem, @cArray )
  747.  
  748. ENDCASE
  749.  
  750. RETURN  cRetVal
  751.  
  752.  
  753. // ----------------- //
  754.  
  755. STATIC FUNCTION _str2ar ( cString )
  756.  
  757. LOCAL nPosition := 1, cArray := cString
  758. IF SubStr(cArray,1,14)==CHR(1)+'Array String:'
  759.   cArray := SubStr(cString,15)
  760. ENDIF
  761. RETURN _dcGet( @nPosition, @cArray )
  762.  
  763. // ----------------- //
  764.  
  765. STATIC FUNCTION _dcGet ( nPosition, cArray )          // get the next thing
  766.  
  767. LOCAL nLength, i, cAttrib, cRetVal
  768.  
  769. // get cAttrib
  770. cAttrib := substr( cArray, nPosition++, 1 )
  771.  
  772. DO CASE
  773.  
  774.   CASE cAttrib $ 'CNADF'
  775.     nLength := bin2l( substr( cArray, nPosition, 4 ) )
  776.     nPosition += 4
  777.  
  778.     DO CASE
  779.  
  780.       CASE cAttrib == "C"
  781.         cRetVal := substr( cArray, nPosition, nLength )
  782.         nPosition += nLength
  783.  
  784.       CASE cAttrib == "F"
  785.         cRetVal := VAL(substr( cArray, nPosition, nLength ))
  786.         nPosition += nLength
  787.  
  788.       CASE cAttrib == "N"
  789.         cRetVal := nLength
  790.  
  791.       CASE cAttrib == "A"
  792.         cRetVal := array( nLength )
  793.         FOR i = 1 TO nLength
  794.            cRetVal[i] := _dcget( @nPosition, @cArray )
  795.         NEXT i
  796.  
  797.       CASE cAttrib == "D"
  798.         cRetVal := ctod("01/01/70")+nLength
  799.  
  800.     ENDCASE
  801.  
  802.   CASE cAttrib = 'M'
  803.     nLength := dc_dec2l( substr( cArray, nPosition, 12 ))
  804.     nPosition += 12
  805.     cRetVal := substr( cArray, nPosition, nLength )
  806.     nPosition += nLength
  807.  
  808.   CASE cAttrib = 'W'
  809.     nLength := dc_dec2l( substr( cArray, nPosition, 12 ))
  810.     nPosition += 12
  811.     cRetVal := nLength
  812.  
  813.   CASE cAttrib == "O"
  814.     nLength := dc_dec2l( substr( cArray, nPosition, 12 ))
  815.     nPosition += 12
  816.     cRetVal := array( nLength )
  817.     FOR i = 1 TO nLength
  818.       cRetVal[i] := _dcget( @nPosition, @cArray )
  819.     NEXT i
  820.  
  821.   CASE cAttrib = 'L'
  822.     cRetVal := if( substr( cArray, nPosition++, 1 ) == "T", .t., .f. )
  823.  
  824.   CASE cAttrib $ 'UB'
  825.     cRetVal := nil
  826.  
  827.   OTHERWISE
  828.  
  829. ENDCASE
  830.  
  831. RETURN  cRetVal
  832.  
  833. /* ------------------- */
  834.  
  835. STATIC FUNCTION dc_dec2l ( cNum )
  836.  
  837. RETURN VAL(Substr(cNum,1,3))*1 + ;
  838.        VAL(Substr(cNum,4,3))*256 + ;
  839.        VAL(Substr(cNum,7,3))*65536 + ;
  840.        VAL(Substr(cNum,10,3))*65536*65536
  841.  
  842. /* ------------------- */
  843.  
  844. STATIC FUNCTION dc_l2dec ( nNum )
  845.  
  846. LOCAL cVal := l2bin( nNum )
  847. RETURN STRTRAN(STR(ASC(SubStr(cVal,1,1)),3) + ;
  848.                STR(ASC(SubStr(cVal,2,1)),3) + ;
  849.                STR(ASC(SubStr(cVal,3,1)),3) + ;
  850.                STR(ASC(SubStr(cVal,4,1)),3),' ','0')
  851.  
  852. /* ---------------------- */
  853.  
  854. FUNCTION XClip60( aData, nHandle )
  855.  
  856. LOCAL cDefault, cDatabase, cIndex, cRdd, dDate, cAreaCode, ;
  857.       nRecords := 0, cPath, nEvery
  858.  
  859. cDefault  := aData[1]
  860. cPath     := aData[2]
  861. cDatabase := aData[3]
  862. cIndex    := aData[4]
  863. cRdd      := aData[5]
  864. dDate     := aData[6]
  865. cAreaCode := aData[7]
  866. nEvery    := aData[8]
  867.  
  868. SET DEFAULT TO (cDefault)
  869. SET PATH TO (cPath)
  870. USE (cDatabase) SHARED VIA cRdd
  871.  
  872. GO TOP
  873. DO WHILE !Eof()
  874.   IF _FIELD->areacode == cAreaCode
  875.      IF _RecLock(5)
  876.        REPL _FIELD->date WITH DTOC(dDate)
  877.        nRecords++
  878.        COMMIT
  879.        UNLOCK
  880.      ENDIF
  881.   ENDIF
  882.   DC_XCUpdate( RecNo(), RecCount(), nEvery )
  883.   SKIP
  884. ENDDO
  885. CLOSE
  886.  
  887. DC_XCReturn( { nRecords } )
  888.  
  889. RETURN nil
  890.  
  891.