rm_barc.pas

进销存·完整的·有数据库的·非常完整·只得参考

{*******************************************}
{                                           }
{          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
    if (Length(Memo1[0]) > 0) and (Memo1[0][1] = '[') then
    begin
      try
        Memo1[0] := RMParser.Calc(Memo1[0]);
      except
        Memo1[0] := '0';
      end;
    end;
  end;

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

  RMInterpretator.DoScript(Script_AfterPrint);
  Tag := SaveTag;
end;

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

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

procedure TRMBarCodeView.ShowEditor;
var
  tmpForm: TRMBarcodeForm;
begin
  tmpForm := TRMBarcodeForm.Create(nil);
  try
    with tmpForm do
    begin
      if Memo.Count > 0 then
        edtCode.Text := Memo.Strings[0];
      cbType.ItemIndex := ord(Param.cBarType);
      chkCheckSum.checked := Param.cCheckSum;
      chkViewText.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
        RMDesigner.BeforeChange;
        Memo.Clear;
        Memo.Add(edtCode.Text);
        Param.cModul := StrToInt(eZoom.Text);
        Param.cCheckSum := chkCheckSum.Checked;
        Param.cShowText := chkViewText.Checked;
        Param.cBarType := TRMBarcodeType(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;
        RMDesigner.AfterChange;
      end;
    end;
  finally
    tmpForm.Free;
  end;
end;

function TRMBarCodeView.GetViewCommon: string;
begin
  Result := '[BarCode]';
end;

{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{TRMBarCodeForm}

procedure TRMBarCodeForm.ShowSample;
var
  Txt: string;
  hg: Integer;
  h, oldh: HFont;
begin
  if IsNumeric(edtCode.Text) then
    FBarCode.Text := edtCode.Text
  else
    FBarCode.Text := cbDefaultText;
  FBarCode.Checksum := chkCheckSum.Checked;
  FBarCode.Typ := TRMBarcodeType(cbType.ItemIndex);
  FBarCode.Ratio := 2;
  FBarCode.Modul := StrToInt(eZoom.Text);
  if RB1.Checked then
    FBarCode.Angle := 0
  else if RB2.Checked then
    FBarCode.Angle := 90
  else if RB3.Checked then
    FBarCode.Angle := 180
  else
    FBarCode.Angle := 270;

  imgSample.Canvas.FillRect(Rect(0, 0, imgSample.Width, imgSample.Height));
  if (FBarCode.Angle = 90) or (FBarCode.Angle = 270) then
    hg := imgSample.Width - 14
  else
    hg := imgSample.Height - 14;

  FBarCode.Left := 0; FBarCode.Top := 0;
  FBarCode.Height := hg;
  if FBarCode.Angle = 180 then
    FBarCode.Top := imgSample.Height - hg
  else if FBarCode.Angle = 270 then
    FBarCode.Left := imgSample.Width - hg;

  Txt := FBarCode.Text;
  with imgSample.Canvas do
  begin
    Font.Color := clBlack;
    Font.Name := 'Courier New';
    Font.Height := -12;
    Font.Style := [];
    h := CreateRotatedFont(Font, Round(FBarCode.Angle));
    oldh := SelectObject(Handle, h);
    if FBarCode.Angle = 0 then
      TextOut((imgSample.Width - TextWidth(Txt)) div 2, imgSample.Height - 12, Txt)
    else if FBarCode.Angle = 90 then
      TextOut(imgSample.Width - 12, imgSample.Height - (imgSample.Height - TextWidth(Txt)) div 2, Txt)
    else if FBarCode.Angle = 180 then
      TextOut(imgSample.Width - (imgSample.Width - TextWidth(Txt)) div 2, 12, Txt)
    else
      TextOut(12, (imgSample.Height - TextWidth(Txt)) div 2, Txt);
    SelectObject(Handle, oldh);
    DeleteObject(h);
  end;

  FBarCode.DrawBarcode(imgSample.Canvas);
end;

procedure TRMBarCodeForm.FormCreate(Sender: TObject);
var
  i: TRMBarcodeType;
begin
  FBarCode := TRMBarCode.Create(Self);
  FBarCode.Height := ImgSample.ClientHeight;
  CbType.Items.Clear;
  for i := bcCode_2_5_interleaved to bcCodeEAN128C do
    cbType.Items.Add(bcData[i].Name);
  cbType.ItemIndex := 0;

  Localize;
end;

procedure TRMBarCodeForm.FormDestroy(Sender: TObject);
begin
  FBarCode.Free;
end;

procedure TRMBarCodeForm.FormActivate(Sender: TObject);
begin
  edtCode.SetFocus;
end;

procedure TRMBarCodeForm.DBBtnClick(Sender: TObject);
var
  s: string;
begin
  s := RMDesigner.InsertExpression;
  if s <> '' then
    edtCode.Text := s;
end;

procedure TRMBarCodeForm.btnOKClick(Sender: TObject);
var
  bc: TRMBarCode;
  Bmp: TBitmap;
begin
  bc := TRMBarCode.Create(nil);
  Bmp := TBitmap.Create;
  try
    bc.Text := edtCode.Text;
    bc.CheckSum := chkCheckSum.Checked;
    bc.Typ := TRMBarcodeType(cbType.ItemIndex);
    Bmp.Width := 16; Bmp.Height := 16;
    if (bc.Text = '') or (bc.Text[1] <> '[') then
    begin
      try
        bc.DrawBarcode(Bmp.Canvas);
      except
        MessageBox(0, PChar(RMLoadStr(SBarcodeError)), PChar(RMLoadStr(SError)),
          mb_Ok + mb_IconError);
        ModalResult := 0;
      end;
    end;
  finally
    Bmp.Free;
    bc.Free;
  end;
end;

procedure TRMBarCodeForm.edtCodeChange(Sender: TObject);
begin
  ShowSample;
end;

procedure TRMBarCodeForm.cbTypeChange(Sender: TObject);
begin
  ShowSample;
end;

procedure TRMBarCodeForm.chkCheckSumClick(Sender: TObject);
begin
  ShowSample;
end;

procedure TRMBarCodeForm.RB1Click(Sender: TObject);
begin
  ShowSample;
end;

procedure TRMBarCodeForm.FormShow(Sender: TObject);
begin
  ShowSample;
end;

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

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

procedure TRMBarCodeForm.Localize;
begin
  Font.Name := RMLoadStr(SRMDefaultFontName);
  Font.Size := StrToInt(RMLoadStr(SRMDefaultFontSize));
  Font.Charset := StrToInt(RMLoadStr(SCharset));

  RMSetStrProp(Self, 'Caption', rmRes + 650);
  RMSetStrProp(Label1, 'Caption', rmRes + 651);
  RMSetStrProp(Label2, 'Caption', rmRes + 652);
  RMSetStrProp(Label3, 'Caption', rmRes + 659);
  RMSetStrProp(GroupBox1, 'Caption', rmRes + 653);
  RMSetStrProp(chkCheckSum, 'Caption', rmRes + 654);
  RMSetStrProp(chkViewText, 'Caption', rmRes + 655);
  RMSetStrProp(DBBtn, 'Hint', rmRes + 656);
  RMSetStrProp(GroupBox2, 'Caption', rmRes + 658);
  btnOk.Caption := RMLoadStr(SOk);
  btnCancel.Caption := RMLoadStr(SCancel);
end;

initialization
  RMRegisterObjectByRes(TRMBarCodeView, 'RM_BARCODEOBJECT', RMLoadStr(SInsBarcode), TRMBarCodeForm);

finalization

end.