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