{*******************************************} { } { FastReport v2.3 } { Barcode Add-in object } { } { Copyright (c) 1998-99 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:shmia@bizerba.de or // a_j_schmidt@rocketmail.com { Fr_BarC: Guilbaud Olivier } { golivier@worldnet.fr } { Ported to FR2.3: Alexander Tzyganenko } { } {*******************************************} unit LR_BarC; {$I lr_vers.inc} interface uses Classes, SysUtils, LCLPlatformDef, InterfaceBase, Graphics, Controls, Forms, Dialogs, Buttons, StdCtrls, Menus, Barcode, ExtCtrls, ButtonPanel, LCLType, LR_Class {$IFDEF LCLNOGUI} ,lr_ngcanvas {$ENDIF} ; {.$DEFINE BC_1_25} //For Barcode version 1.25 actually in debug type {$IFDEF BC_1_25} TBarCode=Class(TAsBarCode); {$ENDIF} { TfrBarCodeObject } TfrBarCodeObject = class(TComponent) // fake component public constructor Create(aOwner : TComponent); override; end; TfrBarCode = packed record cCheckSum : Boolean; cShowText : Boolean; cCadr : Boolean; cBarType : TBarcodeType; cModul : Integer; cRatio : Double; cAngle : Double; end; { TfrCustomBarCodeView } TfrCustomBarCodeView = class(TfrView) private BarC: TBarCode; FText: string; function GetAngle: Double; function GetBarType: TBarcodeType; function GetCheckSum: Boolean; function GetShowText: Boolean; function GetZoom: Double; procedure SetAngle(AValue: Double); procedure SetBarType(const AValue: TBarcodeType); procedure SetCheckSum(const AValue: Boolean); procedure SetShowText(const AValue: Boolean); procedure SetZoom(const AValue: Double); function CreateBarcode: TLazreportBitmap; function CreateLabelFont(aCanvas: TCanvas): TFont; procedure DrawLabel(aCanvas: TCanvas; R: TRect); public Param: TfrBarCode; constructor Create(AOwnerPage:TfrPage);override; destructor Destroy; override; procedure Assign(Source: TPersistent); override; function GenerateBitmap: TLazreportBitmap; virtual; procedure LoadFromStream(Stream: TStream); override; procedure SaveToStream(Stream: TStream); override; procedure Draw(aCanvas: TCanvas); override; procedure Print(Stream: TStream); override; procedure DefinePopupMenu({%H-}Popup: TPopupMenu); override; procedure LoadFromXML(XML: TLrXMLConfig; const Path: String); override; procedure SaveToXML(XML: TLrXMLConfig; const Path: String); override; property CheckSum : Boolean read GetCheckSum write SetCheckSum; property BarType : TBarcodeType read GetBarType write SetBarType; property ShowText : Boolean read GetShowText write SetShowText; property Zoom : Double read GetZoom write SetZoom; property Angle: Double read GetAngle write SetAngle; end; TfrBarcodeView = class(TfrCustomBarcodeView) published property CheckSum; property BarType; property ShowText; property Zoom; property Angle; property Memo; property Frames; property FrameColor; property FrameStyle; property FrameWidth; property Restrictions; end; {$IFNDEF LCLNOGUI} { TfrBarCodeForm } TfrBarCodeForm = class(TfrObjEditorForm) ButtonPanel1: TButtonPanel; edZoom: TEdit; labZoom: TLabel; M1: TEdit; Label1: TLabel; cbType: TComboBox; Label2: TLabel; Image1: TImage; Panel1: TPanel; DBBtn: TSpeedButton; VarBtn: TSpeedButton; GroupBox1: TGroupBox; ckCheckSum: TCheckBox; ckViewText: TCheckBox; GroupBox2: TGroupBox; RB1: TRadioButton; RB2: TRadioButton; RB3: TRadioButton; RB4: TRadioButton; procedure FormClose(Sender: TObject; var {%H-}CloseAction: TCloseAction); procedure FormCreate(Sender: TObject); procedure VarBtnClick(Sender: TObject); procedure DBBtnClick(Sender: TObject); procedure bOkClick(Sender: TObject); procedure FormActivate(Sender: TObject); procedure edZoomKeyPress(Sender: TObject; var Key: char); public procedure ShowEditor(t: TfrView); override; end; {$ENDIF} implementation uses LR_Var, LR_Flds, LR_Const, LR_Utils; {$IFNDEF LCLNOGUI} {$R *.lfm} var frBarCodeForm: TfrBarCodeForm; {$ENDIF} const cbDefaultText ='12345678'; bcNames: array[bcCode_2_5_interleaved..{$IFNDEF BC_1_25}bcCodeEAN13{$ELSE}bcCodeEAN128C{$ENDIF}, 0..1] of string = (('2_5_interleaved', 'N'), ('2_5_industrial', 'N'), ('2_5_matrix', 'N'), ('Code39', 'A'), ('Code39 Extended', 'A'), ('Code128A', 'A'), ('Code128B', 'A'), ('Code128C', 'N'), ('Code93', 'A'), ('Code93 Extended', 'A'), ('MSI', 'N'), ('PostNet', 'N'), ('Codebar', 'A'), ('EAN8', 'N'), ('EAN13', 'N') {$IFDEF BC_1_25} , ('UPC A','N'), ('UPC E0','N'), ('UPC E1','N'), ('UPC SUPP 2','N'), ('UPC SUPP 5','N'), ('EAN128A','A'), ('EAN128B','A'), ('EAN128C','N') {$ENDIF} ); defaultFontSize = 10; {$PUSH} {$HINTS OFF} {$NOTES OFF} function isNumeric(St: String): Boolean; var {%H-}R: Double; E: Integer; begin Val(St, R, E); Result := (E = 0); end; {$POP} function TfrCustomBarCodeView.GetBarType: TBarcodeType; begin Result:=Param.cBarType; end; function TfrCustomBarCodeView.GetAngle: Double; begin Result := Param.cAngle; end; function TfrCustomBarCodeView.GetCheckSum: Boolean; begin Result:=Param.cCheckSum; end; function TfrCustomBarCodeView.GetShowText: Boolean; begin Result:=Param.cShowText; end; function TfrCustomBarCodeView.GetZoom: Double; begin Result:=Param.cRatio; end; procedure TfrCustomBarCodeView.SetAngle(AValue: Double); begin if (Param.cAngle<>AValue) and ((AValue=0.0) or (AValue=90.0) or (AValue=180.0) or (AValue=270.0)) then begin BeforeChange; Param.cAngle:=AValue; AfterChange; end; end; procedure TfrCustomBarCodeView.SetBarType(const AValue: TBarcodeType); begin if Param.cBarType<>AValue then begin BeforeChange; Param.cBarType:=aValue; AfterChange; end; end; procedure TfrCustomBarCodeView.SetCheckSum(const AValue: Boolean); begin if Param.cCheckSum<>AValue then begin BeforeChange; Param.cCheckSum:=aValue; AfterChange; end; end; procedure TfrCustomBarCodeView.SetShowText(const AValue: Boolean); begin if Param.cShowText<>AValue then begin BeforeChange; Param.cShowText:=aValue; AfterChange; end; end; procedure TfrCustomBarCodeView.SetZoom(const AValue: Double); begin if (Param.cRatio<>AValue) and ((AValue>=1.0)and(Avalue<=4.0)) then begin BeforeChange; Param.cRatio:=aValue; AfterChange; end; end; function TfrCustomBarCodeView.CreateBarcode: TLazreportBitmap; begin Result := nil; if Trim(Memo.Text) = '' then Exit; {Assign Barcode text} Memo1.Assign(Memo); if (Memo1.Text <> '') and (pos('[',Memo1.Strings[0])=0) and ((bcNames[Param.cBarType, 1] = 'A') or IsNumeric(Memo1.Strings[0]) or Barc.BarcodeTypeChecked(Param.cBarType) ) then begin BarC.Text := Memo1.Strings[0]; BarC.Checksum := Param.cCheckSum; end else begin BarC.Text := cbDefaultText; BarC.Checksum := true; end; if Trim(BarC.Text)='0' then Exit; {Barcode Properties} BarC.Left:= 0; BarC.Top := 0; BarC.Typ := Param.cBarType; BarC.Angle := Param.cAngle; BarC.Ratio := 2; // param.cRatio <>2 renders some codes unreadable BarC.Modul := 1; // param.cModul {$IFDEF BC_1_25} BarC.ShowTextPosition:=stpBottomCenter; BarC.ShowText := bcoNone; if FillColor=clNone then BarC.Color:=clWhite else BarC.Color:=FillColor; {$ELSE} BarC.ShowText:=False; {$ENDIF} {Barcode width is determined by type of barcode and text. Update object dimensions to suit barcode} if (Param.cAngle = 90) or (Param.cAngle = 270) then dy := BarC.Width else dx := BarC.Width; if (Param.cAngle = 90) or (Param.cAngle = 270) then BarC.Height := dx else BarC.Height := dy; if (BarC.Typ=bcCodePostNet) and (Param.cAngle=0) then begin BarC.Top:=BarC.Height; BarC.Height:=-BarC.Height; end; if Param.cAngle = 90 then begin BarC.Top:= Round(Height); BarC.Left:=0; end else if Param.cAngle = 180 then begin BarC.Top:= dy; BarC.Left:= dx; end else if Param.cAngle = 270 then begin BarC.Top:= 0; BarC.Left:= dx; end; result := TLazreportBitmap.Create; Result.Width:=dx; Result.Height:=dy; Result.Canvas.Brush.Style:=bsSolid; Result.Canvas.Brush.Color:=clWhite; Result.Canvas.FillRect(Rect(0,0,dx,dy)); try BarC.DrawBarcode(Result.Canvas); if BarC.Checksum then FText := BarC.CodeText else FText := BarC.Text; except on E: Exception do FText := E.Message end; end; function TfrCustomBarCodeView.CreateLabelFont(aCanvas: TCanvas) :TFont; begin with aCanvas do begin Result := TFont.Create; Result.Assign(aCanvas.Font); Result.Color := clBlack; Result.Name := 'Arial'; Result.Style := []; Result.Size := -defaultFontSize; if Param.cAngle = 90 then Result.Orientation := 900 else if Param.cAngle = 180 then Result.Orientation := 1800 else if Param.cAngle = 270 then Result.Orientation := 2700 else Result.Orientation := 0; end; end; procedure TfrCustomBarCodeView.DrawLabel(aCanvas: TCanvas; R: TRect); var fs: integer; begin if Param.cShowText then begin with aCanvas do begin fs := Font.Height; if Param.cAngle = 0 then begin Brush.Color:=clWhite; Brush.Style:=bsSolid; FillRect(Rect(R.Left,R.Top + dy-fs ,R.Right, R.Bottom)); TextOut(R.Left + (dx - TextWidth(FText)) div 2, R.Top + dy - fs, FText); end else if Param.cAngle = 90 then begin Brush.Color:=clWhite; Brush.Style:=bsSolid; FillRect(Rect(R.Left + dx - fs,R.Top,R.Right, R.Bottom)); Font.Orientation := 900; TextOut(R.Right - fs,R.Bottom - (dy - TextWidth(FText)) div 2, FText) end else if Param.cAngle = 180 then begin Brush.Color:=clWhite; Brush.Style:=bsSolid; FillRect(Rect(R.Left,R.Top,R.Right,R.Top + fs)); Font.Orientation := 1800; TextOut(R.left + (dx + TextWidth(FText)) div 2, R.Top + fs, FText); end else begin Brush.Color:=clWhite; Brush.Style:=bsSolid; Font.Orientation := 2700; FillRect(Rect(R.Left,R.Top,R.Left + fs,R.Bottom)); if (WidgetSet.LCLPlatform = lpGtk2) and IsPrinting then TextOut(R.Left + fs, R.Top + (dy -TextWidth(FText)) div 2, FText) end; end; end; end; constructor TfrCustomBarCodeView.Create(AOwnerPage: TfrPage); begin inherited Create(AOwnerPage); BarC := TBarCode.Create(nil); Param.cCheckSum := True; Param.cShowText := True; Param.cCadr := False; Param.cBarType := bcCode39; Param.cModul := 2; Param.cRatio := 1; Param.cAngle := 0; Memo.Add(cbDefaultText); Typ := gtAddIn; BaseName := 'Bar'; end; destructor TfrCustomBarCodeView.Destroy; begin BarC.Free; inherited Destroy; end; procedure TfrCustomBarCodeView.Assign(Source: TPersistent); begin inherited Assign(Source); if Source is TfrCustomBarCodeView then Param := TfrCustomBarCodeView(Source).Param; end; function TfrCustomBarCodeView.GenerateBitmap: TLazreportBitmap; var R: TRect; barcodeFont: TFont; oldFont: TFont; begin Result := CreateBarcode; R := Rect(0,0, Result.Width,Result.Height); barcodeFont := CreateLabelFont(Result.Canvas); try oldFont := Result.Canvas.Font; Result.Canvas.Font := barcodeFont; DrawLabel(Result.Canvas,r) finally Result.Canvas.Font := oldFont; barcodeFont.Free end; end; procedure TfrCustomBarCodeView.LoadFromStream(Stream:TStream); begin inherited LoadFromStream(Stream); Stream.Read(Param, SizeOf(Param)); end; procedure TfrCustomBarCodeView.SaveToStream(Stream:TStream); begin inherited SaveToStream(Stream); Stream.Write(Param, SizeOf(Param)); end; procedure TfrCustomBarCodeView.Draw(aCanvas:TCanvas); var Bmp : TLazreportBitmap; R: TRect; fh: integer; barcodeFont: TFont; oldFont: TFont; begin BeginDraw(aCanvas); Bmp := CreateBarcode; if Bmp <> nil then try // dx/dy is calculated in CreateBarCode using as base // barcdode type, angle, zoom and data if (Param.cAngle = 90) or (Param.cAngle = 270) then dy := round(dy * param.cRatio) else dx := round(dx * Param.cRatio); CalcGaps; ShowBackground; if Param.cShowText then begin barcodeFont := CreateLabelFont(aCanvas); try oldFont := aCanvas.Font; aCanvas.Font := barcodeFont; if not IsPrinting then begin if (Param.cAngle = 90) or (Param.cAngle = 270) then ACanvas.Font.Height := -Round(ACanvas.Font.Size * ACanvas.Font.PixelsPerInch / 72 * ScaleX) else ACanvas.Font.Height := -Round(ACanvas.Font.Size * ACanvas.Font.PixelsPerInch / 72 * ScaleY); fh := Round(aCanvas.Font.Height); end else fh := aCanvas.Font.Height; if (Param.cAngle = 90) then R := Rect(DRect.Left,DRect.Top, DRect.Right - fh, DRect.Bottom) else if (Param.cAngle = 180) then R := Rect(DRect.Left,DRect.Top + fh, DRect.Right , DRect.Bottom) else if (Param.cAngle = 270) then R := Rect(DRect.Left + fh, DRect.Top, DRect.Right, DRect.Bottom) else R := Rect(DRect.Left,DRect.Top, DRect.Right , DRect.Bottom - fh); {$IFDEF LCLNOGUI} TVirtualCanvas(aCanvas).StretchDraw(R,Bmp); {$ELSE} aCanvas.StretchDraw(R,Bmp); {$ENDIF} DrawLabel(aCanvas, DRect); finally aCanvas.Font := oldFont; barcodeFont.Free end; end else {$IFDEF LCLNOGUI} TVirtualCanvas(aCanvas).StretchDraw(DRect,Bmp); {$ELSE} aCanvas.StretchDraw(DRect,Bmp); {$ENDIF} ShowFrame; finally Bmp.Free; RestoreCoord; end; end; procedure TfrCustomBarCodeView.Print(Stream: TStream); begin BeginDraw(Canvas); Memo1.Assign(Memo); CurReport.InternalOnEnterRect(Memo1, Self); frInterpretator.DoScript(Script); if not Visible then Exit; if Memo1.Count > 0 then if (Length(Memo1[0]) > 0) and (Pos('[',Memo1[0])<>0) then Memo1[0] := frParser.Calc(Memo1[0]); Stream.Write(Typ, 1); frWriteString(Stream, ClassName); SaveToStream(Stream); end; procedure TfrCustomBarCodeView.DefinePopupMenu(Popup: TPopupMenu); begin // no specific items in popup menu end; procedure TfrCustomBarCodeView.LoadFromXML(XML: TLrXMLConfig; const Path: String); begin inherited LoadFromXML(XML, Path); RestoreProperty('BarType',XML.GetValue(Path+'BarCode/BarType','')); RestoreProperty('ShowText',XML.GetValue(Path+'BarCode/ShowText','')); RestoreProperty('CheckSum',XML.GetValue(Path+'BarCode/CheckSum','')); RestoreProperty('Zoom',XML.GetValue(Path+'BarCode/Zoom','1')); RestoreProperty('Angle',XML.GetValue(Path+'BarCode/Angle','0')); end; procedure TfrCustomBarCodeView.SaveToXML(XML: TLrXMLConfig; const Path: String); begin inherited SaveToXML(XML, Path); XML.SetValue(Path+'BarCode/BarType', GetSaveProperty('BarType')); XML.SetValue(Path+'BarCode/ShowText', GetSaveProperty('ShowText')); XML.SetValue(Path+'BarCode/CheckSum', GetSaveProperty('CheckSum')); XML.SetValue(Path+'BarCode/Zoom', GetSaveProperty('Zoom')); XML.SetValue(Path+'BarCode/Angle', GetSaveProperty('Angle')); end; {$IFNDEF LCLNOGUI} //-------------------------------------------------------------------------- procedure TfrBarCodeForm.FormCreate(Sender: TObject); var i: TBarcodeType; begin CbType.Items.Clear; for i := bcCode_2_5_interleaved to {$IFNDEF BC_1_25}bcCodeEAN13{$ELSE}bcCodeEAN128C{$ENDIF} do cbType.Items.Add(bcNames[i, 0]); cbType.ItemIndex := 0; Caption := sBarCodeFormTitle; Label1.Caption := sBarCodeFormCode; Label2.Caption := sBarCodeFormType; GroupBox1.Caption := sBarCodeFormOpts; ckCheckSum.Caption := sBarCodeFormChksum; ckViewText.Caption := sBarCodeFormReadable; DBBtn.Hint := sBarCodeFormDbFld; VarBtn.Hint := sBarCodeFormVar; GroupBox2.Caption := sBarCodeFormRotate; labZoom.Caption:=sBarCodeZoom; end; procedure TfrBarCodeForm.FormClose(Sender: TObject; var CloseAction: TCloseAction); begin if ModalResult = mrOk then bOkClick(nil); end; procedure TfrBarCodeForm.FormActivate(Sender: TObject); begin M1.SetFocus; end; procedure TfrBarCodeForm.edZoomKeyPress(Sender: TObject; var Key: char); begin If (Key>#31) and not (Key in ['0'..'9','.']) then {AJW} Key:=#0; end; procedure TfrBarCodeForm.ShowEditor(t:TfrView); var tmp:Double; begin if t.Memo.Count > 0 then M1.Text := t.Memo.Strings[0]; with t as TfrBarCodeView do begin cbType.ItemIndex := ord(Param.cBarType); ckCheckSum.checked := Param.cCheckSum; ckViewText.Checked := Param.cShowText; 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; edZoom.Text:=SysUtils.Format('%.1f',[Param.cRatio]); if ShowModal = mrOk then begin Memo.Clear; Memo.Add(M1.Text); CheckSum := ckCheckSum.Checked; ShowText := ckViewText.Checked; BarType := TBarcodeType(cbType.ItemIndex); tmp := StrToFloatDef(edZoom.Text,1); if tmp<1.0 then tmp:=1.0; Zoom := tmp; if RB1.Checked then Angle := 0 else if RB2.Checked then Angle := 90 else if RB3.Checked then Angle := 180 else Angle := 270; end; end; end; procedure TfrBarCodeForm.VarBtnClick(Sender: TObject); begin frVarForm := TfrVarForm.Create(nil); with frVarForm do if ShowModal = mrOk then if SelectedItem <> '' then M1.Text := '[' + SelectedItem + ']'; frVarForm.Free; M1.SetFocus; end; procedure TfrBarCodeForm.DBBtnClick(Sender: TObject); begin frFieldsForm := TfrFieldsForm.Create(nil); with frFieldsForm do if ShowModal = mrOk then if DBField <> '' then M1.Text := '[' + DBField + ']'; frFieldsForm.Free; M1.SetFocus; end; procedure TfrBarCodeForm.bOkClick(Sender: TObject); var bc: TBarCode; Bmp: TBitmap; begin Bmp := nil; bc := TBarCode.Create(nil); try if Pos('[',M1.Text) <> 0 then begin bc.Text := cbDefaultText; bc.checksum := true end else begin bc.Text := M1.Text; bc.CheckSum := ckCheckSum.Checked; end; bc.Ratio := StrToFloatDef(edZoom.Text,1); bc.Typ := TBarcodeType(cbType.ItemIndex); Bmp := TBitmap.Create; Bmp.Width := 16; Bmp.Height := 16; try Bmp.Canvas.Brush.Style:=bsSolid; Bmp.Canvas.Brush.Color:=clWhite; Bmp.Canvas.FillRect(Rect(0,0,Bmp.Width,Bmp.Height)); bc.DrawBarcode(Bmp.Canvas); except MessageDlg(sBarcodeError,mtError,[mbOk],0); ModalResult := 0; end; finally Bmp.Free; bc.Free; end; end; procedure InitializeBarcAddin; begin if not assigned(frBarCodeForm) {and not (csDesigning in ComponentState)} then begin frBarCodeForm := TfrBarCodeForm.Create(nil); frSetAddinEditor(TfrBarcodeView, frBarcodeForm); frSetAddinIcon(TfrBarcodeView, frBarCodeForm.Image1.Picture.Bitmap); frSetAddinHint(TfrBarcodeView, sInsBarcode); end; end; {$ENDIF} { TfrBarCodeObject } constructor TfrBarCodeObject.Create(aOwner: TComponent); begin inherited Create(aOwner); {$IFNDEF LCLNOGUI} InitializeBarcAddin; {$ENDIF} end; {$IFNDEF LCLNOGUI} initialization frBarcodeForm := nil; frRegisterObject(TfrBarCodeView, nil, '', nil, @InitializeBarcAddin); finalization if Assigned(frBarCodeForm) then frBarCodeForm.Free; {$ELSE} initialization frRegisterObject(TfrBarCodeView, nil, '', nil); {$ENDIF} end.