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