//---------------------------------------------------------------------------
// Generowanie kodow kreskowych Code 93
// www.algorytm.org
// (c)2006 Tomasz Lubinski

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ExtCtrls;

type
  TForm1 = class(TForm)
    Image1: TImage;
    Button1: TButton;
    Kod: TEdit;
    procedure Button1Click(Sender: TObject);
  private
    curentPos: Integer;
    procedure DrawBars(txt: String; converted: String);
    procedure DrawSignBars(bars: array of Byte);
    function Check(txt: String): Boolean;
    function CheckLetter(ch: Char): Boolean;
    function GetLetterValue(ch: Char) : Integer;
    function CheckDigitC(txt: String): Integer;
    function CheckDigitK(txt: String; checkDigitC: Byte): Integer;
    function Convert(txt: String): String;
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

  special_1 : Char = Char(127 + 1); // ($)
  special_2 : Char = Char(127 + 2); // (%)
  special_3 : Char = Char(127 + 3); // (/)
  special_4 : Char = Char(127 + 4); // (+)

  code93sign : array [0..46] of Char = (
        '0', '1', '2', '3', '4', '5', '6', '7', '8', '9',
        'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J',
        'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T',
        'U', 'V', 'W', 'X', 'Y', 'Z', '-', '.', ' ', '$',
        '/', '+', '%', #$80, #$81, #$82, #$83);

  code93bars : array [0..46] of array [0..8] of Byte = (
        (1, 0, 0, 0, 1, 0, 1, 0, 0),
        (1, 0, 1, 0, 0, 1, 0, 0, 0),
        (1, 0, 1, 0, 0, 0, 1, 0, 0),
        (1, 0, 1, 0, 0, 0, 0, 1, 0),
        (1, 0, 0, 1, 0, 1, 0, 0, 0),
        (1, 0, 0, 1, 0, 0, 1, 0, 0),
        (1, 0, 0, 1, 0, 0, 0, 1, 0),
        (1, 0, 1, 0, 1, 0, 0, 0, 0),
        (1, 0, 0, 0, 1, 0, 0, 1, 0),
        (1, 0, 0, 0, 0, 1, 0, 1, 0),
        (1, 1, 0, 1, 0, 1, 0, 0, 0),
        (1, 1, 0, 1, 0, 0, 1, 0, 0),
        (1, 1, 0, 1, 0, 0, 0, 1, 0),
        (1, 1, 0, 0, 1, 0, 1, 0, 0),
        (1, 1, 0, 0, 1, 0, 0, 1, 0),
        (1, 1, 0, 0, 0, 1, 0, 1, 0),
        (1, 0, 1, 1, 0, 1, 0, 0, 0),
        (1, 0, 1, 1, 0, 0, 1, 0, 0),
        (1, 0, 1, 1, 0, 0, 0, 1, 0),
        (1, 0, 0, 1, 1, 0, 1, 0, 0),
        (1, 0, 0, 0, 1, 1, 0, 1, 0),
        (1, 0, 1, 0, 1, 1, 0, 0, 0),
        (1, 0, 1, 0, 0, 1, 1, 0, 0),
        (1, 0, 1, 0, 0, 0, 1, 1, 0),
        (1, 0, 0, 1, 0, 1, 1, 0, 0),
        (1, 0, 0, 0, 1, 0, 1, 1, 0),
        (1, 1, 0, 1, 1, 0, 1, 0, 0),
        (1, 1, 0, 1, 1, 0, 0, 1, 0),
        (1, 1, 0, 1, 0, 1, 1, 0, 0),
        (1, 1, 0, 1, 0, 0, 1, 1, 0),
        (1, 1, 0, 0, 1, 0, 1, 1, 0),
        (1, 1, 0, 0, 1, 1, 0, 1, 0),
        (1, 0, 1, 1, 0, 1, 1, 0, 0),
        (1, 0, 1, 1, 0, 0, 1, 1, 0),
        (1, 0, 0, 1, 1, 0, 1, 1, 0),
        (1, 0, 0, 1, 1, 1, 0, 1, 0),
        (1, 0, 0, 1, 0, 1, 1, 1, 0),
        (1, 1, 1, 0, 1, 0, 1, 0, 0),
        (1, 1, 1, 0, 1, 0, 0, 1, 0),
        (1, 1, 1, 0, 0, 1, 0, 1, 0),
        (1, 0, 1, 1, 0, 1, 1, 1, 0),
        (1, 0, 1, 1, 1, 0, 1, 1, 0),
        (1, 1, 0, 1, 0, 1, 1, 1, 0),
        (1, 0, 0, 1, 0, 0, 1, 1, 0),
        (1, 1, 1, 0, 1, 1, 0, 1, 0),
        (1, 1, 1, 0, 1, 0, 1, 1, 0),
        (1, 0, 0, 1, 1, 0, 0, 1, 0)
        );

  extendedCode93Replace : array [0..127] of String = (
        #$81'U', #$80'A', #$80'B', #$80'C', #$80'D', #$80'E', #$80'F', #$80'G', #$80'H',
        #$80'I', #$80'J', #$80'K', #$80'L', #$80'M', #$80'N', #$80'O', #$80'P', #$80'Q',
        #$80'R', #$80'S', #$80'T', #$80'U', #$80'V', #$80'W', #$80'X', #$80'Y', #$80'Z',
        #$81'A', #$81'B', #$81'C', #$81'D', #$81'E', ' ', #$82'A', #$82'B', #$82'C',
        #$82'D', #$82'E', #$82'F', #$82'G', #$82'H', #$82'I', #$82'J', #$82'K', #$82'L',
        '-', '.', #$82'O', '0', '1', '2', '3', '4', '5', '6', '7', '8', '9', #$82'Z',
        #$81'F', #$81'G', #$81'H', #$81'I', #$81'J', #$81'V', 'A', 'B', 'C', 'D', 'E',
        'F', 'G', 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T',
        'U', 'V', 'W', 'X', 'Y', 'Z', #$81'K', #$81'L', #$81'M', #$81'N', #$81'O', #$81'W',
        #$83'A', #$83'B', #$83'C', #$83'D', #$83'E', #$83'F', #$83'G', #$83'H', #$83'I',
        #$83'J', #$83'K', #$83'L', #$83'M', #$83'N', #$83'O', #$83'P', #$83'Q', #$83'R',
        #$83'S', #$83'T', #$83'U', #$83'V', #$83'W', #$83'X', #$83'Y', #$83'Z', #$81'P',
        #$81'Q', #$81'R', #$81'S', #$81'T'
        );


  start_stop : array [0..8] of Byte = (
        1, 0, 1, 0, 1, 1, 1, 1, 0
        );

  termination_bar : array [0..0] of Byte = (
        1
        );


implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
var
        converted : String;
begin

        converted := Convert(Kod.Text);

        if Check(converted) = False then
            begin
                ShowMessage('Incorrect text');
                exit;
            end;

        DrawBars(Kod.Text, converted);
end;

function TForm1.Convert(txt: String): String;
var
        i, code: Integer;
        res: String;
        incorrect: Char;
begin
        res := '';
        incorrect := Char($84);

        for i:=1 to Length(txt) do
                begin
                code := Ord(txt[i]);
                if ((code >= 0) and (code <= 127)) then
                        res := res + extendedCode93Replace[code]
                else
                        res := res + incorrect;
                end;

        Result := res;
end;

function TForm1.Check(txt: String): Boolean;
var
        i: Integer;
        res: Boolean;
begin
        res := True;

        for i:=1 to Length(txt) do
                if (CheckLetter(txt[i])) = False then
                        begin
                                res := False;
                                break;
                        end;

        Result := res;
end;

function TForm1.CheckLetter(ch: Char): Boolean;
var
        i: Integer;
        res: Boolean;
begin
        res := False;

        for i:=0 to 46 do
                if code93sign[i] = ch then
                        begin
                                res := True;
                                break;
                        end;

        Result := res;
end;

// returns letter value for check digit
function TForm1.GetLetterValue(ch: Char) : Integer;
var
        i: Integer;
begin
        Result := 0;

        for i:=0 to 46 do
                if (code93sign[i] = ch) then
                        begin
                                Result := i;
                                break;
                        end;
end;

// return check digit C
function TForm1.CheckDigitC(txt: String): Integer;
var
        i, sum, w : Integer;
begin
        sum := 0;
        w := 0;

        for i:=length(txt) downto 1 do
        begin
                sum := sum + (getLetterValue(txt[i]) * ((w mod 20) + 1));
                w := w+ 1;
        end;

        Result := (sum mod 47);

end;

// return check digit K
function TForm1.CheckDigitK(txt: String; checkDigitC: Byte): Integer;
var
        i, sum, w : Integer;
begin
        sum := checkDigitC;
        w := 1;

        for i:=length(txt) downto 1 do
        begin
                sum := sum + (getLetterValue(txt[i]) * ((w mod 15) + 1));
                w := w+ 1;
        end;

        Result := (sum mod 47);

end;

procedure TForm1.DrawBars(txt: String; converted: String);
var
        i, j, c, k : Integer;
begin
        c := checkDigitC(converted);
        k := checkDigitK(converted, c);

        curentPos := 0;
        Image1.Canvas.Brush.Color := clWhite;
        Image1.Canvas.Rectangle(0, 0, 441, 121);

        //print start character
        DrawSignBars(start_stop);

        //print characters
        for i:=1 to Length(converted) do
                for j:=0 to 46 do
                        if code93sign[j] = converted[i] then
                                begin
                                        DrawSignBars(code93bars[j]);
                                        break;
                                end;

        //print check digit C
        drawSignBars(code93bars[c]);
        
        //print check digit K
        drawSignBars(code93bars[k]);        

        //print stop character
        drawSignBars(start_stop);

        //print termination bar
        drawSignBars(termination_bar);

        //Draw text
        Image1.Canvas.Font.Size := 10;
        Image1.Canvas.Brush.Color := clWhite;
        Image1.Canvas.Font.Color := clBlack;
        Image1.Canvas.TextOut(curentPos div 2 + 20 - Length(txt)*3, 100, txt);
end;

procedure TForm1.DrawSignBars(bars: array of Byte);
var
        i : Integer;
begin
        Image1.Canvas.Brush.Color := clBlack;

        //print bars
        for i:=0 to high(bars) do
                begin
                        if (bars[i] = 1) then
                                Image1.Canvas.Rectangle(curentPos + 20, 10, curentPos + 22, 100);

                        curentPos := curentPos + 2;
                end;
end;

end.