vpdfbarcode.pas

生成PDF文档的控件

{*******************************************************}
{                                                       }
{       This unit is part of the VISPDF VCL library.    }
{       Written by R.Husske - ALL RIGHTS RESERVED.      }
{                                                       }
{       Copyright (C) 2000-2009, www.vispdf.com         }
{                                                       }
{       e-mail: [e-mail]                      }
{       http://www.vispdf.com                           }
{                                                       }
{*******************************************************}

unit VPDFBarcode;

interface

{$I VisPDFLib.inc }

uses
  Classes, Graphics;

type
  TVPDFBarLineType = (white, black, black_half);

  TVPDFBarcodeOption = (bcoNone, bcoCode, bcoTyp, bcoBoth);

  TVPDFShowTextPosition =
    (
    stpTopLeft,
    stpTopRight,
    stpTopCenter,
    stpBottomLeft,
    stpBottomRight,
    stpBottomCenter
    );

  TVPDFCheckSumMethod =
    (
    csmNone,
    csmModulo10
    );

  TVPDFBarcode = class(TComponent)
  private
    FHeight: integer;
    FText: AnsiString;
    FTop: integer;
    FLeft: integer;
    FModul: integer;
    FRatio: double;
    FTyp: Integer;
    FCheckSum: boolean;
    FShowText: TVPDFBarcodeOption;
    FAngle: double;
    FColor: TColor;
    FColorBar: TColor;
    FCheckSumMethod: TVPDFCheckSumMethod;
    FOnChange: TNotifyEvent;
    Modules: array[0..3] of shortint;
    FShowTextFont: TFont;
    FShowTextPosition: TVPDFShowTextPosition;
    procedure OneBarProps(code: AnsiChar; var Width: integer; var lt: TVPDFBarLineType);
    procedure DoLines(data: AnsiString; Canvas: TCanvas);
    function SetLen(pI: byte): AnsiString;
    function Code_2_5_interleaved: AnsiString;
    function Code_2_5_industrial: AnsiString;
    function Code_2_5_matrix: AnsiString;
    function Code_39: AnsiString;
    function Code_39Extended: AnsiString;
    function Code_128: AnsiString;
    function Code_93: AnsiString;
    function Code_93Extended: AnsiString;
    function Code_MSI: AnsiString;
    function Code_PostNet: AnsiString;
    function Code_Codabar: AnsiString;
    function Code_EAN8: AnsiString;
    function Code_EAN13: AnsiString;
    function Code_UPC_A: AnsiString;
    function Code_UPC_E0: AnsiString;
    function Code_UPC_E1: AnsiString;
    function Code_Supp5: AnsiString;
    function Code_Supp2: AnsiString;
    function GetTypText: AnsiString;
    procedure MakeModules;
    procedure SetModul(v: integer);
    function GetWidth: integer;
    procedure SetWidth(Value: integer);
    function DoCheckSumming(const data: AnsiString): AnsiString;
    procedure SetRatio(const Value: Double);
    procedure SetTyp(const Value: Integer);
    procedure SetAngle(const Value: Double);
    procedure SetText(const Value: AnsiString);
    procedure SetShowText(const Value: TVPDFBarcodeOption);
    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;
    procedure SetShowTextFont(const Value: TFont);
    procedure SetShowTextPosition(const Value: TVPDFShowTextPosition);
    function CheckSumModulo10(const Data: AnsiString): AnsiString;
  protected
    function MakeData: AnsiString;
    procedure DoChange; virtual;
  public
    constructor Create(Owner: TComponent); override;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    procedure DrawBarcode(Canvas: TCanvas);
    procedure DrawText(Canvas: TCanvas);
    property CanvasHeight: Integer read GetCanvasHeight;
    property CanvasWidth: Integer read GetCanvasWidth;
  published
    property Height: integer read FHeight write SetHeight;
    property Text: AnsiString read FText write SetText;
    property Top: Integer read FTop write SetTop;
    property Left: Integer read FLeft write SetLeft;
    property Modul: integer read FModul write SetModul;
    property Ratio: Double read FRatio write SetRatio;
    property Typ: Integer read FTyp write SetTyp default
      0;
    property Checksum: boolean read FCheckSum write SetCheckSum default FALSE;
    property CheckSumMethod: TVPDFCheckSumMethod read FCheckSumMethod write
      FCheckSumMethod default csmModulo10;
    property Angle: double read FAngle write SetAngle;
    property ShowText: TVPDFBarcodeOption read FShowText write SetShowText default
      bcoNone;
    property ShowTextFont: TFont read FShowTextFont write SetShowTextFont;
    property ShowTextPosition: TVPDFShowTextPosition read FShowTextPosition write
      SetShowTextPosition default stpTopLeft;
    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;

implementation

uses WinProcs, WinTypes, SysUtils, Math;

type
  TBCdata = record
    Name: AnsiString;
    num: Boolean;
  end;

const
  BCdata: array[0..22] 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)
    );

function Trim(const S: AnsiString): AnsiString; export;
var
  I, L: Integer;
begin
  L := Length(S);
  I := 1;
  while (I <= L) and (S[I] <= ' ') 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;

function Convert(const s: AnsiString): AnsiString;
var
  I, v: integer;
begin
  Result := s;
  for I := 1 to Length(s) do
  begin
    v := ord(s[I]) - 1;
    if odd(I) then
      Inc(v, 5);
    Result[I] := AnsiChar(Chr(v));
  end;
end;

function QuerSumme(x: integer): integer;
var
  Sum: integer;
begin
  Sum := 0;
  while x > 0 do
  begin
    Sum := Sum + (x mod 10);
    x := x div 10;
  end;
  Result := Sum;
end;

function Rotate2D(p: TPoint; Alpha: double): TPoint;
var
  sinus, cosinus: Extended;
begin
  SinCos(Alpha, sinus, cosinus);
  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;

function TranslateQuad2D(const Alpha: double; const Orgin, point: TPoint):
  TPoint;
var
  alphacos: Extended;
  alphasin: Extended;
  moveby: TPoint;
begin
  SinCos(Alpha, alphasin, alphacos);
  if alphasin >= 0 then
  begin
    if alphacos >= 0 then
    begin
      moveby.x := 0;
      moveby.y := Round(alphasin * point.x);
    end
    else
    begin
      moveby.x := -Round(alphacos * point.x);
      moveby.y := Round(alphasin * point.x - alphacos * point.y);
    end;
  end
  else
  begin
    if alphacos >= 0 then
    begin
      moveby.x := -Round(alphasin * point.y);
      moveby.y := 0;
    end
    else
    begin
      moveby.x := -Round(alphacos * point.x) - Round(alphasin * point.y);
      moveby.y := -Round(alphacos * point.y);
    end;
  end;
  Result := Translate2D(Orgin, moveby);
end;

constructor TVPDFBarcode.Create(Owner: TComponent);
begin
  inherited Create(owner);
  FAngle := 0.0;
  FRatio := 2.0;
  FModul := 1;
  FTyp := 14;
  FCheckSum := FALSE;
  FCheckSumMethod := csmModulo10;
  FShowText := bcoCode;
  FColor := clWhite;
  FColorBar := clBlack;
  FShowTextFont := TFont.Create;
  FShowTextPosition := stpBottomCenter;
end;

destructor TVPDFBarcode.Destroy;
begin
  FShowTextFont.Free;
  inherited;
end;

procedure TVPDFBarcode.Assign(Source: TPersistent);
var
  BSource: TVPDFBarcode;
begin
  if Source is TVPDFBarcode then
  begin
    BSource := TVPDFBarcode(Source);
    FHeight := BSource.FHeight;
    FText := BSource.FText;
    FTop := BSource.FTop;
    FLeft := BSource.FLeft;
    FModul := BSource.FModul;
    FRatio := BSource.FRatio;
    FTyp := BSource.FTyp;
    FCheckSum := BSource.FCheckSum;
    FShowText := BSource.FShowText;
    FShowTextPosition := BSource.FShowTextPosition;
    FAngle := BSource.FAngle;
    FColor := BSource.FColor;
    FColorBar := BSource.FColorBar;
    FCheckSumMethod := BSource.FCheckSumMethod;
    FOnChange := BSource.FOnChange;
  end
  else
    inherited;
end;

function TVPDFBarcode.GetTypText: AnsiString;
begin
  Result := BCdata[FTyp].Name;
end;

procedure TVPDFBarcode.SetModul(v: integer);
begin
  if (v >= 1) and (v < 50) then
  begin
    FModul := v;
    DoChange;
  end;
end;

procedure TVPDFBarcode.OneBarProps(code: AnsiChar; var Width: integer; var lt:
  TVPDFBarLineType);
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
      raise Exception.CreateFmt('%s: internal Error', [self.ClassName]);
    end;
  end;
end;

function TVPDFBarcode.MakeData: AnsiString;
var
  I: integer;
begin
  MakeModules;
  if BCdata[Typ].num then
  begin
    FText := Trim(FText);
    for I := 1 to Length(Ftext) do
      if (FText[I] > '9') or (FText[I] < '0') then
        raise Exception.Create('Barcode must be numeric');
  end;
  case Typ of
    0: Result := Code_2_5_interleaved;
    1: Result := Code_2_5_industrial;
    2: Result := Code_2_5_matrix;
    3: Result := Code_39;
    4: Result := Code_39Extended;
    5, 6, 7, 20, 21,
      22: Result := Code_128;
    8: Result := Code_93;
    9: Result := Code_93Extended;
    10: Result := Code_MSI;
    11: Result := Code_PostNet;
    12: Result := Code_Codabar;
    13: Result := Code_EAN8;
    14: Result := Code_EAN13;
    15: Result := Code_UPC_A;
    16: Result := Code_UPC_E0;
    17: Result := Code_UPC_E1;
    18: Result := Code_Supp2;
    19: Result := Code_Supp5;
  else
    raise Exception.CreateFmt('%s: wrong BarcodeType', [self.ClassName]);
  end;
end;

function TVPDFBarcode.GetWidth: integer;
var
  data: AnsiString;
  I: integer;
  w: integer;
  lt: TVPDFBarLineType;
begin
  Result := 0;