home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / TPBARCOD.ZIP / BARCODE.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1990-01-20  |  6.7 KB  |  201 lines
  1. Unit BARCODE;
  2. Interface
  3. uses printer;
  4. CONST
  5.       High      :integer    = 6;
  6.       LeftSpace :integer    = 2;
  7.       Space     :integer    = 17;
  8.       Width     :integer    = 1;
  9.       CopyNum   :integer    = 1;
  10.       Prtr      :string[3]  = 'IBM';
  11.       Bold      :string[3]  = 'ON';
  12. Procedure Printbar(MSG : String; VAR Valid : Boolean);
  13. implementation
  14. Procedure printbar;
  15.  
  16.  
  17. TYPE
  18.   Bar      = string[84];
  19.  
  20.  
  21. VAR
  22.   Len,N1,N2,
  23.   Pass,Incr,Cols              : integer;
  24.   Test,Ch                     : char;
  25.   BarMsg                      : string[25];
  26.   Lbar                        : Bar;
  27.   NNs                         : string[2];
  28.   NWs                         : string[4];
  29.   NNb                         : string[1];
  30.   NWb                         : string[3];
  31.   Ns                          : string[8];
  32.   Ws                          : string[16];
  33.   Nb                          : string[4];
  34.   Wb                          : string[12];
  35.   Prnt                        : array[ 1..25] of Bar;
  36.   Enough        : boolean;
  37.  
  38.  
  39.  
  40. procedure SetWidth;
  41. VAR Z : integer;
  42.    begin
  43.      NS := '';
  44.      WS := '';
  45.      NB := '';
  46.      WB := '';
  47.      NNS := chr(0)+chr(0);                 { set Barcode characters   }
  48.      NWS := chr(0)+chr(0)+chr(0)+chr(0);
  49.      NNB := chr(255);
  50.      NWB := chr(255)+chr(255)+chr(255);
  51.      for Z := 1 to Width do
  52.         begin
  53.            NS := NS + NNS;
  54.            WS := WS + NWS;
  55.            NB := NB + NNB;
  56.            WB := WB + NWB
  57.         end;
  58.   end;
  59.  
  60. procedure Numb_To_Bars;
  61. VAR x : integer;
  62.   begin
  63.     Valid := true;
  64.     SetWidth;
  65.     for X := 1 to Len do
  66.       begin
  67.         Test := (BarMsg[X]);
  68.         case Test of
  69.         '1': Lbar := WB+NS+NB+WS+NB+NS+NB+NS+WB;
  70.         '2': Lbar := NB+NS+WB+WS+NB+NS+NB+NS+WB;
  71.         '3': Lbar := WB+NS+WB+WS+NB+NS+NB+NS+NB;
  72.         '4': Lbar := NB+NS+NB+WS+WB+NS+NB+NS+WB;
  73.         '5': Lbar := WB+NS+NB+WS+WB+NS+NB+NS+NB;
  74.         '6': Lbar := NB+NS+WB+WS+WB+NS+NB+NS+NB;
  75.         '7': Lbar := NB+NS+NB+WS+NB+NS+WB+NS+WB;
  76.         '8': Lbar := WB+NS+NB+WS+NB+NS+WB+NS+NB;
  77.         '9': Lbar := NB+NS+WB+WS+NB+NS+WB+NS+NB;
  78.         '0': Lbar := NB+NS+NB+WS+WB+NS+WB+NS+NB;
  79.         'A': Lbar := WB+NS+NB+NS+NB+WS+NB+NS+WB;
  80.         'B': Lbar := NB+NS+WB+NS+NB+WS+NB+NS+WB;
  81.         'C': Lbar := WB+NS+WB+NS+NB+WS+NB+NS+NB;
  82.         'D': Lbar := NB+NS+NB+NS+WB+WS+NB+NS+WB;
  83.         'E': Lbar := WB+NS+NB+NS+WB+WS+NB+NS+NB;
  84.         'F': Lbar := NB+NS+WB+NS+WB+WS+NB+NS+NB;
  85.         'G': Lbar := NB+NS+NB+NS+NB+WS+WB+NS+WB;
  86.         'H': Lbar := WB+NS+NB+NS+NB+WS+WB+NS+NB;
  87.         'I': Lbar := NB+NS+WB+NS+NB+WS+WB+NS+NB;
  88.         'J': Lbar := NB+NS+NB+NS+WB+WS+WB+NS+NB;
  89.         'K': Lbar := WB+NS+NB+NS+NB+NS+NB+WS+WB;
  90.         'L': Lbar := NB+NS+WB+NS+NB+NS+NB+WS+WB;
  91.         'M': Lbar := WB+NS+WB+NS+NB+NS+NB+WS+NB;
  92.         'N': Lbar := NB+NS+NB+NS+WB+NS+NB+WS+WB;
  93.         'O': Lbar := WB+NS+NB+NS+WB+NS+NB+WS+NB;
  94.         'P': Lbar := NB+NS+WB+NS+WB+NS+NB+WS+NB;
  95.         'Q': Lbar := NB+NS+NB+NS+NB+NS+WB+WS+WB;
  96.         'R': Lbar := WB+NS+NB+NS+NB+NS+WB+WS+NB;
  97.         'S': Lbar := NB+NS+WB+NS+NB+NS+WB+WS+NB;
  98.         'T': Lbar := NB+NS+NB+NS+WB+NS+WB+WS+NB;
  99.         'U': Lbar := WB+WS+NB+NS+NB+NS+NB+NS+WB;
  100.         'V': Lbar := NB+WS+WB+NS+NB+NS+NB+NS+WB;
  101.         'W': Lbar := WB+WS+WB+NS+NB+NS+NB+NS+NB;
  102.         'X': Lbar := NB+WS+NB+NS+WB+NS+NB+NS+WB;
  103.         'Y': Lbar := WB+WS+NB+NS+WB+NS+NB+NS+NB;
  104.         'Z': Lbar := NB+WS+WB+NS+WB+NS+NB+NS+NB;
  105.         '-': Lbar := NB+WS+NB+NS+NB+NS+WB+NS+WB;
  106.         '.': Lbar := WB+WS+NB+NS+NB+NS+WB+NS+NB;
  107.         ' ': Lbar := NB+WS+WB+NS+NB+NS+WB+NS+NB;
  108.         '*': Lbar := NB+WS+NB+NS+WB+NS+WB+NS+NB;
  109.         '$': Lbar := NB+WS+NB+WS+NB+WS+NB+NS+NB;
  110.         '/': Lbar := NB+WS+NB+WS+NB+NS+NB+WS+NB;
  111.         '+': Lbar := NB+WS+NB+NS+NB+WS+NB+WS+NB;
  112.         '%': Lbar := NB+NS+NB+WS+NB+WS+NB+WS+NB;
  113.         else
  114.             Valid := false
  115.         end;                  {Case}
  116.         Prnt[X] := Lbar;
  117.       end;                     {for}
  118.   end;                       {Numb_To_Bars}
  119.  
  120. procedure Do_Bar;
  121. var x : integer;
  122.    begin
  123.       for X := 1 to Len do
  124.         Msg[X] := upcase(Msg[X]);
  125.       Len :=Len + 2;
  126.       BarMsg := concat('*', Msg, '*');
  127.       Numb_To_Bars
  128.    end;
  129.  
  130.  
  131.  
  132. procedure Printnumber;
  133.  
  134.   VAR
  135.     I,X,Y,z,Pass,Counter : Integer;
  136.  
  137.   procedure SmallSpace( Feeds : Integer);
  138.   Var counter :integer;
  139.      begin
  140.         for Counter := 1 to Feeds do
  141.         writeln(lst, chr(27), chr(51), chr((Incr + 2) div 4));
  142.      end;
  143.  
  144.   begin
  145.     if Prtr = 'IBM' then Incr := 22
  146.     else Incr := 14;
  147.     Cols := 21 * Width * Len;
  148.     N1 := Cols mod 256; N2 := Cols div 256;
  149.     for I := 1 to CopyNum do                   { control number of copies }
  150.     begin
  151.        SmallSpace(4);
  152.        for Y := 1 to High do                    {print each line of barcode}
  153.        begin
  154.           for Pass := 1 to 2 do                 { two passes overlapped }
  155.           begin
  156.                for Z := 1 to Leftspace do
  157.                write(lst, ' ');                 { produce left margin   }
  158.                if Bold = 'ON' then
  159.                   write(lst, chr(27), chr(76), chr(N1), chr(N2))
  160.                                                 { set      DD graphics  }
  161.                else write(lst, chr(27), chr(75), chr(N1), chr(N2));
  162.                                                 { set      SD graphics  }
  163.                for X := 1 to Len do
  164.                   write(lst, Prnt[X], Ns);      { Print the bars and spaces }
  165.                if (Pass mod 2) = 0 then
  166.                   writeln(lst, chr(27), chr(51), chr(Incr))
  167.                                               { 8/72 inch line feed           }
  168.                                               { Incr = 22 for IBM; 14 for EPS }
  169.                else writeln(lst, chr(27), chr(51), chr(2))
  170.                                              { tiny LF to fill in dots        }
  171.           end;          { of Pass  }
  172.        end;             { of bar printing }
  173.        SmallSpace(3);       { 2/72 linefeed   }
  174.        for Z := 1 to (Leftspace + 1 + (Len*(Width-1) div 2)) do
  175.         write(lst, ' ');
  176.        if Bold = 'ON' then                         { enhanced print on       }
  177.           write(lst, chr(27), 'G')
  178.        else write(lst, chr(27), 'H');              { enhanced print off      }
  179.        for Z := 1 to length(Msg) do
  180.          begin
  181.            write(lst, Msg[Z]);
  182.            for X := 1 to Width do write(lst, ' '); {spaces between digits   }
  183.          end;
  184.       for X := 1 to Space do
  185.       Smallspace(1);
  186.     end;
  187.     writeln(lst, chr(27), chr(64));              { restore line spacing }
  188.   end;
  189.  
  190. begin
  191.       begin
  192.         Valid :=false;
  193.         Len := length(Msg);
  194.         if Len > 0 then Do_Bar;
  195.         if Valid then Printnumber
  196.         else Enough := true
  197.       end;
  198. end;
  199. end.
  200.  
  201.