二维条码 控件(200)

要用delphi 打印二维条码求Delphi下打印二维条码在的控件 或者 相关资料

unit Barcode;interfaceuses WinProcs, WinTypes, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;type TBarLineType = (white, black, black_half);
TBarcode = class(TComponent) private { Private-Deklarationen } FHeight : integer;
FText : string;
FTop : integer;
FLeft : integer;
FModul : integer;
FRatio :do
uble;
FCheckSum:boolean;
FShowText:boolean;
FAngle :do
uble;
FColor : TColor;
FColorBar:TColor;
modules:array[0..3] of shortint;
procedure OneBarProps(code:char;
var Width:integer;
var lt:TBarLineType);
proceduredo
Lines(data:string;
Canvas:TCanvas);
function Code_39:string;
procedure MakeModules;
procedure SetModul(v:integer);
function GetWidth : integer;
protected function MakeData : string;
public constructor Create(Owner:TComponent);
override;
procedure DrawBarcode(Canvas:TCanvas);
procedure DrawText(Canvas:TCanvas);
published property Height : integer read FHeight write FHeight;
property Text : string read FText write FText;
property Top : integer read FTop write FTop;
property Left : integer read FLeft write FLeft;
{ Width of the smallest line in a Barcode } property Modul : integer read FModul write SetModul;
property Ratio :do
uble read FRatio write FRatio;
{ build CheckSum ? } property Checksum:boolean read FCheckSum write FCheckSum default FALSE;
{ 0 - 360 degree } property Angle :double read FAngle write FAngle;
property ShowText:boolean read FShowText write FShowText default FALSE;
property Width : integer read GetWidth;
property Color:TColor read FColor write FColor default clWhite;
property ColorBar:TColor read FColorBar write FColorBar default clBlack;
end;
procedure Register;implementation{$ifdef WIN32} {$R barcode.d32}{$else
} {$R barcode.d16}{$endif}type TBCdata = record Name:string;
{ Name of Barcode } num :Boolean;
{ numeric data only } end;
const BCdata: TBCdata = (Name:'Code39';
num:False);{$ifndef WIN32}function Trim(const S: string): string;
export;var I, L: Integer;
begin
L := Length(S);
I := 1;
while (I <= L) and (S <= ' ')do
Inc(I);
if I > L then
Result := '' else
begin
while S[L] <= ' 'do
Dec(L); Result := Copy(S, I, L - I + 1);
end;
end;
{$endif}function Rotate2D(p:TPoint;
alpha:double): TPoint;var sinus, cosinus : Extended;
begin
sinus := sin(alpha); cosinus := cos(alpha); result.x := Round(p.x*cosinus + p.y*sinus); result.y := Round(-p.x*sinus + p.y*cosinus);
end;
function Translate2D(a, b:TPoint): TPoint;
begin
result.x := a.x + b.x; result.y := a.y + b.y;
end;
constructor TBarcode.Create(Owner:TComponent);
begin
inherited Create(owner);
FAngle := 0.0;
FTop := 2;
FHeight := 85;
FLeft := 2;
FRatio := 2.6;
FModul := 1;
FModul := 5;
FCheckSum := True;
FShowText := True;
FColor := clWhite;
FColorBar := clBlack;
end;
{ set Modul Width }procedure TBarcode.SetModul(v:integer);
begin
if (v >= 1) and (v < 50) then
FModul := v;
end;
{calculate the width and the linetype of a sigle bar Code Line-Color Width Height------------------------------------------------------------------ '0' white 100% full '1' white 100%*Ratio full '2' white 150%*Ratio full '3' white 200%*Ratio full '5' black 100% full '6' black 100%*Ratio full '7' black 150%*Ratio full '8' black 200%*Ratio full 'A' black 100% 2/5 (used for PostNet) 'B' black 100%*Ratio 2/5 (used for PostNet) 'C' black 150%*Ratio 2/5 (used for PostNet) 'D' black 200%*Ratio 2/5 (used for PostNet)}procedure TBarcode.OneBarProps(code:char;
var Width:integer;
var lt:TBarLineType);
begin
case code of '0': begin
width := modules[0];
lt := white;
end;
'1': begin
width := modules[1];
lt := white;
end;
'2': begin
width := modules[2];
lt := white;
end;
'3': begin
width := modules[3];
lt := white;
end;
'5': begin
width := modules[0];
lt := black;
end;
'6': begin
width := modules[1];
lt := black;
end;
'7': begin
width := modules[2];
lt := black;
end;
'8': begin
width := modules[3];
lt := black;
end;
'A': begin
width := modules[0];
lt := black_half;
end;
'B': begin
width := modules[1];
lt := black_half;
end;
'C': begin
width := modules[2];
lt := black_half;
end;
'D': begin
width := modules[3];
lt := black_half;
end;
else
begin
{something went wrong :-(} {mistyped pattern table} raise Exception.CreateFmt('%s: internal Error', [self.ClassName]); end;
end;
end;
function TBarcode.MakeData : string;
begin
MakeModules;
Result := Code_39;
end;
function TBarcode.GetWidth:integer;var data : string;
i : integer;
w : integer;
lt : TBarLineType;
begin
Result := 0;
{get barcode pattern} data := MakeData;
for i:=1 to Length(data)do
{examine the pattern string} begin
OneBarProps(data, w, lt);
Inc(Result, w);
end;
end;
type TCode39 = record c : char;
data : array[0..9] of char;
chk: shortint;
end;
const tabelle_39: array[0..43] of TCode39 = ( ( c:'0';
data:'505160605';
chk:0 ), ( c:'1';
data:'605150506';
chk:1 ), ( c:'2';
data:'506150506';
chk:2 ), ( c:'3';
data:'606150505';
chk:3 ), ( c:'4';
data:'505160506';
chk:4 ), ( c:'5';
data:'605160505';
chk:5 ), ( c:'6';
data:'506160505';
chk:6 ), ( c:'7';
data:'505150606';
chk:7 ), ( c:'8';
data:'605150605';
chk:8 ), ( c:'9';
data:'506150605';
chk:9 ), ( c:'A';
data:'605051506';
chk:10), ( c:'B';
data:'506051506';
chk:11), ( c:'C';
data:'606051505';
chk:12), ( c:'D';
data:'505061506';
chk:13), ( c:'E';
data:'605061505';
chk:14), ( c:'F';
data:'506061505';
chk:15), ( c:'G';
data:'505051606';
chk:16), ( c:'H';
data:'605051605';
chk:17), ( c:'I';
data:'506051605';
chk:18), ( c:'J';
data:'505061605';
chk:19), ( c:'K';
data:'605050516';
chk:20), ( c:'L';
data:'506050516';
chk:21), ( c:'M';
data:'606050515';
chk:22), ( c:'N';
data:'505060516';
chk:23), ( c:'O';
data:'605060515';
chk:24), ( c:'P';
data:'506060515';
chk:25), ( c:'Q';
data:'505050616';
chk:26), ( c:'R';
data:'605050615';
chk:27), ( c:'S';
data:'506050615';
chk:28), ( c:'T';
data:'505060615';
chk:29), ( c:'U';
data:'615050506';
chk:30), ( c:'V';
data:'516050506';
chk:31), ( c:'W';
data:'616050505';
chk:32), ( c:'X';
data:'515060506';
chk:33), ( c:'Y';
data:'615060505';
chk:34), ( c:'Z';
data:'516060505';
chk:35), ( c:'-';
data:'515050606';
chk:36), ( c:'.';
data:'615050605';
chk:37), ( c:' ';
data:'516050605';
chk:38), ( c:'*';
data:'515060605';
chk:0 ), ( c:'$';
data:'515151505';
chk:39), ( c:'/';
data:'515150515';
chk:40), ( c:'+';
data:'515051515';
chk:41), ( c:'%';
data:'505151515';
chk:42) );function TBarcode.Code_39:string;
function FindIdx(z:char):integer;
var i:integer;
begin
result := -1;
for i:=0 to High(tabelle_39)do
begin
if z = tabelle_39.c then
begin
result := i;
Break;
end;
end;
end;
var i, idx : integer;
checksum:integer;
begin
checksum := 0;
{Startcode: 5150606050 } result := tabelle_39[FindIdx('*')].data + '0';
for i:=1 to Length(FText)do
begin
idx := FindIdx(FText);
if idx < 0 then
continue;
result := result + tabelle_39[idx].data + '0';
Inc(checksum, tabelle_39[idx].chk);
end;
{Calculate Checksum Data} if FCheckSum then
begin
checksum := checksum mod 43;
for i:=0 to High(tabelle_39)do
if checksum = tabelle_39.chk then
begin
result := result + tabelle_39.data + '0';
exit;
end;
end;
{Stopcode} result := result + tabelle_39[FindIdx('*')].data;
end;
procedure TBarcode.MakeModules;
begin
if Ratio < 2.0 then
Ratio := 2.0;
if Ratio > 3.0 then
Ratio := 3.0;
modules[0] := FModul;
modules[1] := Round(FModul*FRatio);
modules[2] := modules[1] * 3 div 2;
modules[3] := modules[1] * 2;
end;
{Draw the BarcodeParameter :'data' holds the pattern for a Barcode.A barcode begin
s always with a black line andends with a black line.The white Lines builds the space between the black Lines.A black line must always followed by a white Line and vica versa.Examples: '50505' // 3 thin black Lines with 2 thin white Lines '606' // 2 fat black Lines with 1 thin white Line '5605015' // Errordata[] : see procedure OneBarProps}procedure TBarcode.DoLines(data:string;
Canvas:TCanvas);var i:integer;
lt : TBarLineType;
xadd:integer;
width, height:integer;
a,b,c,d, {Edges of a line (we need 4 Point because the line} {is a recangle} orgin : TPoint;
alpha:double;
begin
xadd := 0;
orgin.x := FLeft;
orgin.y := FTop;
alpha := FAngle*pi / 180.0;
with Canvasdo
begin
Pen.Width := 1;
for i:=1 to Length(data)do
{examine the pattern string} begin
{input: pattern code output: Width and Linetype} OneBarProps(data, width, lt);
if (lt = black) or (lt = black_half) then
Pen.Color := FColorBar else
Pen.Color := FColor;
Brush.Color := Pen.Color;
if lt = black_half then
height := FHeight * 2 div 5 else
height := FHeight;
a.x := xadd;
a.y := 0;
b.x := xadd;
b.y := height;
{c.x := xadd+width;} c.x := xadd+Width-1;
{23.04.1999 Line was 1 Pixel too wide} c.y := Height;
{d.x := xadd+width;} d.x := xadd+Width-1;
{23.04.1999 Line was 1 Pixel too wide} d.y := 0;
{a,b,c,d builds the rectangle we want to draw} {rotate the rectangle} a := Translate2D(Rotate2D(a, alpha), orgin);
b := Translate2D(Rotate2D(b, alpha), orgin);
c := Translate2D(Rotate2D(c, alpha), orgin);
d := Translate2D(Rotate2D(d, alpha), orgin);
{draw the rectangle} Polygon([a,b,c,d]);
xadd := xadd + width;
end;
end;
end;
procedure TBarcode.DrawBarcode(Canvas:TCanvas);var data : string;
SaveFont: TFont;
SavePen: TPen;
SaveBrush: TBrush;
begin
Savefont := TFont.Create;
SavePen := TPen.Create;
SaveBrush := TBrush.Create;
{get barcode pattern} data := MakeData;
try {store Canvas properties} Savefont.Assign(Canvas.Font);
SavePen.Assign(Canvas.Pen);
SaveBrush.Assign(Canvas.Brush);
do
Lines(data, Canvas);
{draw the barcode} if FShowText then
DrawText(Canvas);
{show readable Text} {restore old Canvas properties} Canvas.Font.Assign(savefont);
Canvas.Pen.Assign(SavePen);
Canvas.Brush.Assign(SaveBrush);
finally Savefont.Free;
SavePen.Free;
SaveBrush.Free;
end;
end;
procedure TBarcode.DrawText(Canvas:TCanvas);
begin
with Canvasdo
begin
Font.Size := 4;
Pen.Color := clBlack;
Brush.Color := clWhite;
TextOut(FLeft, FTop, FText);
end;
end;
procedure Register;
begin
RegisterComponents('Extras', [TBarcode]);
end;
end.
使用：var BC: TBarCode;procedure TForm1.Edit1Change(Sender: TObject);
begin
Image1.Picture := nil;
BC.Text := Edit1.Text;
BC.DrawBarcode(Image1.Canvas);
end;
打印简单，直接把Image1打印出来即可。

TBarCode http://www.tec-it.com/zh-cn/start/Default.aspx不過要花錢買