rm_barc.pas

中小企业管理系统------ ERP系统原代码

{*******************************************}
{                                           }
{          Report Machine v2.0              }
{         Barcode Add-in object             }
{                                           }
{*******************************************}

unit RM_BarC;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Menus, ExtCtrls, Buttons, RM_Class, RM_BarCode;

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

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

  { TRMBarCodeView }
  TRMBarCodeView = class(TRMView)
  private
    FBarC: TRMBarCode;
    procedure BarcodeEditor(Sender: TObject);
  protected
    function GetViewCommon: string; override;
  public
    Param: TRMBarCodeRec;
    constructor Create; override;
    destructor Destroy; override;
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToStream(Stream: TStream); override;
    procedure Draw(aCanvas: TCanvas); override;
    procedure StreamOut(Stream: TStream); override;
    procedure DefinePopupMenu(Popup: TPopupMenu); override;
    procedure DefineProperties; override;
    procedure ShowEditor; override;
  end;

  { TRMBarCodeForm }
  TRMBarCodeForm = class(TForm)
    btnCancel: TButton;
    btnOK: TButton;
    edtCode: TEdit;
    Label1: TLabel;
    cbType: TComboBox;
    Label2: TLabel;
    GroupBox1: TGroupBox;
    chkCheckSum: TCheckBox;
    chkViewText: TCheckBox;
    GroupBox2: TGroupBox;
    RB1: TRadioButton;
    RB2: TRadioButton;
    RB3: TRadioButton;
    RB4: TRadioButton;
    imgSample: TImage;
    Label3: TLabel;
    eZoom: TEdit;
    Panel2: TPanel;
    SpeedButton1: TSpeedButton;
    SpeedButton2: TSpeedButton;
    DBBtn: TSpeedButton;
    procedure FormCreate(Sender: TObject);
    procedure DBBtnClick(Sender: TObject);
    procedure btnOKClick(Sender: TObject);
    procedure FormActivate(Sender: TObject);
    procedure edtCodeChange(Sender: TObject);
    procedure cbTypeChange(Sender: TObject);
    procedure chkCheckSumClick(Sender: TObject);
    procedure RB1Click(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure SpeedButton1Click(Sender: TObject);
    procedure SpeedButton2Click(Sender: TObject);
  private
    FBarcode: TRMBarcode;
    procedure ShowSample;
    procedure Localize;
  public
  end;

implementation

uses RM_Const, RM_Utils, RM_CmpReg;

{$R *.DFM}

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}

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;

{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{TRMBarCodeView}

constructor TRMBarCodeView.Create;
begin
  inherited Create;

  FBarC := TRMBarCode.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 TRMBarCodeView.Destroy;
begin
  FBarC.Free;
  inherited Destroy;
end;

procedure TRMBarCodeView.DefineProperties;
begin
  inherited DefineProperties;
  AddProperty('Barcode', [RMdtHasEditor, RMdtOneObject], BarcodeEditor);
  AddProperty('DataField', [RMdtOneObject, RMdtHasEditor, RMdtString], RMFieldEditor);

  AddProperty('OnBeforePrint', [RMdtHasEditor, RMdtOneObject], RMScript_BeforePrintEditor);
  AddProperty('OnAfterPrint', [RMdtHasEditor, RMdtOneObject], RMScript_AfterPrintEditor);
end;

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

procedure TRMBarCodeView.SaveToStream(Stream: TStream);
begin
  LVersion := 0;
  inherited SaveToStream(Stream);
  Stream.Write(Param, SizeOf(Param));
end;

procedure TRMBarCodeView.Draw(aCanvas: TCanvas);
var
  Txt: string;
  hg: Integer;
  EMF: TMetafile;
  EMFCanvas: TMetafileCanvas;
  h, oldh: HFont;
  lidx, lidy: Integer;
begin
  if (dx < 0) or (dy < 0) then Exit;
  BeginDraw(aCanvas);
  Memo1.Assign(Memo);

  if (Memo1.Count > 0) and (Length(Memo1[0]) > 0) and (Memo1[0][1] <> '[') then
    Txt := Memo1.Strings[0]
  else
    Txt := cbDefaultText;

  FBarC.Angle := Param.cAngle;
  FBarC.Ratio := Param.cRatio;
  FBarC.Modul := Param.cModul;
  FBarC.Checksum := Param.cCheckSum;
  if FillColor = clNone then
    FBarC.Color := clWhite
  else
    FBarC.Color := FillColor;
  FBarC.Typ := Param.cBarType;
  if bcData[Param.cBarType].Num = False then
    FBarC.Text := Txt
  else if IsNumeric(Txt) then
    FBarC.Text := Txt
  else
    FBarC.Text := cbDefaultText;

  if (Param.cAngle = 90) or (Param.cAngle = 270) then
    dy := FBarC.Width + Gapy * 2 + _CalcVFrameWidth(TopFrame.Width, BottomFrame.Width)
  else
    dx := FBarC.Width + Gapx * 2 + _CalcHFrameWidth(LeftFrame.Width, RightFrame.Width);

  lidx := dx - Gapx * 2 - _CalcHFrameWidth(LeftFrame.Width, RightFrame.Width);
  lidy := dy - Gapy * 2 - _CalcVFrameWidth(TopFrame.Width, BottomFrame.Width);
  if (lidx <= 0) or (lidy <= 0) or (Trim(FBarC.Text) = '0') then
  begin
    Exit;
  end;

  if (Param.cAngle = 90) or (Param.cAngle = 270) then
  begin
    if Param.cShowText then
      hg := lidx - 14
    else
      hg := lidx;
  end
  else if Param.cShowText then
    hg := lidy - 14
  else
    hg := lidy;

  FBarC.Left := 0;
  FBarC.Top := 0;
  FBarC.Height := hg;
  if Param.cAngle = 180 then
    FBarC.Top := lidy - hg
  else if Param.cAngle = 270 then
    FBarC.Left := lidx - hg;

  EMF := TMetafile.Create;
  EMF.Width := lidx;
  EMF.Height := lidy;
  EMFCanvas := TMetafileCanvas.Create(EMF, 0);
  FBarC.DrawBarcode(EMFCanvas);
  Txt := FBarC.Text;

  if Param.cShowText then
  begin
    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((lidx - TextWidth(Txt)) div 2, lidy - 12, Txt)
      else if Param.cAngle = 90 then
        TextOut(lidx - 12, lidy - (lidy - TextWidth(Txt)) div 2, Txt)
      else if Param.cAngle = 180 then
        TextOut(lidx - (lidx - TextWidth(Txt)) div 2, 12, Txt)
      else
        TextOut(12, (lidy - TextWidth(Txt)) div 2, Txt);
      SelectObject(Handle, oldh);
      DeleteObject(h);
    end;
  end;
  EMFCanvas.Free;

  CalcGaps;
  ShowBackground;
  InflateRect(DRect, -gapx, -gapy);
  aCanvas.StretchDraw(DRect, EMF);
  EMF.Free;
  ShowFrame;
  RestoreCoord;
end;

procedure TRMBarCodeView.StreamOut(Stream: TStream);
var
  SaveTag: string;
begin
  BeginDraw(Canvas);
  Memo1.Assign(Memo);
  CurReport.InternalOnEnterRect(Memo1, Self);
  RMInterpretator.DoScript(Script);
  if not Visible then Exit;
  if IsPrinting and (not PPrintFrame) then Exit;

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

  if Memo1.Count > 0 then
  begin