fr_barc.pas

1、开发环境 d6 up2,sqlserver2000, win2000 server 1024*768（笔记本电脑） c/s 2、数据库配置方法

{*******************************************}
{                                           }
{            FastReport v2.4                }
{         Barcode Add-in object             }
{                                           }
{ Copyright (c) 1998-2001 by Tzyganenko A.  }
{                                           }

//  Barcode Component
//  Version 1.3
//  Copyright 1998-99 Andreas Schmidt and friends

//  Freeware

//  for use with Delphi 2/3/4


//  this component is for private use only!
//  i am not responsible for wrong barcodes
//  Code128C not implemented

//  bug-reports, enhancements:
//  mailto:[e-mail] or
//  [e-mail]

{  Fr_BarC:     Guilbaud Olivier            }
{               [e-mail]        }
{  Ported to FR2.3: Alexander Tzyganenko    }
{                                           }
{*******************************************}

unit FR_BarC;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Menus, frBarcod, FR_Class, ExtCtrls, FR_Ctrls;

type
  TfrBarCodeObject = class(TComponent)  // fake component
  end;

  TfrBarCodeRec = packed record
    cCheckSum : Boolean;
    cShowText : Boolean;
    cCadr     : Boolean;
    cBarType  : TfrBarcodeType;
    cModul    : Integer;
    cRatio    : Double;
    cAngle    : Double;
  end;

  TfrBarCodeView = class(TfrView)
  private
    BarC: TfrBarCode;
    procedure BarcodeEditor(Sender: TObject);
  public
    Param: TfrBarCodeRec;
    constructor Create; override;
    destructor Destroy; override;
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToStream(Stream: TStream); override;
    procedure Draw(Canvas: TCanvas); override;
    procedure StreamOut(Stream: TStream); override;
    procedure DefinePopupMenu(Popup: TPopupMenu); override;
    procedure DefineProperties; override;
    procedure ShowEditor; override;
  end;

  TfrBarCodeForm = class(TForm)
    bCancel: TButton;
    bOk: TButton;
    M1: TfrComboEdit;
    Label1: TLabel;
    cbType: TComboBox;
    Label2: TLabel;
    Image1: TImage;
    GroupBox1: TGroupBox;
    ckCheckSum: TCheckBox;
    ckViewText: TCheckBox;
    GroupBox2: TGroupBox;
    RB1: TRadioButton;
    RB2: TRadioButton;
    RB3: TRadioButton;
    RB4: TRadioButton;
    Label3: TLabel;
    eZoom: TEdit;
    Panel1: TPanel;
    frSpeedButton1: TfrSpeedButton;
    frSpeedButton2: TfrSpeedButton;
    procedure FormCreate(Sender: TObject);
    procedure bOkClick(Sender: TObject);
    procedure FormActivate(Sender: TObject);
    procedure ExprBtnClick(Sender: TObject);
    procedure frSpeedButton1Click(Sender: TObject);
    procedure frSpeedButton2Click(Sender: TObject);
  private
    procedure Localize;
  public
  end;


implementation

uses FR_Const, FR_Utils;

{$R *.DFM}
{$R *.RES}

const
  cbDefaultText = '12345678';


{$HINTS OFF}
function isNumeric(St: String): Boolean;
var
  R: Double;
  E: Integer;
begin
  Val(St, R, E);
  Result := (E = 0);
end;
{$HINTS ON}

constructor TfrBarCodeView.Create;
begin
  inherited Create;

  BarC := TfrBarCode.Create(nil);
  Param.cCheckSum := True;
  Param.cShowText := True;
  Param.cCadr     := False;
  Param.cBarType  := bcCode39;
  Param.cModul    := 1;
  Param.cRatio    := 2;
  Param.cAngle    := 0;
  Memo.Add(cbDefaultText);
  BaseName := 'Bar';
end;

destructor TfrBarCodeView.Destroy;
begin
  BarC.Free;
  inherited Destroy;
end;

procedure TfrBarCodeView.DefineProperties;
begin
  inherited DefineProperties;
  AddProperty('Barcode', [frdtHasEditor, frdtOneObject], BarcodeEditor);
  AddProperty('DataField', [frdtOneObject, frdtHasEditor, frdtString], frFieldEditor);
end;

procedure TfrBarCodeView.LoadFromStream(Stream:TStream);
begin
  inherited LoadFromStream(Stream);
  Stream.Read(Param, SizeOf(Param));
end;

procedure TfrBarCodeView.SaveToStream(Stream:TStream);
begin
  inherited SaveToStream(Stream);
  Stream.Write(Param, SizeOf(Param));
end;

procedure TfrBarCodeView.Draw(Canvas: TCanvas);
var
  Txt: String;
  hg: Integer;
  EMF: TMetafile;
  EMFCanvas: TMetafileCanvas;
  h, oldh: HFont;

  function CreateRotatedFont(Font: TFont; Angle: Integer): HFont;
  var
    F: TLogFont;
  begin
    GetObject(Font.Handle, SizeOf(TLogFont), @F);
    F.lfEscapement := Angle * 10;
    F.lfOrientation := Angle * 10;
    Result := CreateFontIndirect(F);
  end;

begin
  if (dx < 0) or (dy < 0) or (Memo.Text = #13#10) then Exit;
  BeginDraw(Canvas);
  Memo1.Assign(Memo);

  if (Memo1.Count > 0) and (Memo1[0][1] <> '[') then
    Txt := Memo1[0] else
    Txt := cbDefaultText;
  BarC.Angle := Param.cAngle;
  BarC.Ratio := Param.cRatio;
  BarC.Modul := Param.cModul;
  BarC.Checksum := Param.cCheckSum;
  if FillColor = clNone then
    BarC.Color := clWhite else
    BarC.Color := FillColor;
  BarC.Typ := Param.cBarType;
  if bcData[Param.cBarType].Num = False then
    BarC.Text := Txt
  else if IsNumeric(Txt) then
    BarC.Text := Txt else
    BarC.Text := cbDefaultText;
  if (Param.cAngle = 90) or (Param.cAngle = 270) then
    dy := BarC.Width else
    dx := BarC.Width;

  if Trim(BarC.Text) = '0' then Exit;

  if (Param.cAngle = 90) or (Param.cAngle = 270) then
    if Param.cShowText then
      hg := dx - 14 else
      hg := dx
  else if Param.cShowText then
      hg := dy - 14 else
      hg := dy;
  BarC.Left := 0;
  BarC.Top := 0;
  BarC.Height := hg;
  if (BarC.Typ = bcCodePostNet) and (Param.cAngle = 0) then
  begin
    BarC.Top := hg;
    BarC.Height := -hg;
  end;

  if Param.cAngle = 180 then
    BarC.Top := dy - hg
  else if Param.cAngle = 270 then
    BarC.Left := dx - hg;



  EMF := TMetafile.Create;
  EMF.Width := dx;
  EMF.Height := dy;
  EMFCanvas := TMetafileCanvas.Create(EMF, 0);
  BarC.DrawBarcode(EMFCanvas);
  Txt := BarC.Text;

  if Param.cShowText then
  with EMFCanvas do
  begin
    Font.Color := clBlack;
    Font.Name := 'Courier New';
    Font.Height := -12;
    Font.Style := [];
    h := CreateRotatedFont(Font, Round(Param.cAngle));
    oldh := SelectObject(Handle, h);
    if Param.cAngle = 0 then
      TextOut((dx - TextWidth(Txt)) div 2, dy - 12, Txt)
    else if Param.cAngle = 90 then
      TextOut(dx - 12, dy - (dy - TextWidth(Txt)) div 2, Txt)
    else if Param.cAngle = 180 then
      TextOut(dx - (dx - TextWidth(Txt)) div 2, 12, Txt)
    else
      TextOut(12, (dy - TextWidth(Txt)) div 2, Txt);
    SelectObject(Handle, oldh);
    DeleteObject(h);
  end;
  EMFCanvas.Free;

  CalcGaps;
  ShowBackground;
  Canvas.StretchDraw(DRect, EMF);
  EMF.Free;
  ShowFrame;
  RestoreCoord;
end;

procedure TfrBarCodeView.StreamOut(Stream: TStream);
var
  SaveTag: String;
begin
  BeginDraw(Canvas);
  Memo1.Assign(Memo);
  CurReport.InternalOnEnterRect(Memo1, Self);
  frInterpretator.DoScript(Script);
  if not Visible then Exit;

  SaveTag := Tag;
  if (Tag <> '') and (Pos('[', Tag) <> 0) then
    ExpandVariables(Tag);

  if Memo1.Count > 0 then
    if (Length(Memo1[0]) > 0) and (Memo1[0][1] = '[') then
    try
      Memo1[0] := frParser.Calc(Memo1[0]);
    except
      Memo1[0] := '0';
    end;

  Stream.Write(Typ, 1);
  frWriteString(Stream, ClassName);
  SaveToStream(Stream);

  Tag := SaveTag;
end;

procedure TfrBarCodeView.DefinePopupMenu(Popup: TPopupMenu);
begin
  // no specific items in popup menu
end;

procedure TfrBarCodeView.BarcodeEditor(Sender: TObject);
begin
  ShowEditor;
end;

procedure TfrBarCodeView.ShowEditor;
begin
  with TfrBarcodeForm.Create(nil) do
  begin
    if Memo.Count > 0 then
      M1.Text := Memo.Strings[0];
    cbType.ItemIndex   := ord(Param.cBarType);
    ckCheckSum.checked := Param.cCheckSum;
    ckViewText.Checked := Param.cShowText;
    eZoom.Text := IntToStr(Param.cModul);
    if Param.cAngle = 0 then
      RB1.Checked := True
    else if Param.cAngle = 90 then
      RB2.Checked := True
    else if Param.cAngle = 180 then
      RB3.Checked := True
    else
      RB4.Checked := True;
    if ShowModal = mrOk then
    begin
      frDesigner.BeforeChange;
      Memo.Clear;
      Memo.Add(M1.Text);
      Param.cModul := StrToInt(eZoom.Text);
      Param.cCheckSum  := ckCheckSum.Checked;
      Param.cShowText  := ckViewText.Checked;
      Param.cBarType := TfrBarcodeType(cbType.ItemIndex);
      if RB1.Checked then
        Param.cAngle := 0
      else if RB2.Checked then
        Param.cAngle := 90
      else if RB3.Checked then
        Param.cAngle := 180
      else
        Param.cAngle := 270;
    end;
    Free;
  end;
end;


//--------------------------------------------------------------------------
procedure TfrBarCodeForm.Localize;
begin
  Caption := frLoadStr(frRes + 650);
  Label1.Caption := frLoadStr(frRes + 651);
  Label2.Caption := frLoadStr(frRes + 652);
  Label3.Caption := frLoadStr(frRes + 659);
  GroupBox1.Caption := frLoadStr(frRes + 653);
  ckCheckSum.Caption := frLoadStr(frRes + 654);
  ckViewText.Caption := frLoadStr(frRes + 655);
  M1.ButtonHint := frLoadStr(frRes + 656);
  GroupBox2.Caption := frLoadStr(frRes + 658);
  bOk.Caption := frLoadStr(SOk);
  bCancel.Caption := frLoadStr(SCancel);
end;

procedure TfrBarCodeForm.FormCreate(Sender: TObject);
var
  i: TfrBarcodeType;
begin
  Localize;
  CbType.Items.Clear;
  for i := bcCode_2_5_interleaved to bcCodeEAN128C do
    cbType.Items.Add(bcData[i].Name);
  cbType.ItemIndex := 0;
end;

procedure TfrBarCodeForm.FormActivate(Sender: TObject);
begin
  M1.SetFocus;
end;

procedure TfrBarCodeForm.ExprBtnClick(Sender: TObject);
var
  s: String;
begin
  s := frDesigner.InsertExpression;
  if s <> '' then
    M1.Text := s;
end;

procedure TfrBarCodeForm.bOkClick(Sender: TObject);
var
  bc: TfrBarCode;
  Bmp: TBitmap;
begin
  bc := TfrBarCode.Create(nil);
  bc.Text := M1.Text;
  bc.CheckSum  := ckCheckSum.Checked;
  bc.Typ := TfrBarcodeType(cbType.ItemIndex);
  Bmp := TBitmap.Create;
  Bmp.Width := 16; Bmp.Height := 16;
  if (bc.Text = '') or (bc.Text[1] <> '[') then
    try
      bc.DrawBarcode(Bmp.Canvas);
    except
      MessageBox(0, PChar(frLoadStr(SBarcodeError)), PChar(frLoadStr(SError)),
        mb_Ok + mb_IconError);
      ModalResult := 0;
    end;
  Bmp.Free;
end;


var
  Bmp: TBitmap;

procedure TfrBarCodeForm.frSpeedButton1Click(Sender: TObject);
var
  i: Integer;
begin
  i := StrToInt(eZoom.Text);
  Inc(i);
  eZoom.Text := IntToStr(i);
end;

procedure TfrBarCodeForm.frSpeedButton2Click(Sender: TObject);
var
  i: Integer;
begin
  i := StrToInt(eZoom.Text);
  Dec(i);
  if i <= 0 then i := 1;
  eZoom.Text := IntToStr(i);
end;

initialization
  Bmp := TBitmap.Create;
  Bmp.LoadFromResourceName(hInstance, 'FR_BARCODEVIEW');
  frRegisterObject(TfrBarCodeView, Bmp, IntToStr(SInsBarcode));

finalization
  Bmp.Free;


end.