home *** CD-ROM | disk | FTP | other *** search
/ DOS Wares / doswares.zip / doswares / DATABASE / DBASE5 / SAMPLES.ZIP / ORDERS.FRG < prev    next >
Encoding:
Text File  |  1994-06-24  |  7.8 KB  |  389 lines
  1. * Program............: orders.FRG
  2. * Date...............: 6-22-94
  3. * Versions...........: dBASE 5.0, Report
  4. *
  5. * Notes:
  6. * ------
  7. * Prior to running this procedure with the DO command
  8. * it is necessary use LOCATE because the CONTINUE
  9. * statement is in the main loop.
  10. *
  11. *-- Parameters
  12. PARAMETERS gl_noeject, gl_plain, gl_summary, gc_heading, gc_extra
  13. ** The first three parameters are of type Logical.
  14. ** The fourth parameter is a string.  The fifth is extra.
  15. PRIVATE _peject, _wrap, ll_heading, ll_temp, ll_toprint
  16. ll_heading = .F.
  17. ll_toprint = (SET("PRINTER") = "ON")
  18.  
  19. *-- Test for no records found
  20. IF EOF() .OR. .NOT. FOUND()
  21.    RETURN
  22. ENDIF
  23.  
  24. *-- turn word wrap mode off
  25. _wrap=.F.
  26.  
  27. IF _plength < (_pspacing * 4 + 1) + (_pspacing * 3 + 1) + 2
  28.    SET DEVICE TO SCREEN
  29.    DEFINE WINDOW gw_report FROM 7,17 TO 11,62 DOUBLE
  30.    ACTIVATE WINDOW gw_report
  31.    @ 0,1 SAY "Increase the page length for this report."
  32.    @ 2,1 SAY "Press any key ..."
  33.    x=INKEY(0)
  34.    DEACTIVATE WINDOW gw_report
  35.    RELEASE WINDOW gw_report
  36.    RETURN
  37. ENDIF
  38.  
  39. _plineno=0          && set lines to zero
  40. *-- NOEJECT parameter
  41. IF gl_noeject
  42.    IF _peject="BEFORE"
  43.       _peject="NONE"
  44.    ENDIF
  45.    IF _peject="BOTH"
  46.       _peject="AFTER"
  47.    ENDIF
  48. ENDIF
  49.  
  50. *-- Set-up environment
  51. ON ESCAPE DO Prnabort
  52. IF SET("TALK")="ON"
  53.    SET TALK OFF
  54.    gc_talk="ON"
  55. ELSE
  56.    gc_talk="OFF"
  57. ENDIF
  58. gc_space=SET("SPACE")
  59. SET SPACE OFF
  60. gc_time=TIME()      && system time for predefined field
  61. gd_date=DATE()      && system date  "    "    "     "
  62. gl_fandl=.F.        && first and last page flag
  63. gl_intros=.F.       && flag for group intros on each page
  64. gl_prntflg=.T.      && Continue printing flag
  65. gl_widow=.T.        && flag for checking widow bands
  66. gn_length=LEN(gc_heading)  && store length of the HEADING
  67. gn_level=2          && current band being processed
  68. gn_page=_pageno     && grab current page number
  69. gn_pspace=_pspacing && get current print spacing
  70.  
  71. *-- Initialize group footer field variables
  72. r_foot1=.F.
  73.  
  74.  
  75. *-- Set up procedure for page break
  76. gn_atline=_plength - (_pspacing * 3 + 1)
  77. ON PAGE AT LINE gn_atline EJECT PAGE
  78.  
  79. *-- Print Report
  80.  
  81. PRINTJOB
  82.  
  83. *-- Initialize group break vars.
  84. r_mvar4=CUST_ID
  85.  
  86. *-- Initialize summary variables.
  87. r_msum1=0
  88. r_msum2=0
  89.  
  90. IF gl_plain
  91.    ON PAGE AT LINE gn_atline DO Pgplain
  92. ELSE
  93.    ON PAGE AT LINE gn_atline DO Pgfoot
  94. ENDIF
  95.  
  96. DO Pghead
  97.  
  98. gl_fandl=.T.        && first physical page started
  99.  
  100. DO Rintro
  101.  
  102. DO Grphead
  103. gl_intros=.F.
  104.  
  105. *-- File Loop
  106. DO WHILE FOUND() .AND. .NOT. EOF() .AND. gl_prntflg
  107.    DO CASE
  108.    CASE CUST_ID <> r_mvar4
  109.       gn_level=4
  110.    OTHERWISE
  111.       gn_level=0
  112.    ENDCASE
  113.    *-- test whether an expression didn't match
  114.    IF gn_level <> 0
  115.       DO Grpfoot WITH 100-gn_level
  116.       DO Grpinit
  117.    ENDIF
  118.    *-- Repeat group intros
  119.    IF gn_level <> 0
  120.       DO Grphead
  121.    ENDIF
  122.    gl_intros=.F.
  123.    gn_level=0
  124.    *-- Detail lines
  125.    IF gl_summary
  126.       DO Upd_Vars
  127.    ELSE
  128.       DO __Detail
  129.    ENDIF
  130.    gl_widow=.T.         && enable widow checking
  131.    CONTINUE
  132. ENDDO
  133.  
  134. IF gl_prntflg
  135.    gn_level=3
  136.    DO Grpfoot WITH 97
  137.    DO Rsumm
  138.    IF _plineno <= gn_atline
  139.       EJECT PAGE
  140.    ENDIF
  141. ELSE
  142.    gn_level=3
  143.    DO Rsumm
  144.    DO Reset
  145.    RETURN
  146. ENDIF
  147.  
  148. ON PAGE
  149.  
  150. ENDPRINTJOB
  151.  
  152. DO Reset
  153. RETURN
  154. * EOP: orders.FRG
  155.  
  156. *-- Determine height of group bands and detail band for widow checking
  157. FUNCTION Gheight
  158. PARAMETER Group_Band
  159. retval=0              && return value
  160. IF Group_Band <= 4
  161.    retval = retval + 2 * gn_pspace
  162. ENDIF
  163. *-- add height of detail band
  164. retval = retval + 5 * gn_pspace
  165. RETURN retval
  166. * EOP: Gheight
  167.  
  168. *-- Update summary fields and/or calculated fields.
  169. PROCEDURE Upd_Vars
  170. r_foot1=Cust_id
  171. *-- Count
  172. r_msum1=r_msum1+1
  173. *-- Count
  174. r_msum2=r_msum2+1
  175. RETURN
  176. * EOP: Upd_Vars
  177.  
  178. *-- Set flag to get out of DO WHILE loop when escape is pressed.
  179. PROCEDURE Prnabort
  180. gl_prntflg=.F.
  181. RETURN
  182. * EOP: Prnabort
  183.  
  184. *-- Reset group break variables.  Reinit summary
  185. *-- fields with reset set to a particular group band.
  186. PROCEDURE Grpinit
  187. IF gn_level <= 4
  188.    r_msum1=0
  189. ENDIF
  190. IF gn_level <= 4
  191.    r_mvar4=CUST_ID
  192. ENDIF
  193. RETURN
  194. * EOP: Grpinit
  195.  
  196. *-- Process Group Intro bands during group breaks
  197. PROCEDURE Grphead
  198. IF EOF()
  199.    RETURN
  200. ENDIF
  201. PRIVATE _pspacing
  202. _pspacing=gn_pspace
  203. IF gn_level = 0
  204.    gn_level=50
  205. ENDIF
  206. IF gn_level = 4
  207.    IF 2 * gn_pspace  < gn_atline
  208.       IF (gl_widow .AND. _plineno+Gheight(4) > gn_atline + 1) ;
  209.       .OR. (gl_widow .AND. _plineno+2 * gn_pspace > gn_atline)
  210.          EJECT PAGE
  211.       ENDIF
  212.    ENDIF
  213. ENDIF
  214. IF gn_level <= 4 .OR. gl_intros
  215.    DO Head4
  216. ENDIF
  217. gn_level=0
  218. RETURN
  219. * EOP: Grphead.PRG
  220.  
  221. *-- Process Group Summary bands during group breaks
  222. PROCEDURE Grpfoot
  223. PARAMETER ln_level
  224. IF ln_level >= 96
  225.    DO Foot96
  226. ENDIF
  227. RETURN
  228. * EOP: Grpfoot.PRG
  229.  
  230. PROCEDURE Pghead
  231. PRIVATE ll_heading, ln_width
  232. ll_heading = .T.
  233. ln_width = _rmargin - _lmargin
  234. ?
  235. *-- Print HEADING parameter - if it doesn't fit on line one
  236. *-- Value added to gn_length is the last column on line one times two
  237. IF .NOT. gl_plain .AND. gn_length + 160 > ln_width
  238.    ?? gc_heading FUNCTION "I;V"+LTRIM(STR(ln_width))
  239.    ?
  240.    ll_heading = .F.
  241. ENDIF
  242.  
  243. ?? IIF(gl_plain,'',gd_date) AT 0,;
  244.  IIF(gl_plain,'' , "PAGE " ) AT 71,;
  245.  IIF(gl_plain,'',_pageno) PICTURE "999" 
  246.  
  247. *-- Print HEADING parameter - if it fits on line one
  248. IF .NOT. gl_plain .AND. gn_length > 0 .AND. ll_heading
  249.    ?? " "
  250.    ?? gc_heading FUNCTION "I;V"+LTRIM(STR(ln_width-(_pcolno*2)))
  251. ENDIF
  252. ?
  253. ?
  254. ?
  255. RETURN
  256. * EOP: Pghead
  257.  
  258. PROCEDURE Rintro
  259. ?
  260. DEFINE BOX FROM 27 TO 56 HEIGHT 4 DOUBLE
  261. ?
  262. ?? "A-T FURNITURE INDUSTRIES" AT 30
  263. ?
  264. ?? "ORDERS REPORT" AT 35
  265. ?
  266. ?
  267. RETURN
  268. * EOP: Rintro
  269.  
  270. PROCEDURE Head4
  271. ?? ;
  272. "══════════════════════════════════════════════════════════════════════";
  273. + "═════════";
  274. AT 0
  275. ?
  276. ?? "CUSTOMER I.D.: " STYLE "BU" AT 0,;
  277.  Cust_id FUNCTION "T" STYLE "BU" 
  278. ?
  279. RETURN
  280.  
  281. PROCEDURE __Detail
  282. IF 5 * gn_pspace < gn_atline - (_pspacing * 4 + 1)
  283.    IF gl_widow .AND. _plineno+5 * gn_pspace > gn_atline + 1
  284.       EJECT PAGE
  285.       gl_intros=.F.
  286.    ENDIF
  287. ENDIF
  288. DO Upd_Vars
  289. ?? "ORDER DATE:  " AT 0,;
  290.  Date_trans ,;
  291.  "PART NUMBER: " AT 40,;
  292.  Part_id FUNCTION "T" ,;
  293.  "QUANTITY: " AT 66,;
  294.  Part_qty PICTURE "999" 
  295. ?
  296. ?? "P.O. NUMBER: " AT 0,;
  297.  Po_number FUNCTION "T" 
  298. ?
  299. ?? "SOLD BY EMPLOYEE: " AT 0,;
  300.  Emp_id FUNCTION "T" ,;
  301.  "INVOICED: " AT 66,;
  302.  Invoiced PICTURE "Y" AT 78
  303. ?
  304. ?? "NOTES: " AT 0,;
  305.  Notes FUNCTION "V64" AT 13
  306. ?
  307. ?? ;
  308. "──────────────────────────────────────────────────────────────────────";
  309. + "─────────";
  310. AT 0
  311. ?
  312. RETURN
  313. * EOP: __Detail
  314.  
  315. PROCEDURE Foot96
  316. ?? "NUMBER OF ORDERS FOR CUSTOMER " AT 0,;
  317.  r_foot1 FUNCTION "T" ,;
  318.  ": " ,;
  319.  r_msum1 PICTURE "999" 
  320. ?
  321. ?? ;
  322. "══════════════════════════════════════════════════════════════════════";
  323. + "═════════";
  324. AT 0
  325. ?
  326. ?
  327. RETURN
  328.  
  329. PROCEDURE Rsumm
  330. ?? "TOTAL NUMBER OF ORDERS: " AT 0,;
  331.  r_msum2 PICTURE "9,999" 
  332. ?
  333. ?? ;
  334. "══════════════════════════════════════════════════════════════════════";
  335. + "═════════";
  336. AT 0
  337. gl_fandl=.F.        && last page finished
  338. ?
  339. RETURN
  340. * EOP: Rsumm
  341.  
  342. PROCEDURE Pgfoot
  343. PRIVATE _box, _pspacing
  344. gl_widow=.F.         && disable widow checking
  345. _pspacing=1
  346. ?
  347. IF .NOT. gl_plain
  348.    _pspacing=gn_pspace
  349.    ?
  350.    ?? "PREPARED BY SALES DEPARTMENT" AT 28
  351.    ?
  352. ENDIF
  353. EJECT PAGE
  354. gl_intros=.T.
  355. *-- is the page number greater than the ending page
  356. IF _pageno > _pepage
  357.    GOTO BOTTOM
  358.    SKIP
  359.    gn_level=0
  360. ENDIF
  361. IF .NOT. gl_plain .AND. gl_fandl
  362.    _pspacing=gn_pspace
  363.    DO Pghead
  364.    IF gl_intros .AND. gn_level = 0
  365.      DO GrpHead
  366.      gl_newpage = .F.
  367.      gl_intros = .F.
  368.    ENDIF
  369. ENDIF
  370. RETURN
  371. * EOP: Pgfoot
  372.  
  373. *-- Process page break when PLAIN option is used.
  374. PROCEDURE Pgplain
  375. PRIVATE _box
  376. EJECT PAGE
  377. RETURN
  378. * EOP: Pgplain
  379.  
  380. *-- Reset dBASE environment prior to calling report
  381. PROCEDURE Reset
  382. SET SPACE &gc_space.
  383. SET TALK &gc_talk.
  384. ON ESCAPE
  385. ON PAGE
  386. RETURN
  387. * EOP: Reset
  388.  
  389.