home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 5 / 05.iso / a / a031 / template.exe / QUICKAPP.COD < prev    next >
Encoding:
Text File  |  1992-03-10  |  19.9 KB  |  700 lines
  1. //
  2. // Module name: Quickapp.cod
  3. // Description: Quick application template for dBASE IV
  4. //
  5.  
  6. Quick Application Template
  7. --------------------------
  8. Version 1.5.a
  9. Borland International (c) 1987, 1988, 1989, 1990
  10. {
  11.  include "applctn.def"  // Applicaton selectors
  12.  include "builtin.def"  // Builtin Functions
  13.  
  14.  
  15.  if getenv("dtl_debug") then
  16.    debug(2)
  17.    breakpoint( pick_debug )
  18.  endif
  19.  
  20.  var  bnl_formname,     // Name of BNL file to newframe if argument() has value
  21.       arg_list;
  22.  
  23.  arg_list = alltrim(argument())
  24.  
  25.  if arg_list != "" then
  26.    bnl_formname = token( ",", arg_list, 1 )
  27.    if !newframe( bnl_formname ) then
  28.      return -1;
  29.    endif
  30.  endif
  31.  
  32.  // Check menu type
  33.  if MENU_TYPE != app then
  34.    pause(app_class)
  35.    goto NoGen;
  36.  endif
  37.  //
  38.  // Enum string constants for international translation
  39.  //
  40.  enum pack_dbf1 = "Packing database ",
  41.       pack_dbf2 = " to REMOVE records marked for deletion...",
  42.       set_msg1  = "Appending records to file ",
  43.       set_msg2  = "Editing file ",
  44.       set_msg3  = "Browsing file ",
  45.       set_msg4  = "Pick an option to locate a record or <ESC> for default",
  46.       set_msg5  = "Printing report ",
  47.       set_msg6  = "Printing labels",
  48.       quick_bar1= " Add Information", quick_msg1 = "Add records to database ",
  49.       quick_bar2= " Change Information", quick_msg2 = "Edit records in database ",
  50.       quick_bar3= " Browse Information", quick_msg3 = "Browse database ",
  51.       quick_bar4= " Discard Marked Records ", quick_msg4 = "Purge deleted records in database ",
  52.       quick_bar5= " Print Report", quick_msg5 = "Run report form ",
  53.       quick_bar6= " Mailing Labels", quick_msg6 = "Run label form ",
  54.       quick_bar7= " Reindex Database", quick_msg7 = "Reindex database ",
  55.       quick_bar8= " Exit From ", quick_msg8 = "Exit program to dBASE",
  56.       prntchk_bar1= " Send to...",
  57.       prntchk_bar3= " Screen ", prntchk_msg3= "Screen only" ,
  58.       prntchk_bar4= " Printer ", prntchk_msg4= "Printer LPT1:",
  59.       prntchk_bar5= " Label Sample ", prntchk_msg5= "Printer LPT1: with Sample label",
  60.       prntchk_bar6= " Return", prntchk_msg6= "Return to Main Menu",
  61.       reindex_dbf = "Reindexing database ",
  62.       ready_printer = "Please ready your printer or",
  63.       press_esc = "     press ESC to cancel",
  64.       error_occured = "[Error occurred on line ]+LTRIM(STR(LINE())) +[ of procedure ]+Program()",
  65.  ;
  66.  //
  67.  // End string constants for international translation
  68.  //
  69.  // Declare variables
  70.  var quickapp, barcnt, rptchoice, lblchoice, ndxchoice, file, crlf, x, color,
  71.      ask_user, strng, author, copyright, dbVersion, default_drv, temp,
  72.      scrn_size, display // Type of display
  73.  ;
  74.  
  75.  // Grab default drive from dBASE
  76.  // See bottom of Builtin.def for numset & strset enum's
  77.  default_drv = strset(_defdrive);
  78.  
  79.  if filedrive(menu_name) or !default_drv then
  80.    quickapp = alltrim(menu_name);
  81.  else
  82.    quickapp = default_drv + ":" + alltrim(menu_name);
  83.  endif
  84.  quickapp = upper(quickapp);
  85.  
  86.  // Assign default values to some of the variables
  87.  barcnt = 4;
  88.  crlf = chr(10);
  89.  author = Appl_Authr;
  90.  copyright = Appl_cpyrt;
  91.  dbVersion = Appl_Versn;
  92.  display = numset(_flgcolor);
  93.  if display > ega25 then scrn_size = 39 else scrn_size = 21 endif
  94.  scrn_size = scrn_size + 3
  95.  
  96.  // Check to see if file exists and safety is on
  97.  if fileexist(quickapp+".PRG") and numset(_safety) then
  98.    do while not at(upper(ask_user),"YN")
  99.       ask_user = askuser("Application "+quickapp+".prg already exists...Overwrite (Y/N)","N",1);
  100.    enddo
  101.    if upper(ask_user) == "N" then
  102.      pause(gen_request + any_key)
  103.      goto NoGen;
  104.    endif
  105.  endif
  106. //
  107. //----------------------------------
  108. //Create Quickapp main program
  109. //----------------------------------
  110. //
  111.  if not create(quickapp+".PRG") then
  112.     pause(fileroot(quickapp)+".PRG" + read_only + any_key)
  113.     goto nogen;
  114.  endif
  115.  
  116.  print(replicate("*",80)+crlf);
  117. }
  118. * Program......: {quickapp}
  119. {include "as_headr.cod";}
  120. * Notes........:
  121. {print(replicate("*",80)+crlf);}
  122.  
  123. SET CONSOLE OFF
  124. IF TYPE("gn_apgen") = "U"  && We were not called from another APGEN program
  125.    CLEAR ALL
  126.    CLEAR WINDOW
  127.    CLOSE DATABASE
  128.    gn_apgen = 1
  129. ELSE
  130.    gn_apgen = gn_apgen + 1
  131.    PRIVATE gc_bell, gc_carry, gc_clock, gc_century, gc_confirm, gc_deli,;
  132.            gc_escape, gc_safety, gc_status, gc_score, gc_talk, gc_color,;
  133.            gc_proc
  134. ENDIF
  135.  
  136. *-- Window for pause message box (ON ERROR)
  137. DEFINE WINDOW Pause FROM 15,00 TO 19,79 DOUBLE
  138. ON ERROR DO PAUSE WITH {error_occured}
  139. ON KEY LABEL F1 DO quickhlp
  140.  
  141. *-- Store initial SETs to variables
  142. gc_bell   =SET("BELL")
  143. gc_carry  =SET("CARRY")
  144. gc_clock  =SET("CLOCK")
  145. gc_century=SET("CENTURY")
  146. gc_color  =SET("ATTRIBUTE")
  147. gc_confirm=SET("CONFIRM")
  148. gc_cursor =SET("CURSOR")
  149. gc_deli   =SET("DELIMITERS")
  150. gc_escape =SET("ESCAPE")
  151. gc_proc   =SET("PROCEDURE")
  152. gc_safety =SET("SAFETY")
  153. gc_status =SET("STATUS")
  154. gc_score  =SET("SCOREBOARD")
  155. gc_talk   =SET("TALK")
  156.  
  157. SET CLOCK OFF
  158. SET COLOR TO
  159. CLEAR
  160. SET CONSOLE ON
  161.  
  162. *-- Sets for application
  163. SET BELL {if Set_Bell then}OFF{else}ON{endif}
  164. {if Set_BellFr and Set_BellDr then}
  165. SET BELL TO {Set_BellFr},{Set_BellDr}
  166. {endif}
  167. SET CARRY {if Set_Carry then}ON{else}OFF{endif}
  168. SET CENTURY {if Set_Centry then}ON{else}OFF{endif}
  169. SET CONFIRM {if Set_Confrm then}ON{else}OFF{endif}
  170. SET CURSOR OFF
  171. SET DELIMITERS TO \
  172. {if not AT(CHR(34),Set_DelChr) then}"{Set_DelChr}"
  173. {  goto deliok;
  174.  endif
  175.  if not AT("'",Set_DelChr) then}'{Set_DelChr}'
  176. {  goto deliok;
  177.  endif
  178.  if not AT("[",Set_DelChr) or not AT("]",Set_DelChr) then}[{Set_DelChr}]
  179. {  goto deliok;
  180.  endif
  181. }
  182. ""
  183. {deliok:}
  184. SET DELIMITER {if Set_Delim then}ON{else}OFF{endif}
  185. SET ESCAPE {if Set_Escape then}OFF{else}ON{endif}
  186. SET SAFETY {if Set_Safety then}OFF{else}ON{endif}
  187. SET SCOREBOARD OFF
  188. SET STATUS OFF
  189. SET TALK OFF
  190. //
  191. {if Run_Drive then}
  192. SET DEFAULT TO {UPPER(Run_Drive)}:
  193. {endif}
  194. {if Run_Path then}
  195. SET PATH TO {Run_Path}
  196. {endif}
  197.  
  198. *-- Set global variables
  199. gn_barv  = 0{tabto(30)}&& Initialize bar value variable
  200. gn_error = 0{tabto(30)}&& Variable to store error() number
  201. gn_send  = 0{tabto(30)}&& Return variable from popup
  202. gc_brdr  = "2"{tabto(30)}&& Border style for menu box - See Procedure
  203. lc_heading = "{if quick_hdng then
  204.   alltrim(Quick_Hdng)
  205. else
  206.   fileroot(Upper(quickapp))
  207. endif}" && Menu heading string
  208.  
  209. gl_color = ISCOLOR()
  210. gc_scope = ""
  211. {if Disp_Sign then}
  212. // Display Signon Banner
  213. SET ESCAPE OFF
  214.  
  215. *-- Signon Banner
  216. tmpcolor = IIF(gl_color,"{color(Clr_box)}", "W+/N")
  217. @ {row1()},{col1()} TO {row2()},{col2()} \
  218. {   case Mnu_Border of}
  219. {   0: // Panel}
  220. PANEL \
  221. {   1: // Single}
  222.  \
  223. {   2: // Double}
  224. DOUBLE \
  225. {   endcase}
  226. COLOR &tmpcolor.
  227. {   foreach text_element}
  228. @ {row1()+Row_Positn},{col1()+Col_Positn} SAY "{Text_Item}"
  229. {   next}
  230. IF gl_color
  231.    @ {row1()+1},{col1()+1} FILL TO {row2()-1},{col2()-1} COLOR {color(Clr_Messages)}
  232. ENDIF
  233. @ IIF("43" $ SET("DISPLAY"),42,24),30 \
  234. SAY "Press any key ..." COLOR {color(Clr_Messages)}
  235. SET CONSOLE OFF                       && For mouse click recognition
  236. WAIT
  237. SET CONSOLE ON
  238. CLEAR
  239.  
  240. {endif}
  241. SET ESCAPE {if Set_Escape then}OFF{else}ON{endif}
  242. SET STATUS ON
  243.  
  244. *-- Set colors
  245. IF gl_color
  246.    SET COLOR OF NORMAL TO {color(Clr_Text)}
  247.    SET COLOR OF MESSAGES TO {color(Clr_Messages)}
  248.    SET COLOR OF TITLES TO {color(Clr_Heading)}
  249.    SET COLOR OF HIGHLIGHT TO {color(Clr_Hghlight)}
  250.    SET COLOR OF BOX TO {color(Clr_Box)}
  251.    SET COLOR OF INFORMATION TO {color(Clr_Info)}
  252.    SET COLOR OF FIELDS TO {color(Clr_Fields)}
  253. ENDIF
  254. //
  255.  
  256. {dBFOpen(Quick_DBF, Quick_NDX, Quick_Ordr);}
  257.  
  258. *-- Define the main popup menu for Quickapp
  259. SET BORDER TO DOUBLE
  260. DEFINE POPUP quick FROM 7,27
  261. DEFINE BAR 1 OF quick PROMPT "{quick_bar1}" MESSAGE "{quick_msg1 + Quick_DBF}"
  262. DEFINE BAR 2 OF quick PROMPT "{quick_bar2}" MESSAGE "{quick_msg2 + Quick_DBF}"
  263. DEFINE BAR 3 OF quick PROMPT "{quick_bar3}" MESSAGE "{quick_msg3 + Quick_DBF}"
  264. DEFINE BAR 4 OF quick PROMPT "{quick_bar4}" MESSAGE "{quick_msg4 + Quick_DBF}"
  265. { if Quick_FRM then barcnt=barcnt+1; rptchoice=barcnt;}
  266. DEFINE BAR {barcnt} OF quick PROMPT "{quick_bar5}" MESSAGE "{quick_msg5 + Quick_FRM}"
  267. { endif
  268.   if Quick_LBL then barcnt=barcnt+1; lblchoice=barcnt;}
  269. DEFINE BAR {barcnt} OF quick PROMPT "{quick_bar6}" MESSAGE "{quick_msg6 + Quick_LBL}"
  270. { endif
  271.   if Quick_NDX or Quick_Ordr then barcnt=barcnt+1; ndxchoice=barcnt;}
  272. DEFINE BAR {barcnt} OF quick PROMPT "{quick_bar7}" MESSAGE "{quick_msg7 + Quick_DBF}"
  273. { endif
  274.   barcnt=barcnt+1;
  275.  strng=fileroot(quickapp);
  276.  strng=upper(substr(strng,1,1))+lower(substr(strng,2,7));}
  277. DEFINE BAR {barcnt} OF quick PROMPT "{quick_bar8 + strng}" MESSAGE "{quick_msg8}"
  278. ON SELECTION POPUP quick DO Action WITH BAR()
  279.  
  280. {if Quick_LBL or Quick_FRM then}
  281. *-- Define the popup menu for print redirection
  282. DEFINE POPUP prntchk FROM 10,55
  283. DEFINE BAR 1 OF prntchk PROMPT "{prntchk_bar1}" SKIP
  284. DEFINE BAR 2 OF prntchk PROMPT REPLICATE(CHR(196),14) SKIP
  285. DEFINE BAR 3 OF prntchk PROMPT "{prntchk_bar3}" MESSAGE "{prntchk_msg3}"
  286. DEFINE BAR 4 OF prntchk PROMPT "{prntchk_bar4}" MESSAGE "{prntchk_msg4}"
  287. DEFINE BAR 5 OF prntchk PROMPT "{prntchk_bar5}" MESSAGE "{prntchk_msg5}" \
  288.  SKIP{if Quick_LBL} FOR gn_barv <> {lblchoice}{endif}
  289. DEFINE BAR 6 OF prntchk PROMPT "{prntchk_bar6}" MESSAGE "{prntchk_msg6}"
  290. ON SELECTION POPUP prntchk DEACTIVATE POPUP
  291. {endif}
  292.  
  293. *-- Window to cover work surface during edit, append, etc.
  294. DEFINE WINDOW work FROM 0,0 TO 21,79 NONE
  295.  
  296. *-- Window for area below menu heading & for running reports/labels in
  297. DEFINE WINDOW desktop FROM 4,0 TO 21,79 NONE
  298.  
  299. DEFINE WINDOW printemp FROM 10,25 TO 15,56
  300.  
  301. *-- Display heading centered on the screen.
  302. DO menubox WITH lc_heading
  303.  
  304. *-- Show the menu so we don't get a flash if the user hits arrow keys or ESC
  305. SHOW POPUP quick
  306. SAVE SCREEN TO quick
  307. *-- Display Quickapp menu centered on the screen.
  308. DO WHILE gn_barv <> {barcnt} && Prevent user from exiting with arrow keys or ESC
  309.   ACTIVATE POPUP quick
  310. ENDDO
  311.  
  312. * Restore SET environment the best we can
  313. ?? COLOR(gc_color)                               && See UDF COLOR below
  314. SET BELL &gc_bell.
  315. SET CARRY &gc_carry.
  316. SET CLOCK TO
  317. SET CLOCK &gc_clock.
  318. SET CENTURY &gc_century.
  319. SET CONFIRM &gc_confirm.
  320. SET CURSOR &gc_cursor.
  321. SET DELIMITERS &gc_deli.
  322. SET ESCAPE &gc_escape.
  323. SET FORMAT TO
  324. SET PROCEDURE TO (gc_proc)
  325. SET STATUS &gc_status.
  326. SET SAFETY &gc_safety.
  327. SET SCORE  &gc_score.
  328. SET TALK   &gc_talk.
  329.  
  330. IF gn_apgen = 1 && We were not called from another APGEN program
  331.    CLEAR WINDOW
  332.    CLEAR POPUP
  333.    CLEAR ALL
  334.    CLOSE DATABASE
  335. ELSE
  336.    RELEASE WINDOWS work, desktop
  337.    RELEASE SCREEN quick
  338.    RELEASE POPUP quick
  339.    gn_apgen = gn_apgen - 1
  340. ENDIF
  341. ON ERROR
  342. ON KEY LABEL F1
  343. RETURN
  344. * EOP: {Quickapp}.PRG
  345.  
  346. //
  347. //-------------------------------------------------------------------------
  348. //  Create Quickapp procedure file
  349. //  Since the dBASE compiler does not care that their are procedures in the
  350. //  same file as the program we tack the procedures onto the bottom.
  351. //-------------------------------------------------------------------------
  352. //
  353. {print(replicate("*",80)+crlf);}
  354. * Procedures...: {quickapp}.Prc
  355. {include "as_headr.cod";}
  356. * Notes........:
  357. {print(replicate("*",80)+crlf);}
  358.  
  359. *-- Here is a sample procedure file to show the power of procdures.
  360. *-- This example - Menubox displays a menu heading box with a centered heading.
  361. {include "as_menub.cod";}
  362.  
  363. PROCEDURE get_sele
  364. *-- Get the user selection & store BAR into variable
  365. gn_send = BAR()  && Variable for print testing
  366. DEACTIVATE POPUP
  367. RETURN
  368.  
  369. PROCEDURE Action
  370. PARAMETERS bar
  371. *-- Get the user selection & store BAR into variable
  372. gn_barv = bar
  373. lc_toprnt=''
  374. SET MESSAGE TO
  375. IF LTRIM( STR( gn_barv)) $ "123"
  376.    SET CURSOR ON
  377. {if Quick_FMT then}
  378.    *-- Set format file {Quick_FMT} for edit/append/browse
  379.    SET FORMAT TO {Quick_FMT}
  380. {endif}
  381. ENDIF
  382. DO CASE
  383.    CASE gn_barv = 1
  384.       *-- Add information
  385.       SET MESSAGE TO '{set_msg1 + Quick_DBF}'
  386.       APPEND
  387.    CASE gn_barv = 2
  388.       *-- Change information
  389.       SET MESSAGE TO '{set_msg2 + Quick_DBF}'
  390.       EDIT
  391.    CASE gn_barv = 3
  392.       *-- Browse information
  393.       SET MESSAGE TO '{set_msg3 + Quick_DBF}'
  394.       BROWSE {if Quick_FMT then}FORMAT {endif}
  395.    CASE gn_barv = 4
  396.       *-- Remove information (Pack file {lower(Quick_DBF)})
  397.       ACTIVATE WINDOW desktop
  398.       @ 2,0 SAY "{pack_dbf1 + Quick_DBF + pack_dbf2}"
  399.       @ 3,0
  400.       SET TALK ON
  401.       PACK
  402.       GO TOP
  403.       ?
  404.       WAIT
  405.       SET TALK OFF
  406.       DEACTIVATE WINDOW desktop
  407. {  if Quick_FRM}
  408.    CASE gn_barv = {rptchoice}
  409.       *-- Run report form {lower(Quick_FRM)}
  410.       SET MESSAGE TO '{set_msg4}'
  411.       ACTIVATE WINDOW work
  412.       gn_recno = RECNO()
  413.       DO position
  414.       DEACTIVATE WINDOW work
  415.       STORE 0 TO gn_send, gn_pkey
  416.       ACTIVATE POPUP prntchk
  417.       gn_send = BAR()
  418.       IF gn_send = 4
  419.          lc_toprnt = 'TO PRINT'
  420.          ON ERROR DO prntrtry
  421.       ENDIF
  422.       IF gn_send <> 6 .AND. gn_send <> 0
  423.          SET MESSAGE TO '{set_msg5 + Quick_FRM}'
  424.          ACTIVATE WINDOW desktop
  425.          SET ESCAPE ON
  426.          REPORT FORM {Quick_FRM} &gc_scope. &lc_toprnt.
  427.          IF gn_pkey <> 27
  428.             WAIT
  429.          ENDIF
  430.          SET ESCAPE {if Set_Escape then}OFF{else}ON{endif}
  431.          DEACTIVATE WINDOW desktop
  432.       ENDIF
  433.       GOTO gn_recno
  434.       ON ERROR DO PAUSE WITH {error_occured}
  435. {  endif
  436.    if Quick_LBL}
  437.    CASE gn_barv = {lblchoice}
  438.       *-- Run label form {lower(Quick_LBL)}
  439.       SET MESSAGE TO '{set_msg4}'
  440.       ACTIVATE WINDOW work
  441.       gn_recno = RECNO()
  442.       DO position
  443.       DEACTIVATE WINDOW work
  444.       STORE 0 TO gn_send, gn_pkey
  445.       ACTIVATE POPUP prntchk
  446.       gn_send = BAR()
  447.       DO CASE
  448.        CASE gn_send = 4
  449.          lc_toprnt = 'TO PRINT'
  450.        CASE gn_send = 5
  451.          lc_toprnt = 'TO PRINT SAMPLE'
  452.       ENDCASE
  453.       IF gn_send <> 6 .AND. gn_send <> 0
  454.          SET MESSAGE TO '{set_msg6}'
  455.          ACTIVATE WINDOW desktop
  456.          SET ESCAPE ON
  457.          ON ERROR DO prntrtry
  458.          LABEL FORM {Quick_LBL} &gc_scope. &lc_toprnt.
  459.          IF gn_pkey <> 27
  460.             WAIT
  461.          ENDIF
  462.          SET ESCAPE {if Set_Escape then}OFF{else}ON{endif}
  463.          DEACTIVATE WINDOW desktop
  464.       ENDIF
  465.       GOTO gn_recno
  466.       ON ERROR DO PAUSE WITH {error_occured}
  467. {  endif
  468.    if Quick_NDX or Quick_Ordr}
  469.    CASE gn_barv = {ndxchoice}
  470.       *-- Reindex {lower(Quick_DBF)}
  471.       ACTIVATE WINDOW desktop
  472.       @ 3,0 SAY "{reindex_dbf + Quick_DBF + "..."}"
  473.       @ 4,0
  474.       SET TALK ON
  475.       REINDEX
  476.       GO TOP
  477.       ?
  478.       WAIT
  479.       SET TALK OFF
  480.       DEACTIVATE WINDOW desktop
  481. {  endif}
  482.    CASE gn_barv = {barcnt}
  483.       DEACTIVATE POPUP
  484. ENDCASE
  485. SET MESSAGE TO
  486. SET CURSOR OFF
  487. {if Quick_FMT then}
  488. IF gc_status = "OFF"
  489.    SET STATUS ON
  490. ENDIF
  491. SET FORMAT TO
  492. {endif}
  493. RESTORE SCREEN FROM quick
  494. RETURN
  495.  
  496. {include "as_pause.cod"}
  497.  
  498. PROCEDURE quickhlp
  499. *--  If you want to include help for a quickapp uncomment the lines below and
  500. *--  put your help @ say's into the case statements
  501. *ACTIVATE WINDOW desktop
  502. *CLEAR
  503. DO CASE
  504. {for temp = 1 to barcnt}
  505.   CASE BAR() = {temp}
  506. {next}
  507. ENDCASE
  508. *WAIT
  509. *DEACTIVATE WINDOW desktop
  510. RETURN
  511.  
  512. {if Quick_LBL or Quick_FRM then
  513.   include "as_posit.cod";}
  514.  
  515. PROCEDURE prntrtry
  516. PRIVATE lc_escape
  517. lc_escape = SET("ESCAPE")
  518. IF .NOT. PRINTSTATUS()
  519.    IF lc_escape = "ON"
  520.       SET ESCAPE OFF
  521.    ENDIF
  522.    gn_pkey = 0
  523.    ACTIVATE WINDOW printemp
  524.    @ 1,0 SAY "{ready_printer}"
  525.    @ 2,0 SAY "{press_esc}"
  526.    DO WHILE ( .NOT. PRINTSTATUS()) .AND. gn_pkey <> 27
  527.       gn_pkey = INKEY()
  528.    ENDDO
  529.    DEACTIVATE WINDOW printemp
  530.    SET ESCAPE &lc_escape.
  531.    IF gn_pkey <> 27
  532.       RETRY
  533.    ENDIF
  534. ENDIF
  535. RETURN
  536. { endif}
  537.  
  538. FUNCTION color
  539. *-----------------------------------------------------------------------------
  540. * Format:
  541. * COLOR( <expC> )
  542. *  <expC> = NORMAL, HIGHLIGHT, MESSAGES, TITLES, BOX, INFORMATION, FIELDS, COLOR
  543. *        or a variable with all colors store in it
  544. *  Ver: dBASE 1.1
  545. *
  546. * The COLOR() function either returns or sets colors returned with the
  547. * SET("attribute") setting
  548. * If <expC> is a color string then null is returned otherwise the color
  549. * setting is returned for one of dBASE's color options
  550. *
  551. * See Also: SET("attribute")
  552. *
  553. *-----------------------------------------------------------------------------
  554. PARAMETERS set_color
  555. PRIVATE color_num, color_str, cnt
  556.  
  557. set_color = UPPER(set_color)
  558. IF set_color = "COLOR"
  559.   *- Return standard, enhanced, border colors only
  560.   RETURN SUBSTR(SET("attr"),1, AT(" &", SET("attr")))
  561. ENDIF
  562.  
  563. *- Declare array to parse color options from SET("attr")
  564. PRIVATE color_
  565. DECLARE color_[8]
  566. *- Determine if user is restoring colors vs. saving colors
  567. IF " &" $ set_color
  568.   color_str = ","+set_color+","                  && Restore color attributes
  569. ELSE
  570.   color_str = ","+SET("ATTRIBUTE")+","           && Save color attributes
  571. ENDIF
  572.  
  573. *-- Stuff array with individual color setting
  574. color_str = STUFF(color_str, AT(" &", color_str), 4, ",")
  575. cnt = 1
  576. DO WHILE cnt <= 8
  577.   color_str = SUBSTR(color_str, AT(",", color_str ) +1 )
  578.   color_[cnt] = SUBSTR(color_str, 1, AT(",", color_str ) - 1)
  579.   cnt = cnt + 1
  580. ENDDO
  581.  
  582. IF " &" $ set_color
  583.   *-- Set color back
  584.   SET COLOR TO ,,&color_[3].                     && Border color
  585.   SET COLOR OF NORMAL TO &color_[1].
  586.   SET COLOR OF HIGHLIGHT TO &color_[2].
  587.   SET COLOR OF MESSAGES TO &color_[4].
  588.   SET COLOR OF TITLES TO &color_[5].
  589.   SET COLOR OF BOX TO &color_[6].
  590.   SET COLOR OF INFORMATION TO &color_[7].
  591.   SET COLOR OF FIELDS TO &color_[8].
  592. ELSE
  593.   *-- Return color string requested
  594.   DO CASE
  595.   CASE set_color $ "NORMAL"
  596.     color_num =  1
  597.   CASE set_color $ "HIGHLIGHT"
  598.     color_num =  2
  599.   CASE set_color $ "BORDER"
  600.     color_num =  3
  601.   CASE set_color $ "MESSAGES"
  602.     color_num =  4
  603.   CASE set_color $ "TITLES"
  604.     color_num =  5
  605.   CASE set_color $ "BOX"
  606.     color_num =  6
  607.   CASE set_color $ "INFORMATION"
  608.     color_num =  7
  609.   CASE set_color $ "FIELDS"
  610.     color_num =  8
  611.   OTHERWISE
  612.     set_color = " &"
  613.   ENDCASE
  614. ENDIF
  615. RETURN IIF(" &" $ set_color, "", color_[color_num])
  616. * EOF: {quickapp}.PRG
  617. {pause(gen_complete + any_key);
  618.  fileerase(quickapp+".DBO");
  619.  NoGen:
  620.  return 0;
  621. //
  622. //-------------------------------
  623. // End of quickapp
  624. // User defined functions include
  625. //-------------------------------
  626. //
  627.  define dbfOpen(mdbf,mndx,mord)
  628.    if at(upper(filetype(mdbf)), ".QBE,.QBO,.VUE") then}
  629. SET VIEW TO {mdbf}
  630. {    if mndx then}
  631. SET INDEX TO {mndx}
  632. {    endif
  633.      if mord then}
  634. SET ORDER TO {mord}
  635. {    endif
  636.    else}
  637. USE {mdbf} {if mndx then}INDEX {mndx}{endif}
  638. {    if mord then}
  639. SET ORDER TO {mord}
  640. {    endif
  641.    endif
  642.   return;
  643.  enddef
  644.  
  645.  define color(getcolor);
  646.  //
  647.  // This udf is used for processing colors from the apgen.
  648.  //  The foreground and background colors are stored in one byte.
  649.  //  The formulas below show how to get the foreground and background color
  650.  //  out of the variable passed in.
  651.  //
  652.  var blink, forground, background, enhanced, incolor;
  653.  //
  654.  forground = background = enhanced = 0;
  655.  //
  656.  if getcolor != 255 then          // N/N in apgen (black on black)
  657.    blink = getcolor >> 7          // high order bit set?
  658.    if blink then
  659.       getcolor = getcolor - 128   // Shift high order bit back
  660.    endif
  661.    background = getcolor >> 4
  662.    forground  = getcolor - (background << 4)
  663.    //
  664.    if forground > 7 then
  665.       enhanced = 1
  666.       forground = forground - 8
  667.    endif
  668.  endif
  669.  // Set your dBASE manual for an explanation of the colors below
  670.  case forground of
  671.   0: incolor = "n"
  672.   1: incolor = "b"
  673.   2: incolor = "g"
  674.   3: incolor = "bg"
  675.   4: incolor = "r"
  676.   5: incolor = "rb"
  677.   6: incolor = "gr"
  678.   7: incolor = "w"
  679.  endcase
  680.  if blink then incolor = incolor + "*" endif
  681.  if enhanced then
  682.    incolor = incolor + "+/"
  683.  else
  684.    incolor = incolor + "/"
  685.  endif
  686.  case background of
  687.   0: incolor = incolor + "n"
  688.   1: incolor = incolor + "b"
  689.   2: incolor = incolor + "g"
  690.   3: incolor = incolor + "bg"
  691.   4: incolor = incolor + "r"
  692.   5: incolor = incolor + "rb"
  693.   6: incolor = incolor + "gr"
  694.   7: incolor = incolor + "w"
  695.  endcase
  696.  return incolor;
  697. enddef
  698. }
  699. // EOP QUICKAPP.COD
  700.