home *** CD-ROM | disk | FTP | other *** search
/ DOS Wares / doswares.zip / doswares / DATABASE / DBASE5 / CUA_SAMP.ZIP / MDFWD.PRG < prev    next >
Encoding:
Text File  |  1994-06-24  |  8.9 KB  |  231 lines
  1. *.............................................................................
  2. *
  3. *   Program Name: MDFWD.PRG           Copyright: Borland International
  4. *   Date Created:  8 Apr 94            Language: dBASE 5.0
  5. *   Time Created: 16:24:01               Author: Borland dBASE R&D
  6. *   /brief/library.src
  7. *.............................................................................
  8.  
  9. #define kQte CHR(34)
  10. #define ALLTRIM(kStr) LTRIM(RTRIM(kStr))
  11.  
  12. *........................................................................
  13. * Procedure Name:   MDFwd
  14. * Parameters:       None
  15. * Ext Memvars:      None
  16. * Description:      Searches forward from the current record for a given
  17. *                   value in the current field
  18. *........................................................................
  19. PROCEDURE MDFwd
  20.     PRIVATE lVoid, xValue, cFilter, nRec, oFRef, oRef, lValid, cStr, nLen
  21.     PRIVATE nLeft, lFlag, lCase, tFilter, nSDec, nSPre, tStr, lFwd, ;
  22.             startAtEof
  23.     
  24.     #include "TALKOFF.HDB"
  25.  
  26.     lValid = .F.
  27.     lFlag  = .F.
  28.     lCase  = .F.
  29.     lFwd   = .T.
  30.  
  31.     *-------------------------------------------------------
  32.     *-- Check to see if this is a forward or backward search
  33.     *-------------------------------------------------------
  34.     IF UPPER(This.Name) = "DBMITEM8"
  35.         lFwd = .F.
  36.     ENDIF    
  37.  
  38.     *------------------------------------------------------------------
  39.     *-- Get the object reference to the Form object.  Remember This. is
  40.     *-- the menu item.
  41.     *------------------------------------------------------------------
  42.     oFRef = This.Form
  43.  
  44.     IF oFRef.ClassName = "FORM" .OR. oFRef.ClassName = "BROWSE"
  45.  
  46.         IF RECCOUNT() = 0
  47.             DO InfoMsg WITH [This file has no records to search against.]
  48.             #include "TALKON.HDB"
  49.             RETURN
  50.         ENDIF
  51.  
  52.         *-----------------------------------------------------------
  53.         *-- Get an object reference to the current field on the form
  54.         *-- or browse and make sure it has a datalink.
  55.         *-----------------------------------------------------------
  56.         IF UPPER(oFRef.ClassName) = "FORM"
  57.             oRef = oFRef.ActiveControl()
  58.         ENDIF
  59.         DO CASE
  60.             CASE UPPER(oFRef.ClassName) = "BROWSE"
  61.                 oRef = oFRef.FieldList
  62.                 oRef = oRef.ActiveField()
  63.                 IF TYPE( "oRef.DataLink" ) = "C" .AND. ;
  64.                    .NOT. ISBLANK(oRef.DataLink)
  65.                     lValid = .T.
  66.                 ENDIF    
  67.             CASE UPPER(oRef.ClassName) = "ENTRYFIELD"
  68.                 IF TYPE( "oRef.DataLink" ) = "C" .AND. ;
  69.                    .NOT. ISBLANK(oRef.DataLink)
  70.                     lValid = .T.
  71.                 ENDIF    
  72.         ENDCASE
  73.  
  74.         *-----------------------------------------
  75.         *-- Don't search if we are on a memo field
  76.         *-----------------------------------------
  77.         IF lValid
  78.             tStr = UPPER(FldStr(oRef.DataLInk))
  79.             tStr = RIGHT(tStr, LEN(tStr) - RAT("[", tStr))
  80.             IF "M" $ tStr
  81.                 lValid = .F.
  82.             ENDIF    
  83.         ENDIF
  84.  
  85.         IF lValid
  86.  
  87.             StartAtEof = EOF()
  88.  
  89.             lCase = IIF(oFRef.MenuBar1.dbMBar3.dbMItem9.Checked, .T., .N.)
  90.             cStr = oRef.DataLink
  91.             nLen = FldLen(cStr)
  92.             
  93.             #include "MDFWD.DFM"
  94.             
  95.             IF .NOT. lFwd
  96.                 MDFwd.Text = "Backward Search"
  97.             ENDIF
  98.                 
  99.             IF nLen > 40
  100.                 MDFwd.etName4.Width = 40
  101.                 nLen = 40
  102.             ELSE
  103.                 MDFwd.etName4.Width = nLen
  104.             ENDIF
  105.             
  106.             nLeft = MAX(nLen,LEN(ALLTRIM(LEFT(cStr, 40))))
  107.             
  108.             IF nLeft < 40
  109.                 nLeft = 1 + INT((40 - nLeft) / 2)
  110.                 MDFwd.txName5.Left = nLeft
  111.                 MDFwd.etName4.Left = nLeft
  112.             ENDIF
  113.             
  114.             xValue = EVALUATE(cStr)
  115.             
  116.             DO CASE
  117.                 CASE TYPE("xValue") = "C"
  118.                     nLen = LEN( m->xValue )
  119.                     MDFwd.etName4.Value = SPACE( nLen )
  120.                     IF nLen > 40
  121.                         MDFwd.etName4.Width = 40
  122.                     ENDIF
  123.                 CASE (TYPE("xValue") = "F") .OR. (TYPE("xValue") = "N")
  124.                     MDFwd.etName4.Value = 0
  125.                 CASE TYPE("xValue") = "D"
  126.                     MDFwd.etName4.Value = {}
  127.                 CASE TYPE("xValue") = "L"
  128.                     MDFwd.etName4.Value = .F.    
  129.             ENDCASE            
  130.  
  131.             cFilter = SET("FILTER")
  132.  
  133.             DO WHILE .NOT. lFlag
  134.                 lVoid = MDFwd.etName4.SetFocus()
  135.                 lVoid = MDFwd.ReadModal()
  136.  
  137.                 IF MDFwd.Action
  138.                     nRec = RECNO()
  139.  
  140.                     xValue = MDFwd.etName4.Value
  141.  
  142.                     DO CASE
  143.                         CASE TYPE("xValue") = "C"    
  144.                             tFilter = IIF(.NOT. ISBLANK(cFilter),; 
  145.                                 "(" + cFilter + ") .AND. (" + IIF(lCase, "", "UPPER(") + oRef.DataLink + IIF(lCase, "", ")") + " = " + IIF(lCase, "", "UPPER(") + kQte + ALLTRIM(xValue) + kQte + IIF(lCase, "", ")") + ")",; 
  146.                                 IIF(lCase, "", "UPPER(") + oRef.DataLink + IIF(lCase, "", ")") + " = " + IIF(lCase, "", "UPPER(") + kQte + ALLTRIM(xValue) + kQte + IIF(lCase, "", ")"))
  147.                         CASE (TYPE("xValue") = "F") .OR. (TYPE("xValue") = "N")
  148.                             nSDec = SET("DECIMALS")
  149.                             nSPre = SET("PRECISION")
  150.                             SET PRECISION TO 20
  151.                             SET DECIMAL TO 18
  152.                             xValue = STR(xValue, 20, 18)
  153.                             DO WHILE RIGHT(xValue,1) = "0"
  154.                                 xValue = LEFT(xValue, LEN(xValue) - 1)
  155.                             ENDDO
  156.                             IF RIGHT(xValue,1) = "."
  157.                                 xValue = LEFT(xValue, LEN(xValue) - 1)
  158.                             ENDIF        
  159.                             tFilter = IIF(.NOT. ISBLANK(cFilter),; 
  160.                                 "(" + cFilter + ") .AND. (" + oRef.DataLink + " = " + xValue + ")",;
  161.                                 oRef.DataLink + " = " + xValue)
  162.                             SET PRECISION TO nSPre
  163.                             SET DECIMALS  TO nSDec    
  164.                         CASE TYPE("xValue") = "D"        
  165.                             tFilter = IIF(.NOT. ISBLANK(cFilter),; 
  166.                                 "(" + cFilter + ") .AND. (" + oRef.DataLink + " = {" + DTOC(xValue) + "})",;
  167.                                 oRef.DataLink + " = {" + DTOC(xValue) + "}")
  168.                         CASE TYPE("xValue") = "L"        
  169.                             tFilter = IIF(.NOT. ISBLANK(cFilter),; 
  170.                                 "(" + cFilter + ") .AND. (" + oRef.DataLink + " = " + IIF(xValue, ".T.", ".F.") + ")",;
  171.                                 oRef.DataLink + " = " + IIF(xValue, ".T.", ".F."))
  172.                     ENDCASE            
  173.                                     
  174.                     SET FILTER TO &tFilter
  175.                     ON ERROR DO SrError
  176.                     IF lFwd
  177.                         GOTO TOP
  178.                     ELSE
  179.                         GOTO BOTTOM
  180.                     ENDIF        
  181.                     ON ERROR
  182.                     lEof = EOF()
  183.                     SET FILTER TO &cFilter
  184.                     IF lEof
  185.                         DO InfoMsg WITH "Search value not found"
  186.                         IF startAtEof
  187.                             GO BOTTOM
  188.                             SKIP
  189.                         ELSE
  190.                             GOTO nRec
  191.                         ENDIF
  192.                         MDFwd.Action = .F.
  193.                         *..................................
  194.                         * TEMPORARY FIX TO GET AROUND BUG!
  195.                         *..................................
  196.                         lFlag = .T.
  197.                     ELSE
  198.                         lFlag = .T.
  199.                         IF oFRef.Classname = "FORM"
  200.                             lVoid = oFRef.Refresh()
  201.                         ENDIF
  202.                     ENDIF
  203.                 ELSE
  204.                     lFlag = .T.
  205.                 ENDIF
  206.             ENDDO
  207.             
  208.             lVoid = MDFwd.Release()
  209.             
  210.         ENDIF                       
  211.     ENDIF            
  212.     
  213.     #include "TALKON.HDB"
  214.     
  215. RETURN    
  216.  
  217.     
  218. *....................................................
  219. * Procedure Name:   SrError
  220. * Parameters:       None
  221. * Ext Memvars:      None
  222. * Description:      Error handler for search routine
  223. *                   runs when no match is found
  224. *....................................................
  225. PROCEDURE SrError
  226.     SET FILTER TO &cFilter
  227.     GOTO BOTTOM
  228.     SKIP
  229. RETURN    
  230.  
  231.