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; 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.