在图书管理系统中，碰到许多重复条码、没有条码的情形，所以为了自己快速制作打印出二维条码（CODE39），所以编写了这个自定义条码制作打印工具。。。
工程文件
program pCodeMaker; uses Forms, uCodeMaker in \'uCodeMaker.pas\' {frmCode39}, BuildCode in \'BuildCode.pas\'; {$R *.res} begin Application.Initialize; Application.MainFormOnTaskbar := True; Application.CreateForm(TfrmCode39, frmCode39); Application.Run; end.
主单元文件
unit uCodeMaker; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls, StdCtrls, ComCtrls, frxClass; type TfrmCode39 = class(TForm) edtBegin: TEdit; btnMake: TButton; edtEnd: TEdit; UpDown2: TUpDown; Label1: TLabel; Label2: TLabel; btnPrint: TButton; Image1: TImage; Label3: TLabel; Memo1: TMemo; procedure btnMakeClick(Sender: TObject); procedure btnPrintClick(Sender: TObject); procedure FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject); private { Private declarations } public { Public declarations } end; var frmCode39: TfrmCode39; Imgs: array of TImage; //Img: TImage; implementation {$R *.dfm} uses BuildCode, Printers; procedure TfrmCode39.btnMakeClick(Sender: TObject); var strCode, strHead, strTmp: string; xBegin, yBegin, k, j, step, ImgCounts: Integer; I, Len, Max: Cardinal; begin Memo1.Hide; //初始化 //Img.Hide; CodeEvaluate;//初始化二进制编码 step := 0; xBegin := 10; yBegin := 10; Max := StrtoIntDef(edtEnd.Text,1); ImgCounts := Max div 36; if (Max mod 36) > 0 then ImgCounts := ImgCounts + 1; SetLength(Imgs, ImgCounts); for I := 0 to Length(Imgs)-1 do begin if not assigned(Imgs[i]) then Imgs[i] := TImage.Create(nil); end; Len := Length(Trim(edtBegin.Text)); if Len > 9 then begin strTmp := Copy(Trim(edtBegin.Text),Len-8,9); strHead := Copy(Trim(edtBegin.Text),1,Len-9); end else begin strTmp := Trim(edtBegin.Text); strHead := \'\'; end; for I := 0 to Length(Imgs)-1 do begin Imgs[i].Width := 800; Imgs[i].Height := 1200; end; j := 1; for I := 1 to Max do begin k := (I- 1) div 36; strTmp := Inttostr(StrtoInt(strTmp)+step); while Length(strTmp) < 9 do begin strTmp := \'0\'+strTmp; end; strCode := Trim(strHead + strTmp); if I <= 3 then BuildCodes(strCode, 0, 0,xBegin,yBegin, 60, 2, 1, 12, Image1); BuildCodes(strCode, 0, 0,xBegin,yBegin, 60, 2, 1, 12, Imgs[k]); step := 1; yBegin := yBegin + 90; if ((I mod 12)=0) and (I<>0) then begin xBegin := xBegin + 250; yBegin := 10; inc(j); end; //如果超过3 列,则重新产生 if j>3 then begin j := 1; xBegin := 10; yBegin := 10; end; end; //for end; procedure TfrmCode39.btnPrintClick(Sender: TObject); var r: TRect; bit: TBitmap; xPrinter, yPrinter, x, y, rX,rY, i: integer; begin bit := TBitmap.Create; try for I := 0 to Length(Imgs)-1 do begin Imgs[I].Picture.Graphic.SaveToFile(ExtractFilePath(Application.ExeName)+\'tmp.bmp\'); bit.LoadFromFile(ExtractFilePath(Application.ExeName)+\'tmp.bmp\'); //计算显示器分辨率与打印机分辨率的比率 xPrinter := GetDeviceCaps(printer.Handle, LOGPIXELSX); yPrinter := GetDeviceCaps(printer.Handle, LOGPIXELSY); x := GetDeviceCaps(GetDC(Self.Handle), LOGPIXELSX); y := GetDeviceCaps(GetDC(Self.Handle), LOGPIXELSY); rX := xPrinter div x; rY := yPrinter div y; r := Rect(0,0,rX*Bit.Width,rY*Bit.Height); // 开始打印 with Printer do begin begindoc; Canvas.CopyMode := cmSrcCopy; Canvas.CopyRect(r,bit.Canvas,Rect(0,0,Bit.Width,Bit.Height)); enddoc; end; end;// for i finally if FileExists(ExtractFilePath(Application.ExeName)+\'tmp.bmp\') then DeleteFile(ExtractFilePath(Application.ExeName)+\'tmp.bmp\'); bit.Free; end; end; procedure TfrmCode39.FormCreate(Sender: TObject); begin //Img := TImage.Create(nil); end; procedure TfrmCode39.FormDestroy(Sender: TObject); var i: integer; begin // Img.Free; for I := 0 to Length(Imgs)-1 do begin Imgs[i].Free; end; end; end.
主单元窗体文件
object frmCode39: TfrmCode39 Left = 0 Top = 0 BorderIcons = [biSystemMenu, biMinimize] Caption = #26465#24418#30721#21046#20316#25171#21360 ClientHeight = 286 ClientWidth = 440 Color = clBtnFace Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText Font.Height = -11 Font.Name = \'Tahoma\' Font.Style = [] OldCreateOrder = False Position = poDesktopCenter OnCreate = FormCreate OnDestroy = FormDestroy PixelsPerInch = 96 TextHeight = 13 object Label1: TLabel Left = 8 Top = 62 Width = 60 Height = 13 Caption = #36215#22987#32534#30721#65306 Color = clGreen ParentColor = False end object Label2: TLabel Left = 8 Top = 109 Width = 72 Height = 13 Caption = #36830#32493#29983#25104#25968#37327 Color = clGreen ParentColor = False end object Image1: TImage Left = 208 Top = 8 Width = 225 Height = 270 end object Label3: TLabel Left = 16 Top = 16 Width = 172 Height = 13 Caption = #26412#31243#24207#20165#36866#29992#20110#21046#20316\'CODE39\'#26465#30721 Color = clMoneyGreen ParentColor = False end object edtBegin: TEdit Left = 65 Top = 59 Width = 121 Height = 21 ImeName = #20013#25991\' (\'#31616#20307\') - \'#25628#29399#25340#38899#36755#20837#27861 NumbersOnly = True TabOrder = 0 Text = \'9787000000001\' end object btnMake: TButton Left = 8 Top = 160 Width = 75 Height = 25 Caption = #29983#25104#26465#24418#30721 TabOrder = 1 OnClick = btnMakeClick end object edtEnd: TEdit Left = 86 Top = 106 Width = 60 Height = 21 ImeName = #20013#25991\' (\'#31616#20307\') - \'#25628#29399#25340#38899#36755#20837#27861 NumbersOnly = True TabOrder = 2 Text = \'1\' end object UpDown2: TUpDown Left = 146 Top = 106 Width = 16 Height = 21 Associate = edtEnd Min = 1 Position = 1 TabOrder = 3 end object btnPrint: TButton Left = 111 Top = 160 Width = 75 Height = 25 Caption = #25171#21360 TabOrder = 4 OnClick = btnPrintClick end object Memo1: TMemo Left = 208 Top = 8 Width = 224 Height = 265 Font.Charset = DEFAULT_CHARSET Font.Color = clMedGray Font.Height = -27 Font.Name = \'Tahoma\' Font.Style = [] ImeName = #20013#25991\' (\'#31616#20307\') - \'#19975#33021#20116#31508#20869#32622#36755#20837#27861 Lines.Strings = ( \'\' \' \'#25928 \' \' \' \'#26524 \'\' \' \'#22270) ParentFont = False TabOrder = 5 end end
二维码制作单元文件
{****************************************************************** ** 文件名: BuildCode.pas ** 版 本: 1.0 ** 创建人: zhjun ** 日 期: 2004.12.29 ** 描 述: Code 39 条码输出模块 **----------------------------------------------------------------- ** 修改人: boltwolf ** 日 期: 2012.01.05 ** 描 述: 添加了code39码的头识别，否则扫描仪无法识别 **----------------------------------------------------------------- ******************************************************************} unit BuildCode; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls; function BuildCodes(CodeStr:string;CodeType:integer;Corner:integer;xPos,yPos: integer; CHeight:integer;CWidth:integer;CWidthShort:integer; CTextOutSize:integer; var CodeCanvas:Timage):integer; procedure CodeEvaluate; function CheckParameter(CodeStr:string;CodeType:integer;Corner:integer;xPos,yPos: integer; CHeight:integer;CWidth:integer;CWidthShort:integer;CTextOutSize:integer; var CodeCanvas:Timage):boolean; function ClearCanvas(var CodeCanvas:Timage):boolean; function TypeCode39(CodeStr:string;Corner:integer;xPos,yPos: integer;CHeight,CWidth,CWidthShort:integer; CTextOutSize:integer; var CodeCanvas:Timage):integer; implementation var CodeValue :array[0..43] of string; CodeValueA:array[0..43] of string; CodeOrder:string=\'0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-. *$/+%\'; place_X1,place_X2,place_Y1,place_Y2:integer; //条码输出位置 TextPlace_X,TextPlace_Y:integer;//字符输出位置 CordWord_Place:integer; //编码位置编号 CordWord:string; //单个字符 i,j:integer; //循环参数 Code,CodeA:string; CodeStr:string; function BuildCodes(CodeStr:string;CodeType:integer;Corner:integer;xPos,yPos: integer; CHeight,CWidth,CWidthShort:integer;CTextOutSize:integer;var CodeCanvas:Timage):integer; begin if not CheckParameter(CodeStr,CodeType,Corner,xPos,yPos,CHeight,CWidth,CWidthShort,CTextOutSize,CodeCanvas) then exit; // CodeEvaluate;//初始化二进制编码 // ClearCanvas(CodeCanvas); //清除画布 Case CodeType of 0: TypeCode39(CodeStr,Corner,xPos,yPos,CHeight,CWidth,CWidthShort,CTextOutSize,CodeCanvas); end; end; function ClearCanvas(var CodeCanvas:Timage):boolean; var ClientRect:TRect; begin ClientRect.Left:=0; ClientRect.Top:=0; ClientRect.Right:=CodeCanvas.Width; ClientRect.Bottom:=CodeCanvas.Height; with CodeCanvas.Canvas do begin Brush.Style:=bssolid; Brush.Color:=ClWhite; FillRect(ClientRect); end; result:=true; end; //创建 function TypeCode39(CodeStr:string;Corner:integer;xPos,yPos: integer;CHeight,CWidth,CWidthShort:integer; CTextOutSize:integer;var CodeCanvas:Timage):integer; begin place_X1:=xPos; place_Y1:=yPos; TextPlace_X:=Place_X1+Cwidth; TextPlace_Y:=CHeight+yPos; Codecanvas.Canvas.Pen.Color:=clblack; //画起始码* for j := 1 to 5 do begin //画黑线 Codecanvas.Canvas.Pen.Mode:=pmBlack; Codecanvas.Canvas.Pen.Width := 1; Code:=copy(CodeValue[39],j,1); CodeA:=copy(CodeValueA[39],j,1); if Code=\'1\' then begin Codecanvas.Canvas.Pen.Color:=clblack; Place_X2:=Place_X1+CWidth; Codecanvas.Canvas.Rectangle(Place_X1,Place_Y1,Place_X2,CHeight+Place_Y1); Place_X1:=Place_X1+CWidth; end; if Code=\'0\' then begin Codecanvas.Canvas.Pen.Color:=clblack; Place_X2:=Place_X1+CWidthShort; Codecanvas.Canvas.Rectangle(Place_X1,Place_Y1,Place_X2,CHeight+Place_Y1); Place_X1:=Place_X1+CWidthShort; end; //画白线 Codecanvas.Canvas.Pen.Mode:=pmWhite; Codecanvas.Canvas.Pen.Width := 1; if CodeA=\'1\' then begin Codecanvas.Canvas.Pen.Color:=clwhite; Place_X2:=Place_X1+CWidth; Codecanvas.Canvas.Rectangle(Place_X1,Place_Y1,Place_X2,CHeight+Place_Y1); Place_X1:=Place_X1+CWidth; end; if CodeA=\'0\' then begin Codecanvas.Canvas.Pen.Color:=clwhite; Place_X2:=Place_X1+CWidthShort; Codecanvas.Canvas.Rectangle(Place_X1,Place_Y1,Place_X2,CHeight+Place_Y1); Place_X1:=Place_X1+CWidthShort; end; end;//for j //开始循环 for i := 1 to length(CodeStr) do begin Place_X1:=Place_X1+CWidthShort; //按顺序取单个字符 CordWord:=copy(CodeStr,i,1); //获取字符的位置编号 CordWord_Place:=Pos(CordWord,CodeOrder)-1; //按二进制编码顺序输出条码 for j:= 1 to 5 do begin //画黑线 Codecanvas.Canvas.Pen.Mode:=pmBlack; Codecanvas.Canvas.Pen.Width := 1; Code:=copy(CodeValue[CordWord_Place],j,1); CodeA:=copy(CodeValueA[CordWord_Place],j,1); if Code=\'1\' then begin Codecanvas.Canvas.Pen.Color:=clblack; Place_X2:=Place_X1+CWidth; Codecanvas.Canvas.Rectangle(Place_X1,Place_Y1,Place_X2,CHeight+Place_Y1); Place_X1:=Place_X1+CWidth; end; if Code=\'0\' then begin Codecanvas.Canvas.Pen.Color:=clblack; Place_X2:=Place_X1+CWidthShort; Codecanvas.Canvas.Rectangle(Place_X1,Place_Y1,Place_X2,CHeight+Place_Y1); Place_X1:=Place_X1+CWidthShort; end; //画白线 Codecanvas.Canvas.Pen.Mode:=pmWhite; Codecanvas.Canvas.Pen.Width := 1; if CodeA=\'1\' then begin Codecanvas.Canvas.Pen.Color:=clwhite; Place_X2:=Place_X1+CWidth; Codecanvas.Canvas.Rectangle(Place_X1,Place_Y1,Place_X2,CHeight+Place_Y1); Place_X1:=Place_X1+CWidth; end; if CodeA=\'0\' then begin Codecanvas.Canvas.Pen.Color:=clwhite; Place_X2:=Place_X1+CWidthShort; Codecanvas.Canvas.Rectangle(Place_X1,Place_Y1,Place_X2,CHeight+Place_Y1); Place_X1:=Place_X1+CWidthShort; end; end; //for j end; //for i //画终止* Place_X1:=Place_X1+CWidthShort; for j := 1 to 5 do begin //画黑线 Codecanvas.Canvas.Pen.Mode:=pmBlack; Codecanvas.Canvas.Pen.Width := 1; Code:=copy(CodeValue[39],j,1); CodeA:=copy(CodeValueA[39],j,1); if Code=\'1\' then begin Codecanvas.Canvas.Pen.Color:=clblack; Place_X2:=Place_X1+CWidth; Codecanvas.Canvas.Rectangle(Place_X1,Place_Y1,Place_X2,CHeight+Place_Y1); Place_X1:=Place_X1+CWidth; end; if Code=\'0\' then begin Codecanvas.Canvas.Pen.Color:=clblack; Place_X2:=Place_X1+CWidthShort; Codecanvas.Canvas.Rectangle(Place_X1,Place_Y1,Place_X2,CHeight+Place_Y1); Place_X1:=Place_X1+CWidthShort; end; //画白线 Codecanvas.Canvas.Pen.Mode:=pmWhite; Codecanvas.Canvas.Pen.Width := 1; if CodeA=\'1\' then begin Codecanvas.Canvas.Pen.Color:=clwhite; Place_X2:=Place_X1+CWidth; Codecanvas.Canvas.Rectangle(Place_X1,Place_Y1,Place_X2,CHeight+Place_Y1); Place_X1:=Place_X1+CWidth; end; if CodeA=\'0\' then begin Codecanvas.Canvas.Pen.Color:=clwhite; Place_X2:=Place_X1+CWidthShort; Codecanvas.Canvas.Rectangle(Place_X1,Place_Y1,Place_X2,CHeight+Place_Y1); Place_X1:=Place_X1+CWidthShort; end; end;//for j Codecanvas.Canvas.TextWidth(\'ddddd\'); Codecanvas.Canvas.Font.Name:=\'宋体\'; Codecanvas.Canvas.Font.Size:=CTextOutSize; Codecanvas.Canvas.TextOut(TextPlace_X,TextPlace_Y,Codestr); end; function CheckParameter(CodeStr:string;CodeType:integer;Corner:integer;xPos,yPos: integer; CHeight:integer;CWidth:integer;CWidthShort:integer; CTextOutSize:integer; var CodeCanvas:Timage):boolean; begin result:=True; if COdeType<0 then begin Application.MessageBox(\'缺少参数！\'+#13+\'请求传递条码类型！\', \'系统提示\',mb_OK or MB_ICONINFORMATION); result:=False; Exit; end; if CodeStr=\'\' then begin Application.MessageBox(\'缺少参数！\'+#13+\'请求传递条码字符！\', \'系统提示\',mb_OK or MB_ICONINFORMATION); result:=False; Exit; end; if Corner<0 then Corner:=0; if xPos<0 then xPos := 20; if yPos < 0 then yPos := 20; if CHeight<0 then CHeight:=100; if CWidth<0 then CWidth:=6; if CWidthShort<0 then CWidthShort:=2; if CTextOutSize<0 then CTextOutSize:=9; end; procedure CodeEvaluate; begin CodeValue[0] :=\'00110\'; // 0 CodeValue[1] :=\'10001\'; // 1 CodeValue[2] :=\'01001\'; // 2 CodeValue[3] :=\'11000\'; // 3 CodeValue[4] :=\'00101\'; // 4 CodeValue[5] :=\'10100\'; // 5 CodeValue[6] :=\'01100\'; // 6 CodeValue[7] :=\'00011\'; // 7 CodeValue[8] :=\'10010\'; // 8 CodeValue[9] :=\'01010\'; // 9 CodeValue[10]:=\'10001\'; // A CodeValue[11]:=\'01001\'; // B CodeValue[12]:=\'11000\'; // C CodeValue[13]:=\'00101\'; // D CodeValue[14]:=\'10100\'; // E CodeValue[15]:=\'01100\'; // F CodeValue[16]:=\'00011\'; // G CodeValue[17]:=\'10010\'; // H CodeValue[18]:=\'01010\'; // I CodeValue[19]:=\'00110\'; // J CodeValue[20]:=\'10001\'; // K CodeValue[21]:=\'01001\'; // L CodeValue[22]:=\'11000\'; // M CodeValue[23]:=\'00101\'; // N CodeValue[24]:=\'10100\'; // O CodeValue[25]:=\'01100\'; // P CodeValue[26]:=\'00011\'; // Q CodeValue[27]:=\'10010\'; // R CodeValue[28]:=\'01010\'; // S CodeValue[29]:=\'00110\'; // T CodeValue[30]:=\'10001\'; // U CodeValue[31]:=\'01001\'; // V CodeValue[32]:=\'11000\'; // W CodeValue[33]:=\'00101\'; // X CodeValue[34]:=\'10100\'; // Y CodeValue[35]:=\'01100\'; // Z CodeValue[36]:=\'00011\'; // - CodeValue[37]:=\'10010\'; // . CodeValue[38]:=\'01010\'; // 空格 CodeValue[39]:=\'00110\'; // * CodeValue[40]:=\'00000\'; // $ CodeValue[41]:=\'00000\'; // / CodeValue[42]:=\'00000\'; // + CodeValue[43]:=\'00000\'; // % CodeValueA[0] :=\'0100\'; // 0 CodeValueA[1] :=\'0100\'; // 1 CodeValueA[2] :=\'0100\'; // 2 CodeValueA[3] :=\'0100\'; // 3 CodeValueA[4] :=\'0100\'; // 4 CodeValueA[5] :=\'0100\'; // 5 CodeValueA[6] :=\'0100\'; // 6 CodeValueA[7] :=\'0100\'; // 7 CodeValueA[8] :=\'0100\'; // 8 CodeValueA[9] :=\'0100\'; // 9 CodeValueA[10]:=\'0010\'; // A CodeValueA[11]:=\'0010\'; // B CodeValueA[12]:=\'0010\'; // C CodeValueA[13]:=\'0010\'; // D CodeValueA[14]:=\'0010\'; // E CodeValueA[15]:=\'0010\'; // F CodeValueA[16]:=\'0010\'; // G CodeValueA[17]:=\'0010\'; // H CodeValueA[18]:=\'0010\'; // I CodeValueA[19]:=\'0010\'; // J CodeValueA[20]:=\'0001\'; // K CodeValueA[21]:=\'0001\'; // L CodeValueA[22]:=\'0001\'; // M CodeValueA[23]:=\'0001\'; // N CodeValueA[24]:=\'0001\'; // O CodeValueA[25]:=\'0001\'; // P CodeValueA[26]:=\'0001\'; // Q CodeValueA[27]:=\'0001\'; // R CodeValueA[28]:=\'0001\'; // S CodeValueA[29]:=\'0001\'; // T CodeValueA[30]:=\'1000\'; // U CodeValueA[31]:=\'1000\'; // V CodeValueA[32]:=\'1000\'; // W CodeValueA[33]:=\'1000\'; // X CodeValueA[34]:=\'1000\'; // Y CodeValueA[35]:=\'1000\'; // Z CodeValueA[36]:=\'1000\'; // - CodeValueA[37]:=\'1000\'; // . CodeValueA[38]:=\'1000\'; // 空格 CodeValueA[39]:=\'1000\'; // * CodeValueA[40]:=\'1110\'; // $ CodeValueA[41]:=\'1101\'; // / CodeValueA[42]:=\'1011\'; // + CodeValueA[43]:=\'0111\'; // % end; end.