uhsbarcodeimage.pas

一个完全免费的条码打印控件

                {*******************************************}
                {         HSPackage V1.0 自定义组件包       }
                {            HSBarCodeImage v1.1            }
                {              小点工作室编写               }
                {                                           }
                { Copyright (c) 1998-2002 by onedot         }
                {       E-Mail:[e-mail]              }
                {*******************************************}
//*********************************************************************************/
//1.本控件完全免费并且代码开放                                                     /
//2.算法参考FR有关条形码算法                                                       /
//3.完全所见即所得；支持DB和非DB操作；从TImage继承方便显示位置、区域控制 ；        /
//  支持在QReport和其他任何可接收可视化控件得报表中使用                            /
//  以基本VCL为基础不需要任何额外文件；安装方便                                    /
//4.主要属性及方法如下                                                             /
//Barcode:如果非DB显示时为指定需要显示的条形码字符串                               /
//BarCodeType:需要显示的条形码规格                                                 /
//BarCodeWidth:条形码的宽度（标准为16，普通为32，会自动扩大，但会有极限）          /
//BarcodeHeight：条形码区的高度                                                    /
//BarcodeAngle：条形码的旋转                                                       /
//BarLabel:条形码的显示注释（注释部分为该值自动加上BarCode的值显示）               /
//BarShowLabel:是否显示条形码的注释                                                /
//DataSource,DataField:同其他DB控件，指定后将显示对应数据的值，BarCode则失效       /
//5.主要方法                                                                       /
//ShowBarCode:显示当前得条形码图形                                                 /
//Print:打印当前条形码图形                                                         /
//*********************************************************************************/
//v1.0支持条形码规格清单：
//  bcCode_2_5_interleaved, bcCode_2_5_industrial,
//  bcCode_2_5_matrix,bcCode39,bcCode39Extended,bcCode128A,bcCode128B,
//  bcCode128C,bcCode93,bcCode93Extended,bcCodeMSI,bcCodePostNet,
//  bcCodeCodabar,bcCodeEAN8,bcCodeEAN13,bcCodeUPC_A,bcCodeUPC_E0,
//  bcCodeUPC_E1,bcCodeUPC_Supp2{ UPC 2 digit supplemental },
//  bcCodeUPC_Supp5{ UPC 5 digit supplemental } bcCodeEAN128A,bcCodeEAN128B,
//  bcCodeEAN128C
//
//*********************************************************************************/
//v1.1更新记录
//应网友要求，对最常用的EAN13做了修改，使其完全符合EAN13要求
//BarLabel默认值为空，如果为空不显示冒号
//增加了BARCODEANGLE属性，即旋转角度的显示,但不是和FR的旋转一个原理，因时间紧张没太多求更好算法
//HSBARCODE本身还有一些属性在HSBARCODEIMAGE中未提供设置和访问，但都不是常用的，故省
//
//*********************************************************************************/
//附加说明：
//熬了个晚上，我没有精力再为该控件做更多工作，希望有人可以将它改成也可以加入到FastReport中
//为不和FR本身冲突，我的命名都已经不同了，因此不用担心会有冲突
//*********************************************************************************/
//版权声明：本代码完全公开，你可以对其任意修改、发布。本人对该代码不保证负责永久维护
//
//*********************************************************************************/

unit uHSBarCodeImage;

interface

uses
  WinProcs, ExtCtrls,WinTypes,DBCtrls,Messages,DB,Math,
  SysUtils,StdCtrls,Classes, Graphics, Controls, Forms, Dialogs,Printers;

type
  THSBarcodeType =
  (bcCode_2_5_interleaved,
  bcCode_2_5_industrial,
  bcCode_2_5_matrix,
  bcCode39,
  bcCode39Extended,
  bcCode128A,
  bcCode128B,
  bcCode128C,
  bcCode93,
  bcCode93Extended,
  bcCodeMSI,
  bcCodePostNet,
  bcCodeCodabar,
  bcCodeEAN8,
  bcCodeEAN13,
  bcCodeUPC_A,
  bcCodeUPC_E0,
  bcCodeUPC_E1,
  bcCodeUPC_Supp2,    { UPC 2 digit supplemental }
  bcCodeUPC_Supp5,    { UPC 5 digit supplemental }
  bcCodeEAN128A,
  bcCodeEAN128B,
  bcCodeEAN128C
  );


  THSBarLineType = (white, black, black_half);  {for internal use only}
  { black_half means a black line with 2/5 height (used for PostNet) }


  THSCheckSumMethod =
  (
  csmNone,
  csmModulo10
  );


  THSBarcode = class(TComponent)
  private
    { Private-Deklarationen }
    FHeight : integer;
    FText  : string;
    FTop    : integer;
    FLeft   : integer;
    FModul  : integer;
    FRatio  : double;
    FTyp    : THSBarcodeType;
    FCheckSum:boolean;
    FAngle  : double;
    FColor  : TColor;
    FColorBar:TColor;
    FCheckSumMethod : THSCheckSumMethod;
    FOnChange : TNotifyEvent;


    modules:array[0..3] of shortint;


    procedure OneBarProps(code:char; var Width:integer; var lt:THSBarLineType);

    procedure DoLines(data:string; Canvas:TCanvas);

    function SetLen(pI:byte):string;

    function Code_2_5_interleaved:string;
    function Code_2_5_industrial:string;
    function Code_2_5_matrix:string;
    function Code_39:string;
    function Code_39Extended:string;
    function Code_128:string;
    function Code_93:string;
    function Code_93Extended:string;
    function Code_MSI:string;
    function Code_PostNet:string;
    function Code_Codabar:string;
    function Code_EAN8:string;
    function Code_EAN13:string;
    function Code_UPC_A:string;
    function Code_UPC_E0:string;
    function Code_UPC_E1:string;
    function Code_Supp5:string;
    function Code_Supp2:string;

    procedure MakeModules;

    procedure SetModul(v:integer);

    function GetWidth : integer;
    procedure SetWidth(Value :integer);

    function DoCheckSumming(const data : string):string;
      procedure SetRatio(const Value: Double);
      procedure SetTyp(const Value: THSBarcodeType);
      procedure SetAngle(const Value: Double);
      procedure SetText(const Value: string);
      procedure SetTop(const Value: Integer);
      procedure SetLeft(const Value: Integer);
      procedure SetCheckSum(const Value: Boolean);
    procedure SetHeight(const Value: integer);
    function GetCanvasHeight: Integer;
    function GetCanvasWidth: Integer;
    function IsAppendLine(const i:integer):Boolean;  //是否需要当前数据线延长
  protected
    { Protected-Deklarationen }
    function MakeData : string;
      procedure DoChange; virtual;

  public
    { Public-Deklarationen }
    constructor Create(Owner:TComponent); override;
    procedure Assign(Source: TPersistent);override;
    procedure DrawBarcode(Canvas:TCanvas);
    property CanvasHeight :Integer read GetCanvasHeight;
    property CanvasWidth :Integer read GetCanvasWidth;
  published
    { Published-Deklarationen }
   { Height of Barcode (Pixel)}
    property Height : integer read FHeight write SetHeight;
    property Text   : string read FText write SetText;
    property Top    : Integer read FTop write SetTop;
    property Left   : Integer read FLeft write SetLeft;
   { Width of the smallest line in a Barcode }
    property Modul  : integer read FModul  write SetModul;
    property Ratio  : Double read FRatio write SetRatio;
    property Typ    : THSBarcodeType read FTyp write SetTyp default bcCode_2_5_interleaved;
   { build CheckSum ? }
    property Checksum:boolean read FCheckSum write SetCheckSum default FALSE;
    property CheckSumMethod:THSCheckSumMethod read FCheckSumMethod write FCheckSumMethod default csmModulo10;

   { 0 - 360 degree }
    property Angle  :double read FAngle write SetAngle;

    property Width : integer read GetWidth write SetWidth stored False;
    property Color:TColor read FColor write FColor default clWhite;
    property ColorBar:TColor read FColorBar write FColorBar default clBlack;
      property OnChange:TNotifyEvent read FOnChange write FOnChange;
  end;


  TBCdata = record
   Name:string;        { Name of Barcode }
   num :Boolean;       { numeric data only }
  end;

  THSBarCodeImage = class(TImage)
  private
    { Private declarations }
    FCode:String;
    FWidth:Integer;
    FHeight:Integer;
    FCodeType:THSBarcodeType;
    FDataLink:TFieldDataLink;
    FBarLabel:String;
    FShowLabel: Boolean;
    FBarCodeAngle:Double;
    procedure SetCode(const Value: string);
    procedure SetCodeType(const Value: THSBarcodeType);
    procedure SetHeight(const Value: integer);
    procedure SetWidth(const Value: integer);
    procedure SetBarLabel(const Value: String);
    procedure ChangeSet(Sender:TObject);
    function GetDataField: string;
    function GetDataSource: TDataSource;
    procedure SetDataField(const Value: string);
    procedure SetDataSource(const Value: TDataSource);
    procedure SetShowLabel(const Value: Boolean);
    procedure SetBarCodeAngle(Const value:Double);
  protected
    { Protected declarations }
    procedure ResetMaxLength;
    procedure Notification(AComponent: TComponent;
      Operation: TOperation); override;

  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure ShowBarCode;
    procedure Print;
  published
    { Published declarations }
    property BarCode: string read FCode write SetCode;
    property BarCodeWidth: integer read FWidth write SetWidth;
    property BarHeight: integer read FHeight write SetHeight;
    property BarCodeType: THSBarcodeType read FCodeType write SetCodeType;
    property BarCodeAngle:Double read FBarCodeAngle Write SetBarCodeAngle;
    property BarLabel:String read FBarLabel write SetBarLabel;
    property DataField:String read GetDataField write SetDataField;
    property DataSource:TDataSource read GetDataSource write SetDataSource;
    property BarShowLabel:Boolean read FShowLabel write SetShowLabel;
  end;


const BCdata:array[bcCode_2_5_interleaved..bcCodeEAN128C] of TBCdata =
  (
    (Name:'2_5_interleaved'; num:True),
    (Name:'2_5_industrial';  num:True),
    (Name:'2_5_matrix';      num:True),
    (Name:'Code39';          num:False),
    (Name:'Code39 Extended'; num:False),
    (Name:'Code128A';        num:False),
    (Name:'Code128B';        num:False),
    (Name:'Code128C';        num:True),
    (Name:'Code93';          num:False),
    (Name:'Code93 Extended'; num:False),
    (Name:'MSI';             num:True),
    (Name:'PostNet';         num:True),
    (Name:'Codebar';         num:False),
    (Name:'EAN8';            num:True),
    (Name:'EAN13';           num:True),
    (Name:'UPC_A';           num:True),
    (Name:'UPC_E0';          num:True),
    (Name:'UPC_E1';          num:True),
    (Name:'UPC Supp2';       num:True),
    (Name:'UPC Supp5';       num:True),
    (Name:'EAN128A';         num:False),
    (Name:'EAN128B';         num:False),
    (Name:'EAN128C';         num:True)
  );



procedure Register;

implementation

procedure ImageRotate90(aBitmap: TBitmap);
var
  nIdx, nOfs,
  x, y, i,nMultiplier: integer;
  nMemWidth, nMemHeight, nMemSize,nScanLineSize: LongInt;
  aScnLnBuffer: PChar;
  aScanLine: PByteArray;
begin
  nMultiplier :=2;  //只需要2位即可
  nMemWidth := aBitmap.Height;
  nMemHeight := aBitmap.Width;
  nMemSize := nMemWidth * nMemHeight * nMultiplier;
  GetMem(aScnLnBuffer, nMemSize);
  try
    nScanLineSize := aBitmap.Width * nMultiplier;
    GetMem(aScanLine, nScanLineSize);
    try
      for y := 0 to aBitmap.Height-1 do
      begin
        Move(aBitmap.ScanLine[y]^, aScanLine^, nScanLineSize);
        for x := 0 to aBitmap.Width-1 do
        begin
          nIdx := ((aBitmap.Width-1) - x) * nMultiplier;
          nOfs := (x * nMemWidth * nMultiplier) +(y * nMultiplier);
          for i := 0 to nMultiplier-1 do
            Byte(aScnLnBuffer[nOfs + i]) := aScanLine[nIdx+i];
        end;
      end;
      aBitmap.Height := nMemHeight;
      aBitmap.Width := nMemWidth;
      for y := 0 to nMemHeight-1 do
      begin
        nOfs := y * nMemWidth * nMultiplier;
        Move((@(aScnLnBuffer[nOfs]))^, aBitmap.ScanLine[y]^, nMemWidth * nMultiplier);
      end;
    finally
      FreeMem(aScanLine, nScanLineSize);
    end;
  finally
    FreeMem(aScnLnBuffer, nMemSize);
  end;
end;





function CheckSumModulo10(const data:string):string;
        var i,fak,sum : Integer;
begin
        sum := 0;
        fak := Length(data);
        for i:=1 to Length(data) do
        begin
                if (fak mod 2) = 0 then
                        sum := sum + (StrToInt(data[i])*1)
                else
                        sum := sum + (StrToInt(data[i])*3);
                dec(fak);
        end;
        if (sum mod 10) = 0 then
                result := data+'0'
        else
                result := data+IntToStr(10-(sum mod 10));
end;

procedure Assert(Cond: Boolean; Text: String);
begin
  if not Cond then
    raise Exception.Create(Text);
end;

{
  converts a string from '321' to the internal representation '715'
  i need this function because some pattern tables have a different
  format :