home *** CD-ROM | disk | FTP | other *** search
/ Shareware Overload / ShartewareOverload.cdr / database / sri314_b.zip / DEMOPRGS.ZIP / LAB_GEN.PRG < prev    next >
Text File  |  1990-04-11  |  9KB  |  342 lines
  1. **********************************************************************
  2. *** LAB_GEN.PRG **
  3. **  (C) Copyright 1990, Sub Rosa Publishing Inc.
  4. **  A demonstration program provided to SR-Info and VP-Info users.
  5. **  This program may be copied freely. If it is used in commercial code,
  6. **  please credit the source, Sub Rosa Publishing Inc.
  7. **
  8. **  LAB_GEN is a much more complicated program than any of the others in
  9. **  the SUB ROSA demo collection. It is offerred as a 'DIPLOMA' program.
  10. **  When you have understood it all, you are well on yout way.
  11. **
  12. **
  13. *  LAB_GEN.prg   demonstration program use of macros, files as
  14. *     vectors, and general matrices. This is a general-purpose
  15. *     program generator capable of producing most forms of labels
  16. *     any number of labels across, up to width of printer.
  17. *  (Author: Sidney L. Bursten)
  18. **********************************************************************
  19. xpict=:picture        ;save standard picture, restore at end
  20. :picture='999'        ;use short picture in generating label program
  21. ON escape
  22.    SET print off
  23.    SPOOL
  24.    WINDOW
  25.    ERASE
  26.    :picture=xpict
  27.    CANCEL
  28. ENDON
  29. ON error
  30.    SET print off
  31.    SPOOL
  32.    WINDOW
  33.    ERASE
  34.    :picture=xpict
  35.    CANCEL
  36. ENDON
  37. DIM char 80 xline[6],xline2[6]  ;vectors to hold label-line expressions
  38. USE matrix compile    ;program must have a valid file in use to compile
  39. xfld1=0               ;variables to hold field numbers from structure
  40. xfld2=0
  41. xfld3=0
  42. xfld4=0
  43. xfld5=0
  44. xfld6=0
  45. xfld7=0
  46. xfld8=0
  47. xfld9=0
  48. xfld10=0
  49. xfname=blank(8)       ;data file name to be put into use with macro
  50. xndxname=blank(8)
  51. xwidth=4.25           ;default label width in inches
  52. xacross=3             ;default number of labels across
  53. xcpi=10               ;default characters per inch
  54. xlines=6              ;default depth of label (one inch at 6 lpi)
  55. xsetup='018'+blank(12)
  56. xselect='N'
  57. xselection=blank(50)
  58. WINDOW
  59. ERASE
  60. WINDOW 2,4,22,75 double      ;read in parameters of label job
  61. TEXT
  62. .. xfname,!!!!!!!!
  63. .. xndxname,!!!!!!!!
  64. .. xacross,9
  65. .. xwidth,99999.99
  66. .. xcpi,99.99
  67. .. xlines,99
  68. .. xsetup,999-999-999-999-999
  69. .. xselect,!
  70.  
  71.               GENERAL-PURPOSE PROGRAM GENERATOR FOR LABELS
  72.  
  73.               (To quit enter ALL BLANKS instead of filename.)
  74.  
  75.  
  76.   Enter name of file to print to labels........... @xfname
  77.  
  78.   Name of index file (if any) to use for order.... @xndxname
  79.  
  80.   Number of labels to print across................ @xacross
  81.   Number of lines per label (measure top to top).. @xlines
  82.  
  83.   Width of each label (right side to right side).. @xwidth  inches
  84.   Number of characters per inch for print font.... @xcpi
  85.  
  86.   Setup string to be sent to printer at start..... @xsetup
  87.   Should selection criteria be used (Y/N)?........ @xselect
  88. ENDTEXT
  89. ON field
  90. FIELD xfname
  91.    IF xfname=blank(8)
  92.       :field=65
  93.    ELSE
  94.       IF file(xfname)
  95.          USE &xfname
  96.       ELSE
  97.          :field=field(xfname)
  98.          SOUND 11
  99.       ENDIF
  100.    ENDIF
  101. FIELD xndxname
  102.    IF xndxname>blank(8)
  103.       IF file(trim(xndxname)+'.ndx')
  104.          SET index to &xndxname
  105.       ELSE
  106.          :field=field(xndxname)
  107.          SOUND 11
  108.       ENDIF
  109.    ENDIF
  110. FIELD xacross
  111.    IF xacross<1 .or. xacross>8
  112.       :field=field(xacross)
  113.       SOUND 11
  114.    ENDIF
  115. FIELD xwidth
  116.    IF xwidth<1 .or. xwidth>11
  117.       :field=field(xwidth)
  118.       SOUND 11
  119.    ENDIF
  120. FIELD xlines
  121.    IF xlines<4 .or. xlines>24
  122.       :field=field(xlines)
  123.       SOUND 11
  124.    ENDIF
  125. FIELD xcpi
  126.    IF xcpi<5 .or. xcpi>20
  127.       :field=field(xcpi)
  128.       SOUND 11
  129.    ENDIF
  130. ENDON
  131. READ
  132. xwidth=int(xcpi*xwidth-1)      ;width of ultimate label in characters
  133. xwidth2=int(xwidth-xcpi/2.5)   ;width that ensures no label contents run over end
  134. formxwidth=(xwidth+2)*xacross  ;total print width just enough to accommodate labels
  135. IF xfname=' '
  136.    CHAIN menu
  137. ENDIF
  138. IF xselect='Y'                 ;get and test valid selection criteria if required
  139.    SELECT 1,2
  140.    WINDOW 10,10,17,69 double
  141.    ? '     Selection Criteria Requested. Enter below:'
  142.    @ 13,13 get xselection
  143.    DO WHILE t
  144.       ERASE 13,17
  145.       READ
  146.       IF xselection=' ' .or. test(xselection)
  147.          BREAK
  148.       ENDIF
  149.       ? '    Error in selection criteria...Press any key.'
  150.       SOUND 7
  151.       inkey=inkey()
  152.    ENDDO
  153.    SCREEN 2,1
  154.    WINDOW
  155. ENDIF
  156. WINDOW
  157. ERASE
  158. USE &xfname
  159. WINDOW 1,35,22,78 double       ;list 1st 21 fields of file structure
  160. REPEAT min(21,dbf(fields)) times varying xfld
  161.    ?? str(xfld,2),fld(name,xfld)
  162.    ?
  163. ENDREPEAT
  164. IF dbf(fields)>21              ;if necessary, list next 21 fields of structure
  165.    WINDOW 1,55,22,78 blank
  166.    REPEAT min(21,dbf(fields)-21) times varying xfld
  167.       ?? str(xfld+21,2),fld(name,xfld+21)
  168.       ?
  169.    ENDREPEAT
  170. ENDIF
  171. WINDOW 1,1,22,30 double        ;read in field numbers to use in labels
  172. TEXT
  173. .. xfld1,99
  174. .. xfld2,99
  175. .. xfld3,99
  176. .. xfld4,99
  177. .. xfld5,99
  178. .. xfld6,99
  179. .. xfld7,99
  180. .. xfld8,99
  181. .. xfld9,99
  182. .. xfld10,99
  183.    For each of the following, enter number of the field containing the data to include in the label.
  184.  
  185.    If any item is not to appear, leave its number zero.
  186.  
  187.    Title..... @xfld1
  188.    First Name @xfld2
  189.    Last Name. @xfld3
  190.    Position.. @xfld4
  191.    Company... @xfld5
  192.    Address... @xfld6
  193.    City...... @xfld7
  194.    State..... @xfld8
  195.    Zip Code.. @xfld9
  196.    Country... @xfld10
  197. ENDTEXT
  198. READ
  199. WINDOW
  200. ERASE        ;following section generates expressions for label lines
  201. DO CASE      ;title, first name, last name
  202. CASE xfld1>0 .and. xfld2>0 .and. xfld3>0
  203.    xline[1]='ltrim(trim('+fld(name,xfld1)+')+" "+trim('+fld(name,xfld2)+')+" "+'+fld(name,xfld3)+')'
  204. CASE xfld2>0 .and. xfld3>0
  205.    xline[1]='ltrim(trim('+fld(name,xfld2)+')+" "+'+fld(name,xfld3)+')'
  206. CASE xfld3>0
  207.    xline[1]=fld(name,xfld3)
  208. ENDCASE
  209. IF xfld4>0   ;position
  210.    xline[2]=fld(name,xfld4)
  211. ENDIF
  212. IF xfld5>0   ;company
  213.    xline[3]=fld(name,xfld5)
  214. ENDIF
  215. IF xfld6>0   ;address
  216.    xline[4]=fld(name,xfld6)
  217. ENDIF
  218. DO CASE      ;city, state, zip
  219. CASE xfld7>0 .and. xfld8>0 .and. xfld9>0
  220.    xline[5]='ltrim(trim('+fld(name,xfld7)+')+", "+trim('+fld(name,xfld8)+')+"  "+'+fld(name,xfld9)+')'
  221. CASE xfld7>0 .and. xfld9>0
  222.    xline[5]='ltrim(trim('+fld(name,xfld7)+')+"  "+'+fld(name,xfld9)+')'
  223. CASE xfld7>0
  224.    xline[5]=fld(name,xfld7)
  225. CASE xfld7>0 .and. xfld8>0
  226.    xline[5]='ltrim(trim('+fld(name,xfld7)+')+", "+'+fld(name,xfld8)+')'
  227. CASE xfld9>0
  228.    xline[5]=fld(name,xfld9)
  229. ENDCASE
  230. IF xfld10>0  ;country
  231.    xline[6]=fld(name,xfld10)
  232. ENDIF
  233. CLS
  234. xlines2=0
  235. REPEAT 6 times varying xfld  ;eliminate empty lines in label form
  236.    IF xline[xfld]>' '
  237.       xlines2=xlines2+1
  238.       xline2[xlines2]=xline[xfld]
  239.    ENDIF
  240. ENDREPEAT
  241. xskip=xlines-xlines2-1      ;extra lines needed to get to full depth of label
  242. SPOOL label.prg
  243. DELETE file LABEL.cpl       ;old CPL must be deleted to force use of new program
  244. CLEAR gets
  245. ERASE
  246. cdate=date(dmy)
  247. ctime=time(ampm)
  248. SET print on                ;create the execution program LABEL.PRG
  249. ?? '**********************************************************************'
  250. TEXT
  251. * LABEL.PRG   USES &XFNAME   GENERATED &CDATE  &CTIME
  252. **********************************************************************
  253. WINDOW
  254. ERASE
  255. DIM char &xwidth2 label[6,&xacross]
  256. DIM char &xwidth labelout[&xlines2,&xacross]
  257. USE &XFNAME
  258. ENDTEXT
  259. IF xselect='Y' .and. xselection>' '
  260.    ? 'SET filter to '+xselection
  261. ENDIF
  262. IF xndxname>' '
  263.    ? 'SET index to',xndxname
  264. ELSE
  265.    DO CASE
  266.    CASE xfld9>0 .and. xfld3>0
  267.       ? 'INDEX on '+fld(name,xfld9)+'+!('+fld(name,xfld3)+') to xlabel'
  268.    CASE xfld3>0
  269.       ? 'INDEX on !('+fld(name,xfld3)+') to xlabel'
  270.    CASE xfld9>0
  271.       ? 'INDEX on '+fld(name,xfld9)+' to xlabel'
  272.    ENDCASE
  273. ENDIF
  274. TEXT
  275. SET print on
  276. SET width to &formxwidth
  277. GOTO top
  278. ENDTEXT
  279. IF xsetup>'   '
  280.    xstr=$(xsetup,1,3)
  281.    xsetup2='chr('+xstr+')'
  282.    REPEAT 4 times varying xfld
  283.       xstr=$(xsetup,xfld*3+1,3)
  284.       IF xstr='   '
  285.          BREAK
  286.       ENDIF
  287.       xsetup2=xsetup2+'+chr('+xstr+')'
  288.    ENDREPEAT
  289.    ? 'xsetup2='+xsetup2
  290.    ? '?? xsetup2'
  291. ENDIF
  292. TEXT
  293. DO WHILE .not. eof
  294.    REPEAT &xlines2 times varying xfld
  295.       REPEAT &xacross times varying xcolumn
  296.          labelout[xfld,xcolumn]=' '
  297.       ENDREPEAT
  298.    ENDREPEAT
  299.    REPEAT &xacross times varying xcolumn
  300. ENDTEXT
  301. REPEAT xlines2 times varying xfld
  302.    ? '      label[',str(xfld,2),',xcolumn]=',trim(xline2[xfld])
  303. ENDREPEAT
  304. TEXT
  305.       xline2=0
  306.       REPEAT &xlines2 times varying xline
  307.          IF label[xline,xcolumn]>' '
  308.             xline2=xline2+1
  309.             labelout[xline2,xcolumn]=label[xline,xcolumn]
  310.          ENDIF
  311.       ENDREPEAT
  312.       SKIP
  313.       IF eof
  314.          BREAK
  315.       ENDIF
  316.    ENDREPEAT
  317.    ? labelout
  318. ENDTEXT
  319. IF xskip>0
  320.    TEXT
  321.    REPEAT &xskip times
  322.       ?
  323.    ENDREPEAT
  324.    ENDTEXT
  325. ENDIF
  326. TEXT
  327. ENDDO
  328. SET print off
  329. EJECT
  330. *
  331. *                    *** end of program LABEL.PRG ***
  332. *              USES &XFNAME       GENERATED &CDATE     &CTIME
  333. ENDTEXT
  334. ?
  335. SET print off
  336. SPOOL
  337. :picture=xpict
  338. *WRITE label
  339. CHAIN LABEL
  340. *
  341. *                  *** END OF PROGRAM LAB_GEN.PRG ***
  342.