home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / CLIPPER / DATABASE / BROWSERO.ZIP / BROWSER.PRG next >
Encoding:
Text File  |  1993-04-07  |  16.5 KB  |  510 lines
  1. * BROWSER.PRG
  2. *******************************************************************************
  3. *   Browser is an Object for browsing & editing any database.
  4. *
  5. *******************************************************************************
  6.  
  7. // This Object is intended for browing sorted databases. You must specify
  8. // a key to seek in the database or specify a starting record number where
  9. // the whileBlock is first satisfied. It will then browse all records below
  10. // that point until it finds a record that does not satisfy the code block
  11. // or EOF(). The last record satisfying the whileBlock will be considered
  12. // the last record in the browse.
  13. // This "Scoped Browse" approach greatly increases browse times.
  14. // For a more generic filter on a non-indexed field, simply use Clipper's
  15. // SET FILTER TO command and then call this browser without any whileBlock
  16. // specified, or try combining the two if your feeling dangerous...
  17.  
  18. // Features: 1) Hitting Enter on a field will start editing it, or simply
  19.                 start typing data into a field & it will put you into the
  20.                 editor for that field and apply your keystrokes (no need
  21.                 to press enter to start the field editor).
  22.              2) Hit Control-+ (gray plus key) to repeat the data from the
  23.                 previous record into the currently highlighted field.
  24.              3) Control-PageUp & Control-PageDown for Top & Bottom of File.
  25.              4) Tab & Shift-Tab to move left/right between fields.
  26.              5) You can start the browse either on the first matching key
  27.                 that you specify or you can feed the browser a record number
  28.                 to GOTO.
  29.  
  30. *  FileName is the name of the Database to browse (ie: "TRS")
  31. *  IndexOrder is the number of the index to order by (ie: 0,1,2,3...)
  32. *  Fields is an array of field names to show in the browse
  33. *  Pictures is an array of picture masks to use in the Get of the Fields.
  34. *  Headers is an array of column headers to show
  35. *  Title is a String that will banner across top of browse
  36. *  WhileBlock is a code block to evaluate during skipping operations.
  37. *  Colors is an array of color strings as follows:
  38. *    Colors[1] := Normal Items
  39. *    Colors[2] := Highlighted items
  40. *    Colors[3] := Items being Edited
  41. *    Colors[4] := Title of Browse Screen
  42. *  Hooks is a two dimensional array of Hot Key Numbers and the corresponding
  43. *  code block containing the function/procedure call(s) you would like to
  44. *  be invoked. This is a cleaner way to handle this situation instead of
  45. *  SET KEY TO routines. The value returned from your code block will tell
  46. *  the browse if it needs to perform some action:
  47. *              Return Value    Action Requested
  48. *              ============    =================================
  49. *                   0          Do nothing, simply continue browse
  50. *                   1          Refresh the current Row's data only
  51. *                   2          Refresh data on whole screen
  52. *                   3          Go to top of database, Refresh screen data
  53. *                   4          Refresh current Data, move down one row
  54. *                   5          Go to the bottom of the database, refresh screen
  55. *                   6          Quit the Browser Object & Return from Execute
  56. *                   7          Bottom, Pan LeftMost (Home), Move 1 to Right.
  57. *                   8          Bottom, Pan LeftMost (Home).
  58. *                   9          Bottom, Pan LeftMost (Home), Move 2 to Right.
  59. *
  60. * Note: The first field fed to the browser can not be a memo field, otherwise
  61. *       it will not edit the memo field properly.
  62. *
  63. MEMVAR TheKey, TempString
  64.  
  65. #include "class(y).ch"
  66. #include "inkey.ch"
  67. #include "dbstruct.ch"
  68.  
  69. CREATE CLASS SBrowse FROM TBrowse
  70. HIDDEN:
  71.   VAR AppendMode, OldArea, OldIndex, Changed
  72.   METHOD Navigate, EditCell, Stab
  73. EXPORT:
  74.   VAR FileName, IndexOrder, Fields, Headers, Pictures
  75.   VAR Colors, Hooks, WhileBlock, FirstKey, Title, StartingRec
  76.   VAR HasWhileBlock
  77.   METHOD Init
  78.   METHOD Execute
  79.   MESSAGE NewRec IS DEFERRED
  80. END CLASS
  81.  
  82. *******************************************************************************
  83. *  Method Init
  84. *
  85. *******************************************************************************
  86. METHOD Init(nTop, nLeft, nBottom, nRight), (nTop, nLeft, nBottom, nRight)
  87.  
  88. ::FileName := ""
  89. ::IndexOrder := 0
  90. ::Fields := {}
  91. ::Headers := {}
  92. ::Pictures := {}
  93. ::Title := "SBrowse Screen"
  94. ::Colors := {"N/W","N/BG","B/W","B/BG","B/W","B/BG"}
  95. ::Hooks := {}
  96. ::WhileBlock := {|| .T.}
  97. ::HasWhileBlock := .F.
  98. ::StartingRec := 0
  99. ::FirstKey := ""
  100. ::headSep := "═╤═"
  101. ::colSep  := " │ "
  102. RETURN Self
  103.  
  104. *******************************************************************************
  105. *  METHOD PROCEDURE Execute
  106. *   This is the main METHOD called when you want to start 'browsin!
  107. *******************************************************************************
  108. METHOD PROCEDURE Execute
  109.  
  110. LOCAL I, TempString, Column, Struc, RValue
  111. LOCAL OldArea := 0, OldIndex := 0, HookHit, CallBlock
  112. LOCAL SomeRec, block, TempVar
  113.  
  114. IF ALIAS()<>::FileName
  115.   ::OldArea := SELECT()
  116.   ::OldIndex := INDEXORD()
  117. ENDIF
  118.  
  119. // set up new area to Browse...
  120. SELECT (::FileName)
  121. SET ORDER TO (::IndexOrder)
  122.  
  123. // set up browse parameters...
  124. ::colorspec := ::Colors[1]+","+::Colors[2]+",W/N,W/N,"+::Colors[3]
  125.  
  126. // set up the record skipper blocks
  127. ::GoTopBlock := {|| BPosWhile("top", ::FirstKey, "", 0, ::HasWhileBlock) }
  128. ::GoBottomBlock := {|| BPosWhile("bottom", ::FirstKey) }
  129. ::SkipBlock := {|n| BPosWhile("skip", ::FirstKey, ::WhileBlock, n) }
  130.  
  131. // set up the browse columns
  132. Struc := DBSTRUCT()
  133. FOR I := 1 TO LEN(::Fields)
  134.   IF Struc[FIELDPOS(::Fields[I]),DBS_TYPE]="M"   // if memo type
  135.     TempString := '{|| IF(!EMPTY(' + ::Fields[I] + '),"<Memo>","<    >")}'
  136.     Column := TBCOLUMNNEW(::Headers[I], &(TempString))
  137.     Column:ColorBlock := {|| IF(DELETED(),{3,4},{1,2})}
  138.     ::ADDCOLUMN(Column)
  139.   ELSE
  140.     TempString := '{|| '+::FileName+'->'+::Fields[I]+'}'
  141.     Column := TBCOLUMNNEW(::Headers[I], &(TempString))
  142.     Column:ColorBlock := {|| IF(DELETED(),{3,4},{1,2})}
  143.     ::ADDCOLUMN(Column)
  144.   ENDIF
  145. NEXT I
  146.  
  147. // draw title for browse
  148. SETCOLOR(::Colors[4])
  149. I := 40 - INT(LEN(::Title)/2)
  150. @ ::nTop-1,I SAY ::Title
  151.  
  152. IF !EMPTY(::FirstKey)
  153.   SEEK (::FirstKey)
  154.   IF !FOUND()
  155.     IF YesNo("No Records exist, create a new Record?")
  156.       ::NewRec()
  157.       SEEK (::FirstKey)  // reposition in database...
  158.     ELSE
  159.       RETURN  // quit executing and return
  160.     ENDIF
  161.   ENDIF
  162. ELSEIF (::StartingRec<>0)
  163.   GOTO (::StartingRec)
  164. ELSE
  165.   GO TOP
  166.   IF LASTREC()=0
  167.     IF YesNo("No Records exist, create a new Record?")
  168.       ::NewRec()
  169.     ELSE
  170.       RETURN  // quit executing and return
  171.     ENDIF
  172.   ENDIF
  173. ENDIF
  174.  
  175. SomeRec := 0
  176. // keep stabalizing and processing navigation keystrokes.
  177. DO WHILE .T.
  178.   SET CURSOR OFF
  179.   ::Stab()
  180.   // these next 12 lines had to be added to correct internal re-arrangement
  181.   // of records due to index keys changing...
  182.   IF (SomeRec<>0)
  183.     ::GoTop()
  184.     ::RefreshAll()
  185.     ::forceStable()
  186.     DO WHILE RECNO()<>SomeRec
  187.       ::Down()
  188.       ::RefreshCurrent()
  189.       ::forceStable()
  190.     ENDDO
  191.     ::forceStable()
  192.     SomeRec := 0
  193.   ENDIF
  194.   IF ::Stable   // if the Stabalize wasn't interrupted, wait for keystroke
  195.     TheKey := INKEY(0)
  196.   ENDIF
  197.   IF !::Navigate(TheKey)
  198.     HookHit := .F.
  199.     FOR I := 1 TO LEN(::Hooks)
  200.       IF ::Hooks[I,1] = TheKey
  201.         HookHit := .T.
  202.         CallBlock := ::Hooks[I,2]
  203.       ENDIF
  204.     NEXT I
  205.     DO CASE
  206.       CASE TheKey = 400   // K_CTRL_PLUS (gray)
  207.         // copy the data from the previous record...
  208.         IF BOF()
  209.           Beep()
  210.         ELSE
  211.           SKIP -1
  212.           IF ((::HasWhileBlock).AND.(EVAL(::WhileBlock,::FirstKey))).OR. ;
  213.              (!::HasWhileBlock)
  214.             block := fieldblock(::Fields[::ColPos])
  215.             TempVar := EVAL(block)
  216.             SKIP +1
  217.             EVAL(block,TempVar)
  218.             ::RefreshCurrent()
  219.           ELSE
  220.             Beep()
  221.             SKIP +1
  222.           ENDIF
  223.         ENDIF
  224.       CASE TheKey = K_ESC
  225.         Exit
  226.       CASE TheKey = K_ENTER
  227.         ::EditCell(::Fields[::ColPos], ::Colors[3], ::Pictures[::ColPos])
  228.         IF ::Changed
  229.           ::Changed := .F.
  230.           SomeRec := RECNO()
  231.         ENDIF
  232.       CASE HookHit
  233.         RValue := EVAL(CallBlock, Self)
  234.         DO CASE
  235.           CASE RValue = 1    // Refresh current row only
  236.             ::RefreshCurrent()
  237.           CASE RValue = 2    // Refresh screen only
  238.             ::RefreshAll()
  239.           CASE RValue = 3    // Go to top, refresh
  240.             ::GoTop()
  241.             ::RefreshAll()
  242.           CASE RValue = 4    // Refresh current, move down one
  243.             ::RefreshCurrent()
  244.             ::Down()
  245.           CASE RValue = 5    // Go to Bottom, refresh
  246.             ::GoBottom()
  247.             ::RefreshAll()
  248.           CASE RValue = 6    // Quit the browse object, return
  249.             Exit
  250.           CASE RValue = 7    // Go Bottom, Pan LeftMost (Home), then Right One
  251.             ::GoBottom()
  252.             ::PanHome()
  253.             ::Right()
  254.             ::RefreshAll()
  255.           CASE RValue = 8    // Go Bottom, Pan LeftMost (Home)
  256.             ::GoBottom()
  257.             ::PanHome()
  258.             ::RefreshAll()
  259.           CASE RValue = 9    // Go Bottom, Pan LeftMost (Home), then Right Two
  260.             ::GoBottom()
  261.             ::PanHome()
  262.             ::Right()
  263.             ::Right()
  264.             ::RefreshAll()
  265.         ENDCASE
  266.       OTHERWISE   // must have been an ascii key to edit the cell
  267.         KEYBOARD CHR(K_ENTER)
  268.         KEYBOARD CHR(TheKey)
  269.         ::EditCell(::Fields[::ColPos], ::Colors[3], ::Pictures[::ColPos])
  270.         IF ::Changed
  271.           SomeRec := RECNO()
  272.           ::Changed := .F.
  273.         ENDIF
  274.     ENDCASE
  275.   ENDIF
  276.  
  277. ENDDO  // do while .t. until exit command from <ESC>
  278. IF !EMPTY(::OldArea)
  279.   SELECT (::OldArea)
  280.   SET ORDER TO (::OldIndex)
  281. ENDIF
  282. SET CURSOR ON
  283. RETURN
  284.  
  285. *******************************************************************************
  286. *  Function BPosWhile
  287. *    General Purpose Record Positioning Function with Scoping Condition.
  288. *******************************************************************************
  289. FUNCTION BPosWhile(How, FirstKey, Condition, HowMany, HasWBlk)
  290. // it's assumed that the database is already positioned at the first matching
  291. // key.
  292. LOCAL Actual := 0, SoftStat
  293.  
  294. DO CASE
  295.   CASE How == "top"
  296.     IF HasWBlk
  297.       SEEK FirstKey
  298.     ELSE
  299.       GO TOP
  300.     ENDIF
  301.   CASE How == "bottom"
  302.     SoftStat := SET(_SET_SOFTSEEK, .T.)
  303.     SEEK (LEFT(FirstKey, LEN(FirstKey) -1) + CHR(255))
  304.     SKIP -1
  305.     SET(_SET_SOFTSEEK, SoftStat)
  306.   CASE How == "skip"
  307.     DO CASE
  308.       CASE HowMany < 0    // moving backwards
  309.         DO WHILE (Actual > HowMany) .AND. (!BOF()) .AND. EVAL(Condition, FirstKey)
  310.           SKIP -1
  311.           IF (!BOF()) .AND. EVAL(Condition, FirstKey)
  312.             Actual--
  313.           ENDIF
  314.         ENDDO
  315.         IF (!EVAL(Condition, FirstKey))
  316.           SKIP +1
  317.         ENDIF
  318.       CASE HowMany > 0    // Moving Forward
  319.         DO WHILE (Actual < HowMany) .AND. (!EOF()) .AND. EVAL(Condition, FirstKey)
  320.           SKIP +1
  321.           IF (!EOF()) .AND. EVAL(Condition, FirstKey)
  322.             Actual++
  323.           ENDIF
  324.         ENDDO
  325.         IF EOF() .OR. (!EVAL(Condition, FirstKey))
  326.           SKIP -1
  327.         ENDIF
  328.       OTHERWISE    // HowMany = 0  - No Movement requested, re-read current rec
  329.         SKIP 0
  330.     ENDCASE
  331.   ENDCASE
  332. RETURN Actual
  333.  
  334. *******************************************************************************
  335. *  METHOD PROCEDURE Stab stabalizes the given browse object.
  336. *
  337. *******************************************************************************
  338. METHOD PROCEDURE Stab
  339.  
  340. BEGIN SEQUENCE     // define block to exit from if a keystroke is detected...
  341.   DO WHILE (!::STABILIZE())
  342.     TheKey := INKEY()
  343.     IF !EMPTY(TheKey)
  344.       BREAK
  345.     ENDIF
  346.   ENDDO
  347. END SEQUENCE
  348. RETURN
  349.  
  350. *******************************************************************************
  351. *   METHOD FUNCTION Navigate
  352. *     will interpret a keystroke and navigate if it understands the command,
  353. *  if it doesn't understand, it returns false.
  354. *******************************************************************************
  355. METHOD FUNCTION Navigate(k)
  356. /*
  357.    Establish standard navigation keystrokes and the cursor movement
  358.    METHOD to associate with each key.
  359.  
  360.    This function gets passed a browse object and a potential
  361.    navigation key. If the key is defined it's associated navigation
  362.    message is sent to the browse.
  363.  
  364.    Function returns .t. if navigation was handled, .f. if not.
  365. */
  366. local did := .t.
  367.  
  368.   if k == K_UP
  369.     ::up()
  370.   elseif k == K_DOWN
  371.     ::down()
  372.   elseif k == K_LEFT
  373.     ::left()
  374.   elseif k == K_RIGHT
  375.     ::right()
  376.   elseif k == K_PGUP
  377.     ::pageUp()
  378.   elseif k == K_PGDN
  379.     ::pageDown()
  380.   elseif k == K_CTRL_PGUP
  381.     ::goTop()
  382.   elseif k == K_CTRL_PGDN
  383.     ::goBottom()
  384.   elseif k == K_HOME
  385.     ::home()
  386.   elseif k == K_END
  387.     ::end()
  388.   elseif k == K_CTRL_HOME
  389.     ::panHome()
  390.   elseif k == K_CTRL_END
  391.     ::panEnd()
  392.   elseif k == K_TAB
  393.     ::Right()
  394.   elseif k == K_SH_TAB
  395.     ::Left()
  396.   else
  397.     did := .f.
  398.   endif
  399.  
  400. RETURN did
  401.  
  402. *******************************************************************************
  403. *  METHOD FUNCTION EditCell
  404. *    Edits any kind of cell thrown to it from a browse...
  405. *******************************************************************************
  406. METHOD FUNCTION EditCell(fieldName, editColor, Pict)
  407. /*
  408.    General-purpose browse cell editing function, can handle all
  409.    database field types including memo fields. If you want the
  410.    edits to "stick" you must assign fieldblock()-style
  411.    column:block instance variables. All editing, including
  412.    memo-edit, is done within the boundaries of the browse window.
  413.    On exit any appropriate browse cursor navigation messages are
  414.    passed along. Note: In order to browse a memo field the column
  415.    heading must be defined. This function uses the heading to
  416.    display a message.
  417. */
  418. local c, k, clr, crs, rex, block, cell, OldValue
  419.  
  420.  
  421.   //  Retrieve the column object for the current cell.
  422.   c := ::getColumn(::colPos)
  423.  
  424.  
  425.   //  Create a field block used to check for a memo field
  426.   //  and later used to store the edited memo back. It's
  427.   //  done this way so you can have the browse window display
  428.   //  a notation like "memo" rather than displaying a small
  429.   //  hunk of the real memo field.
  430.   //
  431.   block := fieldblock(fieldName)
  432.  
  433.   // Save old value in a variable to compare later to see if changed...
  434.   OldValue := eval(block)
  435.  
  436.   //  Can't just "get" a memo, need a memo-edit.
  437.   if valtype(eval(block)) = "M"
  438.  
  439.     //  Tell the user what's going on.
  440.     @ ::nTop, ::nLeft clear to ::nBottom, ::nRight
  441.     @ ::nTop, ::nLeft say ;
  442.       padc("Memo Edit: Record " +str(recno(),5) ;
  443.           +', "'+ c:heading +'" Field', ::nRight -::nLeft)
  444.     @ row() +1, ::nLeft say replicate("-", ::nRight -::nLeft +1)
  445.  
  446.  
  447.     //  Turn cursor on and perform the memo edit
  448.     //  using the specified color.
  449.     crs := setcursor(1)
  450.     clr := setcolor(editColor)
  451.     cell := memoedit(eval(block), ::nTop +2, ::nLeft,;
  452.                                   ::nBottom, ::nRight)
  453.     setcursor(crs)
  454.     setcolor(clr)
  455.  
  456.  
  457.     //  If they didn't abandon the edit, save changes.
  458.     //  When passed a parameter, fieldblock-style code
  459.     //  blocks store the value back to the database.
  460.     //  Handiest darn thing they ever stuck in this language.
  461.     if lastkey() <> K_ESC
  462.       eval(block, cell)
  463.     endif
  464.  
  465.  
  466.     //  We mussed up the entire window, tell TBrowse to
  467.     //  clean it up.
  468.     ::configure()
  469.  
  470.  
  471.   //  Regular data type, do a GET/READ.
  472.   else
  473.  
  474.     //  Pass along any additional keystrokes.
  475.     if (lastkey() > K_SPACE) .and. (lastkey() < 256)
  476.       keyboard(chr(lastkey()))
  477.     endif
  478.  
  479.  
  480.     //  Create a get object for the field.
  481.     cell := getnew(row(), col(), ;
  482.                    block, fieldName, Pict, "W/N,"+editColor)
  483.  
  484.     //  Allow up/down to exit the read, and turn the cursor off.
  485.     rex := readexit(.t.)
  486.     crs := setcursor(1)
  487.     SET SCOREBOARD OFF
  488.     //  Perform the read.
  489.     readmodal({cell})
  490.  
  491.     //  Restore original cursor and read-exit states.
  492.     setcursor(crs)
  493.     readexit(rex)
  494.  
  495.     // See if the value was changed
  496.     IF eval(block)<>OldValue
  497.       ::Changed := .T.
  498.     ELSE
  499.       ::Changed := .F.
  500.     ENDIF
  501.  
  502.     //  We changed the field value and TBrowse doesn't know it.
  503.     //  So we must force a re-read for the current row.
  504.     ::refreshCurrent()
  505.     ::Right()
  506.   endif
  507.  
  508. return nil
  509.  
  510.