[Back to PRINTING SWAG index] [Back to Main SWAG index] [Original]

    { This unit writes EAN-8 and EAN-13 barcodes to an Epson, IBM Pro or HP
      Laser compatible printers. It has been tested on a variety of printers
      and works well.  The barcodes generated were able to be read by at least
      one brand of bar code reader.

    By Rohit Gupta

    You may use this as you see fit.

    }

    {$R-,B+,S-,I+,N-,D-,L-,Y-}
    {$M $4000,$4000,$8000}

    UNIT BarCode;

    INTERFACE

    CONST
         PrnPosn = 5;  { Print Offset Column }

    TYPE
        EAN_13  = STRING [13];

        Printer_Type = (Epson, Ibm, Laser);

    PROCEDURE Print_BarCode
              (VAR Lst    : TEXT;
                   Typ    : Printer_Type;
                   Code   : EAN_13;
                   NLines : INTEGER);

    IMPLEMENTATION

    FUNCTION Num (Arg : INTEGER) : STRING;
    VAR
       St : STRING [20];
    BEGIN
         STR (Arg,St);
         Num := St;
    END;

    PROCEDURE Print_BarCode (VAR Lst  : TEXT;   Typ    : Printer_Type;
                                 Code : EAN_13; NLines : INTEGER);

    CONST
         Max_Code_Len = 2*3 + 5 + 7*12;  { For 12 digit bar code }

         ESC = #27;

    TYPE
        Bar_Position = (Left,Centre,Right);
        One_Dig      = STRING [7];
        Buffer       = ARRAY [1..1024] OF CHAR;

    VAR
       LCode     : EAN_13;   { Local Copy, padded & checked }
       Seg_Size,             { Left/Right Segment Size      }
       Code_Len,             { Size of BarCode in digits    }
       Bar_Len,              { Size of Barcode in bar units }
       Bytes,                { Bytes per bar unit           }
       Line_Len,             { Line Length in Gfx Mode      }
       Mult      : INTEGER;  { Number of Lines per char line}

       Full_Code : STRING [Max_Code_Len];

       PBuffer   : ^Buffer;
       Posn      : INTEGER;  { Buffer Position }

    PROCEDURE Rationalise_Code;
    VAR
       I : INTEGER;
    BEGIN
         IF LENGTH (Code) > 8
         THEN Seg_Size := 6
         ELSE Seg_Size := 4;

         Code_Len := Seg_Size * 2;

         LCode := Code;
         FOR I := LENGTH(LCode)+1 TO Code_Len-1  { Pad with Leading Zeros }
         DO LCode := '0' + LCode;

         Bar_Len := 2*3 + 5 + 7*Code_Len;
                 {  LRG   CG  CODE }
    END;

    PROCEDURE Calc_Check_Digit;
    VAR
       I, C1 : INTEGER;
    BEGIN
         IF Code_Len <> LENGTH(LCode)+1  { If already there, assume ok }
         THEN EXIT;

         C1 := 0;
         FOR I := Seg_Size DOWNTO 1
         DO INC (C1,ORD(LCode[I*2-1])-$30);
         C1 := C1 * 3;
         FOR I := Seg_Size-1 DOWNTO 1
         DO INC (C1,ORD(LCode[I*2])-$30);

         LCode := LCode + CHR (((10-(C1 MOD 10)) MOD 10) +$30);
    END;

    PROCEDURE Guard (Which : Bar_Position);
    VAR
       Dig : One_Dig;
    BEGIN
         CASE Which OF
              Centre : Dig := '01010';
              ELSE     Dig := '101';
         END;
         Full_Code := Full_Code + Dig;
    END;

    FUNCTION DigA (Arg : EAN_13) : One_Dig;
    VAR
       Dig : One_Dig;
       I   : INTEGER;
    BEGIN
         FOR I := 1 TO LENGTH (Arg)
         DO BEGIN
            CASE Arg[I] OF
                 '9' : Dig := '0001011';
                 '8' : Dig := '0110111';
                 '7' : Dig := '0111011';
                 '6' : Dig := '0101111';
                 '5' : Dig := '0110001';
                 '4' : Dig := '0100011';
                 '3' : Dig := '0111101';
                 '2' : Dig := '0010011';
                 '1' : Dig := '0011001';
                 ELSE  Dig := '0001101';
            END;
            Full_Code := Full_Code + Dig;
         END;
    END;

    PROCEDURE DigB (Arg : EAN_13);
    VAR
       Dig : One_Dig;
       I   : INTEGER;
    BEGIN
         FOR I := 1 TO LENGTH (Arg)
         DO BEGIN
            CASE Arg[I] OF
                 '9' : Dig := '0010111';
                 '8' : Dig := '0001001';
                 '7' : Dig := '0010001';
                 '6' : Dig := '0111001';
                 '5' : Dig := '0111001';
                 '4' : Dig := '0011101';
                 '3' : Dig := '0100001';
                 '2' : Dig := '0011011';
                 '1' : Dig := '0110011';
                 ELSE  Dig := '0100111';
            END;
            Full_Code := Full_Code + Dig;
         END;
    END;

    PROCEDURE DigC (Arg : EAN_13);
    VAR
       Dig : One_Dig;
       I   : INTEGER;
    BEGIN
         FOR I := 1 TO LENGTH (Arg)
         DO BEGIN
            CASE Arg[I] OF
                 '9' : Dig := '1110100';
                 '8' : Dig := '1001000';
                 '7' : Dig := '1000100';
                 '6' : Dig := '1010000';
                 '5' : Dig := '1001110';
                 '4' : Dig := '1011100';
                 '3' : Dig := '1000010';
                 '2' : Dig := '1101100';
                 '1' : Dig := '1100110';
                 ELSE  Dig := '1110010';
            END;
            Full_Code := Full_Code + Dig;
         END;
    END;

    PROCEDURE Compose_Code;
    BEGIN
         Full_Code := '';
         Guard (Left);
         DigA  (COPY(LCode,1,Seg_Size));
         Guard (Centre);
         DigC  (COPY(LCode,Seg_Size+1,Seg_Size*2));
         Guard (Right);
    END;

    PROCEDURE Init_Buffer;
    BEGIN
         NEW (PBuffer);
         FILLCHAR (PBUffer^,SIZEOF(PBuffer^),#0);
         Posn := 0;

         CASE Typ OF
              Epson : BEGIN
                           Bytes    := 3*3; { 3 pixels x 24 pins }
                           Line_Len := 3*Bar_Len;
                           Mult     := 1;
                      END;
              Ibm   : BEGIN
                           Bytes    := 4;     { 4 pixels X 8 pins }
                           Line_Len := 4*Bar_Len;
                           Mult     := 1;
                      END;
              ELSE    BEGIN
                           Bytes    := 0;     { 5 pixels }
                           Line_Len := (5*Bar_Len +7) DIV 8;
                           Mult     := 37 * NLines;
                           NLines   := 1;
                      END;
         END;
    END;

    PROCEDURE Send_Preamble;
    VAR
       St : STRING [20];
    BEGIN
         IF NLines <> 1
         THEN BEGIN
              CASE Typ OF
                   Epson : St := ESC+'0';
                   Ibm   : St := ESC+'3'#24;
                   ELSE    St := ESC+'&l8D';
              END;
              WRITE (Lst,St);
         END;
    END;

    PROCEDURE Send_Postamble;
    BEGIN
         IF NLines <> 1
         THEN IF Typ = Laser
              THEN WRITE (Lst,ESC,'&l6D')
              ELSE WRITE (Lst,ESC,'2');
    END;

    PROCEDURE Send_Buffer;
    VAR
       I : INTEGER;
    BEGIN
         CASE Typ OF
              Epson : WRITE (Lst,ESC,'*'#$27,CHR(Line_Len MOD 256),CHR(Line_Len DIV 256));
              Ibm   : WRITE (Lst,ESC,'Z',CHR(Line_Len MOD 256),CHR(Line_Len DIV 256));
              ELSE    WRITE (Lst,ESC,'*t300R',ESC,'*r1A',ESC,'*b',Line_Len,'W');
         END;

         FOR I := 1 TO Posn
         DO WRITE (Lst,PBuffer^[I]);

         CASE Typ OF
              Laser : WRITE (Lst, ESC, '*rB');
         END;
    END;

    PROCEDURE Compose_Buffer;
    VAR
       I   : INTEGER;
       Bar : CHAR;
       Blk,
       Spc : STRING [12];

    PROCEDURE Add (St : STRING);
    BEGIN
         MOVE (St[1],PBuffer^[Posn+1],LENGTH (St));
         INC (Posn,LENGTH (St));
    END;

    VAR
       Frag, Len : INTEGER;

    PROCEDURE Add_Frag (B : BYTE);
    BEGIN
         Frag := (Frag SHL 5) OR (B AND $1F);
         INC (Len,5);
         IF Len >= 8
         THEN BEGIN
              Add (CHR (Frag SHR (Len-8)));
              DEC (Len,8);
         END;
    END;

    PROCEDURE Add_Bar (Bar : CHAR);
    BEGIN
         IF Typ = Laser        { 1-dot-line at a time }
         THEN BEGIN
              IF Bar = '0'
              THEN Add_Frag (0)
              ELSE Add_Frag ($1F);
         END
         ELSE BEGIN            { 8/24-dot-lines at a time }
              IF Bar = '0'
              THEN Add (Spc)
              ELSE Add (Blk);
         END;
    END;

    BEGIN
         Frag := 0;
         Len  := 0;

         Blk := '';             { Compose the unit stripes }
         Spc := '';
         FOR I := 1 TO Bytes
         DO BEGIN
            Blk := Blk + #$FF;
            Spc := Spc + #$00;
         END;

         FOR I := 1 TO LENGTH (Full_Code)  { Compose Bars }
         DO Add_Bar (Full_Code [I]);

         IF Typ = Laser
         THEN WHILE Posn < Line_Len
              DO Add_Bar ('0')
    END;

    VAR
       I,J : INTEGER;

    BEGIN

         Rationalise_Code;
         Calc_Check_Digit;
         Compose_Code;
         Init_Buffer;
         Compose_Buffer;

         Send_Preamble;

         FOR I := 1 TO NLines
         DO BEGIN
            WRITE (Lst,'':PrnPosn);
            FOR J := 1 TO Mult
            DO BEGIN
               Send_Buffer;
            END;
            WRITELN (Lst);
         END;

         Send_Postamble;
         WRITELN (Lst,'':PrnPosn+2,LCode); WRITELN (Lst);
    END;

    END.

    { ----------------------    TEST PROGRAM  ---------------------------------- }

    USES
        Crt, Barcode, Printer;

    VAR
    {  Lst : TEXT;}
       Ch  : CHAR;
       Typ : Printer_Type;

    BEGIN
         WRITELN;
         WRITELN ('Bar Code Test');
         WRITELN;

         WRITE ('Select Printer Type (E=Epson, I=IbmPro, L=HPLaser) ');

         Ch := UPCASE (READKEY);

         CASE Ch OF
              'L' : Typ := Laser;
              'I' : Typ := Ibm;
              'E' : Typ := Epson;
              ELSE EXIT;
         END;

    {    ASSIGN (Lst,'TEST');
         REWRITE (Lst);}

         Print_BarCode (Lst,Typ,'1234567',    1);
         Print_BarCode (Lst,Typ, '9876543',   1);
         Print_BarCode (Lst,Typ,'12345678901',1);

         Print_BarCode (Lst,Typ,'1234567',    2);
         Print_BarCode (Lst,Typ, '9876543',   2);
         Print_BarCode (Lst,Typ,'12345678901',2);

         WRITE (Lst,#$0C);

    {    CLOSE (Lst);}
    END.

[Back to PRINTING SWAG index] [Back to Main SWAG index] [Original]