home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / CODE39.ZIP / CODE39.PAS
Encoding:
Pascal/Delphi Source File  |  1987-07-09  |  8.2 KB  |  237 lines
  1.  
  2.  
  3. program Barcode;
  4. {           by:
  5.                  Clifford Knight
  6.                  6 Janebar Circle
  7.                  Plymouth, MA  02360
  8.                  617 888 7480
  9.                  CIS ID# 71106,1153
  10. }
  11. {*** Logmars (Code 39) barcode routines for Epson FX compatible printers ***
  12.      NOTE: MIL-STD-1189 (latest revision) has made the OCR-A HRI (Human
  13.      Readable Interpretation) of the barcode optional...  Therefore, this
  14.      routine will produce acceptable LOGMARS labels provided that you
  15.      apply a layer of waterproof clear tape...  I have done this for
  16.      government orders with NO problems.
  17.      To implement, first call the procedure InitBarCode, then call
  18.      PrintBarCode to actually print the barcode...  See the routines
  19.      for an explanation of the passed parameters.
  20.      The PrintBarCode routine allows you to place the barcode almost
  21.      anywhere on your label using 1/216th inch for vertical measure and
  22.      1/960th inch for horizontal offsets.  Note that the vertical positioning
  23.      is specified for "start" and "end", or "before" printing the barcode and
  24.      "after" printing the code.  The Epson MX and it's kin do not allow
  25.      reverse paper motion so this (negative motion) will NOT work with
  26.      these printers.
  27.      If you specify the 'ht' parameter (in PrintBarCode) as 2 times the
  28.      'z' (Size) parameter of the InitBarCode routine, then you'll meet the
  29.      Logmars height/length ratio requirement.
  30.      By changing the FillBCArray routines assignment statements to fit
  31.      other codes (Code 2 of 5, UPC or ???) this routine could do any of
  32.      these other sequences.
  33.      Enjoy, if you have any questions -or- just to chat, drop a line
  34.      (EMail or USPS) to the above addresses...
  35. }
  36.    type
  37.      Str10           =string[10];
  38.      Str80           =string[80];
  39.    var
  40.      Sequence        :Str80;
  41.      BCArray         :array[0..1000] of byte;
  42.      BCArrayLen      :integer;
  43.      BCGraphLen      :integer;
  44.      BCKWide         :integer;
  45.      BCKNarr         :integer;
  46.      BCPasses        :integer;
  47.      BCount          :integer;
  48.      Size            :integer;
  49.      Density         :integer;
  50.      BCFile          :text;
  51. {***** BarCode Routines *****}
  52.    procedure PrintBarCode (ho,vs,ve,fl,ht :integer);
  53. {          ho = horizontal offset in 960th's of an inch
  54.            vs = vertical offset (+ or -) at start of barcode
  55.                 in 216th's of an inch
  56.            ve = vertical offset (+ or -) at end of barcode
  57.                 in 216th's of an inch
  58.            fl = barcode field length in 960th's of an inch
  59.            ht = number of graphics passes/barcode
  60.                   (1 pass = 23/216th's inch)
  61. }
  62.      var
  63.        f,h,i,j,k,l,m  :integer;
  64.        vc,gch         :char;
  65.      procedure GraphicTab (n :integer);
  66.        begin
  67.          write(lst,#27,'L',chr(lo(n)),chr(hi(n)));
  68.          while n>0 do begin
  69.            write(lst,#0);
  70.            n:=pred(n);
  71.            end;
  72.          end;                      {GraphicTab}
  73.      begin
  74.        k:=(fl-BCGraphLen) div 2;
  75.        if vs<>0 then begin
  76.          if vs>0 then vc:='J'
  77.          else vc:='j';
  78.          write(lst,#27,vc,chr(abs(vs)));
  79.          end;
  80.        for h:=1 to ht do begin
  81.          for m:=1 to BCPasses do begin
  82.            write(lst,#13);
  83.            if ho>0 then GraphicTab(ho);
  84.            if k>0 then GraphicTab(k);
  85.            write(lst,#27,'Y',chr(lo(BCGraphLen)),chr(hi(BCGraphLen)));
  86.            f:=1;
  87.            for i:=1 to BCArrayLen do begin
  88.              f:=swap(f);
  89.              gch:=chr(hi(f)*$ff);
  90.              for j:=1 to BCArray[i] do write(lst,gch);
  91.              end;
  92.            write(lst,#13);
  93.            end;
  94.          if h<ht then write(lst,#27,'J',#23);
  95.          end;
  96.        if ve<>0 then begin
  97.          if ve>0 then vc:='J'
  98.          else vc:='j';
  99.          write(lst,#27,vc,chr(abs(ve)));
  100.          end;
  101.        end;                        {PrintBarCode}
  102.    procedure InitBarCode (s :Str80; z,d :integer);
  103. {           s = sequence to be encoded
  104.                 ('*' prefix & suffix will be added)
  105.             z = size, number of columns in narrow bar
  106.             d = density, number of print head passes
  107.                   per graphic line
  108. }
  109.      procedure FillBCArray (c :char);
  110.        var
  111.          s         :Str10;
  112.          e,h,i     :integer;
  113.        begin
  114.          c:=UpCase(c);
  115.          case c of
  116.            ' ' : s:='0110001000';
  117.            '$' : s:='0101010000';
  118.            '%' : s:='0001010100';
  119.            '*' : s:='0100101000';
  120.            '+' : s:='0100010100';
  121.            '-' : s:='0100001010';
  122.            '.' : s:='1100001000';
  123.            '/' : s:='0101000100';
  124.            '0' : s:='0001101000';
  125.            '1' : s:='1001000010';
  126.            '2' : s:='0011000010';
  127.            '3' : s:='1011000000';
  128.            '4' : s:='0001100010';
  129.            '5' : s:='1001100000';
  130.            '6' : s:='0011100000';
  131.            '7' : s:='0001001010';
  132.            '8' : s:='1001001000';
  133.            '9' : s:='0011001000';
  134.            'A' : s:='1000010010';
  135.            'B' : s:='0010010010';
  136.            'C' : s:='1010010000';
  137.            'D' : s:='0000110010';
  138.            'E' : s:='1000110000';
  139.            'F' : s:='0010110000';
  140.            'G' : s:='0000011010';
  141.            'H' : s:='1000011000';
  142.            'I' : s:='0010011000';
  143.            'J' : s:='0000111000';
  144.            'K' : s:='1000000110';
  145.            'L' : s:='0010000110';
  146.            'M' : s:='1010000100';
  147.            'N' : s:='0000100110';
  148.            'O' : s:='1000100100';
  149.            'P' : s:='0010100100';
  150.            'Q' : s:='0000001110';
  151.            'R' : s:='1000001100';
  152.            'S' : s:='0010001100';
  153.            'T' : s:='0000101100';
  154.            'U' : s:='1100000010';
  155.            'V' : s:='0110000010';
  156.            'W' : s:='1110000000';
  157.            'X' : s:='0100100010';
  158.            'Y' : s:='1100100000';
  159.            'Z' : s:='0110100000'  end;
  160.                                    {case}
  161.          for h:=1 to 10 do begin
  162.            BCArrayLen:=succ(BCArrayLen);
  163.            BCArray[BCArrayLen]:=(ord(s[h])-48)*BCKWide+BCKNarr;
  164.            end;
  165.          end;                      {FillBCArray}
  166.      procedure ScanSequence (s :Str80);
  167.        var
  168.          h,i       :integer;
  169.        begin
  170.          BCArrayLen:=0;
  171.          s:='*'+s+'*';
  172.          for h:=1 to length(s) do begin
  173.            FillBCArray(s[h]);
  174.            end;
  175.          end;                      {ScanSequence}
  176.      procedure GetBCGraphLen;
  177.        var
  178.          f,j,i     :integer;
  179.        begin
  180.          f:=1;
  181.          BCGraphLen:=0;
  182.          for i:=1 to BCArrayLen do begin
  183.            f:=swap(f);
  184.            for j:=1 to (BCArray[i]+lo(f)) do BCGraphLen:=succ(
  185.                 BCGraphLen);
  186.            BCArray[i]:=BCArray[i]+lo(f);
  187.            end;
  188.          end;                      {GetBCGraphLen}
  189.      begin
  190.        BCKWide:=z*2;
  191.        BCKNarr:=z;
  192.        BCPasses:=d;
  193.        ScanSequence(s);
  194.        GetBCGraphLen;
  195.        end;                        {InitBarCode}
  196. {NOTE: The following function is used in the demo routine...
  197.        It is NOT needed by the barcode routines.
  198. }
  199. function ConstStr (n :integer; c :char) :Str80;
  200. var
  201.   s :Str80;
  202. begin
  203.   fillchar(s[1],n,c);
  204.   s[0]:=chr(n);
  205.   ConstStr:=s;
  206.   end;
  207. {*** sample test routine ***}
  208.    begin
  209.      repeat
  210.        clrscr;
  211.        write('Enter size (1..5, -99 to end...): ');
  212.        readln(Size);
  213.        if Size<>-99 then begin
  214.          write('Enter density (1..3, -99 to end...): ');
  215.          readln(Density);
  216.          if Density<>-99 then begin
  217.            repeat
  218.              write('Enter sequence (-99 to end...): ');
  219.              readln(Sequence);
  220.              if (Sequence<>'-99') then begin
  221.                writeln('printing: ',Sequence,#10);
  222.                InitBarCode(Sequence,Size,Density);
  223.                PrintBarCode(10,0,0,960,Size*2);
  224.                write(lst,#13,#10,#27,'E');
  225.                writeln(lst,ConstStr(40-trunc(length(Sequence)/2),' '),
  226.                     Sequence);
  227.                writeln(lst,ConstStr(6,#10));
  228.                end;
  229.              until (Sequence='-99') or keypressed;
  230.            end;
  231.          end;
  232.        until (Size=-99) or (Density=-99);
  233.      end.
  234.  
  235. Download complete.  Turn off Capture File.
  236.  
  237. Download another file (Y/N)?