Nadesłany przez Tomasz Lubiński, 20 września 2006 01:00
Kod przedstawiony poniżej przedstawia główną część rozwiązania problemu.Pobierz pełne rozwiązanie.
Jeżeli nie odpowiada Ci sposób formatowania kodu przez autora skorzystaj z pretty printer'a i dostosuj go automatycznie do siebie.
Kody Kreskowe - Delphi/Unit1.pas:
//---------------------------------------------------------------------------
// 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);
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;
{ 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', '-', '.', ' ', '$',
'/', '+', '%', Char(127 + 1), Char(127 + 2), Char(127 + 3), Char(127 + 4));
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)
);
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);
begin
if Check(Kod.Text) = False then
begin
ShowMessage('Incorrect text');
exit;
end;
DrawBars(Kod.Text);
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 42 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);
var
i, j, c, k : Integer;
begin
c := checkDigitC(txt);
k := checkDigitK(txt, 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(txt) do
for j:=0 to 46 do
if code93sign[j] = txt[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.