home *** CD-ROM | disk | FTP | other *** search
/ DOS Wares / doswares.zip / doswares / DATABASE / DBASE4NL / SAMPLES.ZIP / NETNUM.PRG < prev    next >
Encoding:
Text File  |  1993-05-18  |  6.4 KB  |  210 lines
  1. ******************************************************************************
  2. * PROGRAM NAME: NETNUM.PRG
  3. *               netnum DATABASE SCREEN
  4. *               SAMPLE BUSINESS APPLICATION PROGRAM
  5. * LAST CHANGED: 080692
  6. * WRITTEN BY:   BORLAND INTERNATIONAL INC.
  7. ******************************************************************************
  8. *       FILES USED:
  9. *       Database     =  Codes.dbf  (Area code file)
  10. *       Index file   =  Codes.mdx
  11. *         TAG: City  =  city  <= Master
  12. *         TAG: Code  =  code
  13. *       External procedure file = Library.prg
  14. ******************************************************************************
  15. * Main procedure
  16. PROCEDURE Netnum
  17.  
  18.    * Link to external procedure file of "tool" procedures
  19.    SET PROCEDURE TO Biblio
  20.  
  21.     * Save the environment color settings
  22.     IF TYPE("c_save") = "U"
  23.         * Do not overwrite c_save if it already exists
  24.         PUBLIC c_save
  25.                 SET CONSOLE off              
  26.         c_save = SET("ATTRIBUTES")
  27.                 SET CONSOLE on
  28.     ENDIF
  29.  
  30.    * Set up database environment
  31.    SET CONSOLE off
  32.    DO Set_env
  33.    SET CONSOLE on
  34.  
  35.    SET COLOR TO &c_standard.
  36.  
  37.    * Declare variables used:
  38.    * Database memory variables
  39.    woonplaats = SPACE(20)
  40.    kengetal = SPACE(5)
  41.    * Miscellaneous variables - used to pass parameters to Library
  42.    STORE "NETNUM" TO dbf
  43.    STORE "NIET BESCHIKBAAR" TO mlist     && No mailing list available
  44.    STORE "N/B" TO cust_rpt            && No custom reports available
  45.    STORE "m->woonplaats" TO key, key1
  46.    STORE "GEEN" TO key2, key3
  47.    keyname1 = "Plaats:"
  48.    STORE "" TO keyname2, keyname3
  49.    list_flds = "WOONPLAATS,KENGETAL"
  50.    mcode     = SPACE(5)
  51.    lookup_ok = .F.                    && lookup not applicable
  52.  
  53.    * Open database file and choose active index
  54.    SELECT 1
  55.    USE Netnum ORDER Woonplaats
  56.    GO TOP
  57.  
  58.    record_num = RECNO()
  59.    DO Load_fld    && Load initial record from database into memory variables
  60.  
  61.    * Show data screen
  62.    CLEAR
  63.    DO Dstatus
  64.    DO Backgrnd
  65.    DO Show_data
  66.  
  67.    * Define popup menus
  68.    DO Bar_def
  69.  
  70.    * Activate main popup menu - execute user choices
  71.    SET COLOR TO &c_popup.
  72.    ACTIVATE POPUP main_mnu
  73.    DO Sub_ret
  74. RETURN
  75. *** END MAIN PROCEDURE *******************************************************
  76.  
  77. *** UTILITY PROCEDURES (Proprietary to netnum.prg) *************************
  78. PROCEDURE Filter
  79.    * Filter (group) data into subset
  80.    * Select subset to set up filter condition (J=turn on, N=abort selection,
  81.    * U=turn off). If filter is already on, set default choice to T, show 
  82.    * window. If filter is not on, set default choice to Y, show window.
  83.    choice = IIF(filters_on,"U","J")
  84.    DO Filt_ans
  85.    IF choice = "J"              && Start process of choosing filter condition
  86.       mcode  = SPACE(5)
  87.       ACTIVATE WINDOW alert
  88.          * Get user's filter condition selection
  89.          @  0, 0 SAY "-------FILTERVOORWAARDE OPGEVEN-----"
  90.          @  2, 0 SAY "Kengetal:" GET mcode 
  91.          READ
  92.       DEACTIVATE WINDOW alert
  93.       IF mcode <> " "             && Check whether user entered data
  94.          SET FILTER TO KENGETAL = mcode
  95.       ELSE                      && User entered no data, so exit
  96.          ?? CHR(7)
  97.          filters_on = .F.
  98.          RETURN
  99.       ENDIF
  100.       GO TOP                    && Activate filter by moving record pointer
  101.       * Check whether filter condition matches any records (none matching=EOF)
  102.       filters_on = .NOT. EOF()
  103.       IF .NOT. filters_on       && Turn off filter if no matches found
  104.          ?? CHR(7)
  105.          DO Show_msg WITH "Records voldoen niet aan filtervoorwaarde "
  106.          SET FILTER TO
  107.          GO record_num
  108.       ENDIF
  109.    ELSE
  110.       * If user selects "U", turn off filter
  111.       SET FILTER TO
  112.       filters_on = .F.
  113.    ENDIF
  114. RETURN
  115.  
  116. PROCEDURE Indexer
  117.    * Create/rebuild index
  118.    INDEX ON kengetal TAG kengetal
  119.    INDEX ON woonplaats TAG woonplaats
  120.    SET ORDER TO TAG Woonplaats
  121.    GO TOP
  122. RETURN
  123.  
  124. PROCEDURE Init_fld
  125.    * Initialize memory variables for data entry
  126.    woonplaats = SPACE(20)
  127.    kengetal = SPACE(5)
  128. RETURN
  129.  
  130. PROCEDURE Load_fld
  131.    * Load field values from Codes database record into memory variables
  132.    woonplaats  = woonplaats
  133.    kengetal  = kengetal
  134. RETURN
  135.  
  136. PROCEDURE Repl_fld
  137.    * Replace database fields with values of current memory variables
  138.    REPLACE woonplaats WITH m->woonplaats, kengetal WITH m->kengetal
  139. RETURN
  140.  
  141. PROCEDURE Backgrnd
  142.    * Show background screen
  143.    * Draw lines and boxes
  144.    @  1,25 TO  3,53  DOUBLE COLOR &c_blue.
  145.    @  6,7  TO  8,38  DOUBLE COLOR &c_red.
  146.    @  9,7  TO 11,38         COLOR &c_red.
  147.    @  2,26 FILL TO  2,52    COLOR &c_blue.
  148.    @  6,7  FILL TO 11,38    COLOR &c_red.
  149.    SET COLOR TO &c_data.
  150.    @  2,27 SAY " ZOEKSYSTEEM  KENGETALLEN "
  151.    @  7,10 SAY "PLAATS:"
  152.    @ 10,10 SAY "NETNR.:"
  153.    SET COLOR TO &c_standard.
  154. RETURN
  155.  
  156. PROCEDURE Show_data
  157.    * Show data
  158.    SET COLOR TO &c_fields.
  159.    @  7,17 SAY woonplaats
  160.    @ 10,17 SAY kengetal PICTURE "99999"
  161.    SET COLOR TO &c_standard.
  162. RETURN
  163.  
  164. PROCEDURE Get_data
  165.    * Show data for data entry
  166.    SET COLOR TO &c_data.
  167.    @  7,17 GET m->woonplaats PICTURE "!XXXXXXXXXXXXXXXXXXX"
  168.    @ 10,17 GET m->kengetal PICTURE "99999"
  169.    SET COLOR TO &c_standard.
  170. RETURN
  171.  
  172. PROCEDURE Colo_rese
  173. PRIVATE old_color, c_messages, c_titles, c_box, c_info, c_fields
  174.  
  175. old_color = c_save
  176.  
  177. * Set the Primary colors
  178. SET COLOR TO &old_color.
  179.  
  180. * Remove primary colors and start at the secondary colors
  181. old_color = STUFF(old_color, 1, AT("&",old_color)+2, "")
  182.  
  183. comma = AT(",",old_color)
  184. c_messages = LEFT(old_color, comma-1)        && Get MESSAGES color
  185. old_color = STUFF(old_color, 1, comma, "")    && Remove MESSAGES color
  186.  
  187. comma = AT(",",old_color)
  188. c_titles = LEFT(old_color, comma-1)        && Get TITLES color
  189. old_color = STUFF(old_color, 1, comma, "")    && Remove TITLES color
  190.  
  191. comma = AT(",",old_color)
  192. c_box = LEFT(old_color, comma-1)        && Get BOX color
  193. old_color = STUFF(old_color, 1, comma, "")    && Remove BOX color
  194.  
  195. comma = AT(",",old_color)
  196. c_info = LEFT(old_color, comma-1)        && Get INFORMATION color
  197. old_color = STUFF(old_color, 1, comma, "")    && Remove INFORMATION color
  198.  
  199. comma = AT(",",old_color)
  200. c_fields = old_color                                    && Get FIELDS color
  201.  
  202. SET COLOR OF MESSAGES    TO &c_messages.
  203. SET COLOR OF TITLES      TO &c_titles.
  204. SET COLOR OF BOX         TO &c_box.
  205. SET COLOR OF INFORMATION TO &c_info.
  206. SET COLOR OF FIELDS      TO &c_fields.
  207. RETURN
  208.  
  209. *** END NETNUM.PRG *********************************************************
  210.