Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/POSTNT.ZIP/POSTNT.PAS

Pascal/Delphi Source File | 1990-02-25 | 8.0 KB | 384 lines

program POSTNT;

{ Date: 02-25-90 }

(*********************************************************************)
(* POSTNT was written as an exercise. The intent was to produce      *)
(* a program which could print US Postal Service POSTNET barcodes    *)
(* (those lines on lower right corner of some of the letters         *)
(* you get in the mail) which could be used for demonstration        *)
(* and information purposes. As it turned out, the barcodes          *)
(* actually are 'readable' on a barcode sorter.                      *)
(*                                                                   *)
(*                                                                   *)
(* This program was written by Dave Barrett, CS 76314,1004           *)
(* This program is put in the public domain with the following       *)
(* conditions:                                                       *)
(*                                                                   *)
(* 1) This portion of the documentation must remain with the source. *)
(* 2) If you make any improvements to the program please post them   *)
(*    so others can enjoy them.                                      *)
(* 3) This program must be distributed without charge whether used   *)
(*    alone or included as part of another program.                  *)
(* 4) Please include the accompanying file POSTNT.DOC along with     *)
(*    this file                                                      *)
(*********************************************************************)



uses dos,crt,printer;

type
 NumberSet = set of char;

var
 CheckDigit,
 ZIPString : string[200];
 Afield,
 Bfield : string [10];
 Numbers : NumberSet;
 CheckNumber,
 result : integer;

 ZIPCodeIsValid : boolean;

procedure PrintFullBar;
begin
 Write(Lst,char(255));
 Write(Lst,char(255));
 Write(Lst,char(255));
 Write(Lst,char(255));
end;

procedure PrintFullSpace;
begin
 Write(Lst,char(0));
 Write(Lst,char(0));
 Write(Lst,char(0));
 Write(Lst,char(0));
 Write(Lst,char(0));
 Write(Lst,char(0));
 Write(Lst,char(0));
 Write(Lst,char(0));
end;

procedure PrintPartSpace;
begin
 Write(Lst,char(0));
 Write(Lst,char(0));
 Write(Lst,char(0));
 Write(Lst,char(0));
 Write(Lst,char(0));
 Write(Lst,char(0));
 Write(Lst,char(0));
end;

procedure PrintHalfBar;
begin
 Write(Lst,char(15));
 Write(Lst,char(15));
 Write(Lst,char(15));
 Write(Lst,char(15));
end;

procedure PrintFrameBar;
begin
 PrintFullBar;
 PrintFullSpace;
end;

procedure Print0;
begin
 PrintFullBar;
 PrintFullSpace;
 PrintFullBar;
 PrintPartSpace;
 PrintHalfBar;
 PrintFullSpace;
 PrintHalfBar;
 PrintPartSpace;
 PrintHalfBar;
 PrintFullSpace;
end;

procedure Print1;
begin
 PrintHalfBar;
 PrintFullSpace;
 PrintHalfBar;
 PrintPartSpace;
 PrintHalfBar;
 PrintFullSpace;
 PrintFullBar;
 PrintPartSpace;
 PrintFullBar;
 PrintFullSpace;
end;

procedure Print2;
begin
 PrintHalfBar;
 PrintFullSpace;
 PrintHalfBar;
 PrintPartSpace;
 PrintFullBar;
 PrintFullSpace;
 PrintHalfBar;
 PrintPartSpace;
 PrintFullBar;
 PrintFullSpace;
end;

procedure Print3;
begin
 PrintHalfBar;
 PrintFullSpace;
 PrintHalfBar;
 PrintPartSpace;
 PrintFullBar;
 PrintFullSpace;
 PrintFullBar;
 PrintPartSpace;
 PrintHalfBar;
 PrintFullSpace;
end;

procedure Print4;
begin
 PrintHalfBar;
 PrintFullSpace;
 PrintFullBar;
 PrintPartSpace;
 PrintHalfBar;
 PrintFullSpace;
 PrintHalfBar;
 PrintPartSpace;
 PrintFullBar;
 PrintFullSpace;
end;

procedure Print5;
begin
 PrintHalfBar;
 PrintFullSpace;
 PrintFullBar;
 PrintPartSpace;
 PrintHalfBar;
 PrintFullSpace;
 PrintFullBar;
 PrintPartSpace;
 PrintHalfBar;
 PrintFullSpace;
end;

procedure Print6;
begin
 PrintHalfBar;
 PrintFullSpace;
 PrintFullBar;
 PrintPartSpace;
 PrintFullBar;
 PrintFullSpace;
 PrintHalfBar;
 PrintPartSpace;
 PrintHalfBar;
 PrintFullSpace;
end;

procedure Print7;
begin
 PrintFullBar;
 PrintFullSpace;
 PrintHalfBar;
 PrintPartSpace;
 PrintHalfBar;
 PrintFullSpace;
 PrintHalfBar;
 PrintPartSpace;
 PrintFullBar;
 PrintFullSpace;
end;

procedure Print8;
begin
 PrintFullBar;
 PrintFullSpace;
 PrintHalfBar;
 PrintPartSpace;
 PrintHalfBar;
 PrintFullSpace;
 PrintFullBar;
 PrintPartSpace;
 PrintHalfBar;
 PrintFullSpace;
end;

procedure Print9;
begin
 PrintFullBar;        { 4 }
 PrintFullSpace;      { 8 }
 PrintHalfBar;        { 4 }
 PrintPartSpace;      { 7 }
 PrintFullBar;        { 4 }
 PrintFullSpace;      { 8 }
 PrintHalfBar;        { 4 }
 PrintPartSpace;      { 7 }
 PrintHalfBar;        { 4 }
 PrintFullSpace;      { 8 }
end;

procedure PrintBarCode(s:integer);
var
 i : integer;
begin
 PrintFrameBar;
 i:=1;
 while i <= Length(ZIPString) do
  begin
   case ZIPString[i] of
    '0':Print0;
    '1':Print1;
    '2':Print2;
    '3':Print3;
    '4':Print4;
    '5':Print5;
    '6':Print6;
    '7':Print7;
    '8':Print8;
    '9':Print9;
   end;
   i:=i+1;
  end;
 PrintFrameBar;
 if s=1 then
  else
   Writeln(Lst);
end;

procedure DetermineCheckDigit;
var
 zip_digit,
 zip_total,
 i : integer;
begin
 zip_total:=0;
 for i:=1 to Length(ZIPString) do
  begin
   Val(ZIPString[i],zip_digit,result);
   zip_total:=zip_total+zip_digit;
  end;
 CheckNumber:=10 - (zip_total MOD 10);
 Str(CheckNumber:1,CheckDigit);
 ZIPString:=ZIPString+CheckDigit;
end;

procedure VerifyDigits;
var
 i : integer;
begin
 Numbers:=['0','1','2','3','4','5','6','7','8','9'];
 ZIPCodeIsValid:=true;
 if ((Copy(ZIPString,1,1)='A') OR (Copy(ZIPString,1,1)='a'))
    AND ((Copy(ZIPString,2,1)='B') OR (Copy(ZIPString,2,1)='b'))
    AND (Length(ZIPString)=13) then
  ZIPString:=Copy(ZIPString,3,11);
 if (Length(ZIPString)=5) then
  begin
   for i:=1 to 5 do
    if ZIPString[i] in Numbers then
     begin end
    else
     ZIPCodeIsValid:=false;
  end
 else
  if (Length(ZIPString)=9) then
   begin
    for i:=1 to 9 do
     if ZIPString[i] in Numbers then
      begin end
     else
      ZIPCodeIsValid:=false;
   end
  else
   if (Length(ZIPString)=10) AND (Pos('-',ZIPString)=6) then
    begin
     Delete(ZIPString,6,1);
     for i:=1 to 9 do
      if ZIPString[i] in Numbers then
       begin end
      else
       ZIPCodeIsValid:=false;
    end
   else
    if (Length(ZIPString)=11) then
     begin
      for i:=1 to 11 do
       if ZIPString[i] in Numbers then
        begin end
       else
        ZIPCodeIsValid:=false;
     end
    else
     ZIPCodeIsValid:=false;
end;

procedure Initialization;
begin
 if ParamCount = 1 then
  begin
   ZIPString:=ParamStr(1);
   VerifyDigits;
  end
 else
  ZIPCodeIsValid:=false;
end;

begin
 ZIPString:='';
 Initialization;
 if ZIPCodeIsValid then
  begin
   if Length(ZIPString)=11 then
    begin
     Afield:=Copy(ZIPString,1,5);
     Bfield:=Copy(ZIPString,6,6);
     ZIPString:=Afield;
     DetermineCheckDigit;
     Write(Lst,char(27),'Z',char(116),char(1));
     PrintBarCode(1);    { no CR/LF }
     Write(Lst,'    ');
     ZIPString:=Bfield;
     DetermineCheckDigit;
     Write(Lst,char(27),'Z',char(174),char(1));
     PrintBarCode(0);       { CR/LF ok }
    end
   else
    begin
      DetermineCheckDigit;
      if Length(ZIPSTring) = 6 then
       Write(Lst,char(27),'Z',char(116),char(1))
      else
       Write(Lst,char(27),'Z',char(92),char(2));
      PrintBarCode(0);       { CR/LF ok }
     end;
  end
 else
  begin
   TextColor(LightGray);
   TextBackground(Black);
   ClrScr;
   Writeln;
   Writeln('Usage is ....');
   Writeln;
   Writeln('POSTNT zipcode');
   Writeln;
   Writeln('Where  zipcode  is a 5, 9, or 10 character ZIP in the form');
   Writeln('    99999    or    999999999    or    99999-9999');
   Writeln('or an AB field 11 character ZIP in the form');
   Writeln('    AB99999999999');
   Writeln('Note that in the AB field example above the use of   AB');
   Writeln('preceeding the 11 digit ZIP is required!');
   Writeln;
  end;
end.