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.