FastReport_2022_VCL/LibD28/frxDMPClass.pas
2024-01-01 16:13:08 +01:00

637 lines
16 KiB
ObjectPascal

{******************************************}
{ }
{ FastReport VCL }
{ DotMatrix printers stuff }
{ }
{ Copyright (c) 1998-2021 }
{ by Fast Reports Inc. }
{ }
{******************************************}
unit frxDMPClass;
interface
{$I frx.inc}
uses
SysUtils, {$IFNDEF FPC}Windows, Messages, {$ENDIF}Classes, Graphics, Controls, Forms, Dialogs,
frxClass, Variants
{$IFDEF DELPHI16}
, System.UITypes
{$ENDIF};
type
/// <summary>
/// Dot-matrix font style.
/// </summary>
TfrxDMPFontStyle = (fsxBold, fsxItalic, fsxUnderline, fsxSuperScript,
fsxSubScript, fsxCondensed, fsxWide, fsx12cpi, fsx15cpi);
TfrxDMPFontStyles = set of TfrxDMPFontStyle;
{$IFDEF FR_COM}
TfrxDMPMemoView = class(TfrxCustomMemoView, IfrxDMPMemoView)
{$ELSE}
/// <summary>
/// The TfrxDMPMemoView is similar to TfrxMemoView, but is intended for
/// dot-matrix mode.
/// </summary>
TfrxDMPMemoView = class(TfrxCustomMemoView)
{$ENDIF}
private
FFontStyle: TfrxDMPFontStyles;
FTruncOutboundText: Boolean;
procedure SetFontStyle(const Value: TfrxDMPFontStyles);
{$IFDEF FR_COM}
function Get_FontStyle(out Value: frxFontStyle): HResult; stdcall;
function Set_FontStyle(Value: frxFontStyle): HResult; stdcall;
{$ENDIF}
function IsFontStyleStored: Boolean;
protected
procedure DrawFrame; override;
procedure SetLeft(Value: Extended); override;
procedure SetTop(Value: Extended); override;
procedure SetWidth(Value: Extended); override;
procedure SetHeight(Value: Extended); override;
procedure SetParentFont(const Value: Boolean); override;
public
constructor Create(AOwner: TComponent); override;
class function GetDescription: String; override;
procedure ResetFontOptions;
procedure SetBoundsDirect(ALeft, ATop, AWidth, AHeight: Extended);
function CalcHeight: Extended; override;
function CalcWidth: Extended; override;
//function Diff(AComponent: TfrxComponent): String; override;
function GetoutBoundText: String;
function IsEMFExportable: Boolean; override;
published
property AutoWidth;
property AllowExpressions;
property DataField;
property DataSet;
property DataSetName;
property DisplayFormat;
property ExpressionDelimiters;
property FlowTo;
/// <summary>
/// Dot-matrix font style.
/// </summary>
property FontStyle: TfrxDMPFontStyles read FFontStyle write SetFontStyle
stored IsFontStyleStored;
property Frame;
property HAlign;
property HideZeros;
property Memo;
property ParentFont;
property RTLReading;
property SuppressRepeated;
property WordWrap;
/// <summary>
/// It is used for cutting a text exceeding the bounds of objects if
/// words transfer function is switched off.
/// </summary>
property TruncOutboundText: Boolean read FTruncOutboundText write FTruncOutboundText;
property VAlign;
end;
{$IFDEF FR_COM}
TfrxDMPLineView = class(TfrxCustomLineView, IfrxDMPLineView)
{$ELSE}
/// <summary>
/// The TfrxDMPLineView is similar to TfrxLineView, but is intended for
/// dot-matrix mode.
/// </summary>
TfrxDMPLineView = class(TfrxCustomLineView)
{$ENDIF}
private
FFontStyle: TfrxDMPFontStyles;
procedure SetFontStyle(const Value: TfrxDMPFontStyles);
function IsFontStyleStored: Boolean;
{$IFDEF FR_COM}
function Get_FontStyle(out Value: frxFontStyle): HResult; stdcall;
function Set_FontStyle(Value: frxFontStyle): HResult; stdcall;
{$ENDIF}
protected
procedure SetLeft(Value: Extended); override;
procedure SetTop(Value: Extended); override;
procedure SetWidth(Value: Extended); override;
procedure SetParentFont(const Value: Boolean); override;
public
class function GetDescription: String; override;
//function Diff(AComponent: TfrxComponent): String; override;
published
/// <summary>
/// Dot-matrix font style.
/// </summary>
property FontStyle: TfrxDMPFontStyles read FFontStyle write SetFontStyle
stored IsFontStyleStored;
property ParentFont;
end;
{$IFDEF FR_COM}
TfrxDMPCommand = class(TfrxView, IfrxDMPCommand)
{$ELSE}
/// <summary>
/// The TfrxDMPCommand component can execute an ESC command in the
/// dot-matrix mode.
/// </summary>
TfrxDMPCommand = class(TfrxView)
{$ENDIF}
private
FCommand: String;
{$IFDEF FR_COM}
function Get_Command(out Value: WideString): HResult; stdcall;
function Set_Command(const Value: WideString): HResult; stdcall;
{$ENDIF}
protected
procedure SetLeft(Value: Extended); override;
procedure SetTop(Value: Extended); override;
public
class function GetDescription: String; override;
//function Diff(AComponent: TfrxComponent): String; override;
function ToChr: String;
published
/// <summary>
/// The ESC command. You can use two formats of command: 1B40 or #27#64.
/// </summary>
property Command: String read FCommand write FCommand;
end;
{$IFDEF FR_COM}
TfrxDMPPage = class(TfrxReportPage, IfrxDMPPage)
{$ELSE}
/// <summary>
/// The TfrxDMPPage is similar to TfrxReportPage, but is intended for
/// dot-matrix mode.
/// </summary>
TfrxDMPPage = class(TfrxReportPage)
{$ENDIF}
private
FFontStyle: TfrxDMPFontStyles;
procedure SetFontStyle(const Value: TfrxDMPFontStyles);
{$IFDEF FR_COM}
function Get_FontStyle(out Value: frxFontStyle): HResult; stdcall;
function Set_FontStyle(Value: frxFontStyle): HResult; stdcall;
{$ENDIF}
protected
procedure SetPaperHeight(const Value: Extended); override;
procedure SetPaperWidth(const Value: Extended); override;
procedure SetPaperSize(const Value: Integer); override;
public
constructor Create(AOwner: TComponent); override;
procedure SetDefaults; override;
procedure ResetFontOptions;
published
/// <summary>
/// Dot-matrix font style.
/// </summary>
property FontStyle: TfrxDMPFontStyles read FFontStyle write SetFontStyle;
end;
implementation
uses frxRes, frxDsgnIntf, frxXML;
function DiffFontStyle(f: TfrxDMPFontStyles): String;
var
fs: Integer;
begin
fs := 0;
if fsxBold in f then fs := 1;
if fsxItalic in f then fs := fs or 2;
if fsxUnderline in f then fs := fs or 4;
if fsxSuperScript in f then fs := fs or 8;
if fsxSubScript in f then fs := fs or 16;
if fsxCondensed in f then fs := fs or 32;
if fsxWide in f then fs := fs or 64;
if fsx12cpi in f then fs := fs or 128;
if fsx15cpi in f then fs := fs or 256;
Result := ' FontStyle="' + String(IntToStr(fs)) + '"';
end;
{ TfrxDMPMemoView }
constructor TfrxDMPMemoView.Create(AOwner: TComponent);
begin
inherited;
ResetFontOptions;
end;
class function TfrxDMPMemoView.GetDescription: String;
begin
Result := frxResources.Get('obDMPText');
end;
procedure TfrxDMPMemoView.ResetFontOptions;
begin
Font.OnChange := nil;
Font.Name := 'Courier New';
Font.Size := 12;
Font.Style := [];
if fsxBold in FFontStyle then
Font.Style := Font.Style + [fsBold];
if fsxItalic in FFontStyle then
Font.Style := Font.Style + [fsItalic];
if fsxUnderline in FFontStyle then
Font.Style := Font.Style + [fsUnderline];
CharSpacing := 0;
LineSpacing := 1;
GapX := 0;
GapY := 0;
end;
procedure TfrxDMPMemoView.SetHeight(Value: Extended);
begin
Value := Round(Value / fr1CharY) * fr1CharY;
inherited;
end;
procedure TfrxDMPMemoView.SetLeft(Value: Extended);
begin
if Align = baRight then
Value := Trunc(Value / fr1CharX) * fr1CharX else
Value := Round(Value / fr1CharX) * fr1CharX;
inherited;
end;
procedure TfrxDMPMemoView.SetTop(Value: Extended);
begin
Value := Round(Value / fr1CharY) * fr1CharY;
inherited;
end;
procedure TfrxDMPMemoView.SetWidth(Value: Extended);
begin
Value := Round(Value / fr1CharX) * fr1CharX;
inherited;
end;
procedure TfrxDMPMemoView.SetFontStyle(const Value: TfrxDMPFontStyles);
begin
FFontStyle := Value;
ParentFont := False;
ResetFontOptions;
end;
procedure TfrxDMPMemoView.SetParentFont(const Value: Boolean);
begin
inherited;
if Value then
if Page is TfrxDMPPage then
FFontStyle := TfrxDMPPage(Page).FontStyle;
end;
function TfrxDMPMemoView.IsEMFExportable: Boolean;
begin
Result := AllowVectorExport;
end;
function TfrxDMPMemoView.IsFontStyleStored: Boolean;
begin
Result := not ParentFont;
end;
procedure TfrxDMPMemoView.DrawFrame;
begin
FX := Round((AbsLeft - fr1CharX / 2) * FScaleX + FOffsetX);
FY := Round((AbsTop - fr1CharY / 2) * FScaleY + FOffsetY);
FX1 := Round((AbsLeft + Width + fr1CharX / 2) * FScaleX + FOffsetX);
FY1 := Round((AbsTop + Height + fr1CharY / 2) * FScaleY + FOffsetY);
inherited;
end;
function TfrxDMPMemoView.CalcHeight: Extended;
begin
Result := inherited CalcHeight;
Result := Round(Result / fr1CharY) * fr1CharY;
end;
function TfrxDMPMemoView.CalcWidth: Extended;
begin
Result := inherited CalcWidth;
Result := Round(Result / fr1CharX) * fr1CharX;
end;
//function TfrxDMPMemoView.Diff(AComponent: TfrxComponent): String;
//var
// m: TfrxDMPMemoView;
//begin
// Result := inherited Diff(AComponent);
// m := TfrxDMPMemoView(AComponent);
// if FFontStyle <> m.FontStyle then
// Result := Result + DiffFontStyle(FFontStyle);
//end;
procedure TfrxDMPMemoView.SetBoundsDirect(ALeft, ATop, AWidth, AHeight: Extended);
begin
inherited SetLeft(ALeft);
inherited SetTop(ATop);
inherited SetWidth(AWidth);
inherited SetHeight(AHeight);
end;
{$IFDEF FR_COM}
function TfrxDMPMemoView.Get_FontStyle(out Value: frxFontStyle): HResult;
begin
Value := PInteger(@FontStyle)^;
Result := S_OK;
end;
function TfrxDMPMemoView.Set_FontStyle(Value: frxFontStyle): HResult; stdcall;
type
PfrxDMPFontStyles = ^ TfrxDMPFontStyles;
var
dst: TfrxDMPFontStyles;
src: Integer;
begin
src := Value;
dst := PfrxDMPFontStyles(@src)^;
FontStyle := dst;
Result := S_OK;
end;
{$ENDIF}
function TfrxDMPMemoView.GetoutBoundText: String;
var
idx, mH: Integer;
begin
Result := '';
mH := Round(Height/fr1CharY);
for idx := 0 to Memo.Count - 1 do
if mH >= idx + 1 then
begin
Result := Result + Copy(Memo.Strings[idx], 1, Round(Width/fr1CharX)) + #13#10;
end;
end;
{ TfrxDMPLineView }
class function TfrxDMPLineView.GetDescription: String;
begin
Result := frxResources.Get('obDMPLine');
end;
procedure TfrxDMPLineView.SetLeft(Value: Extended);
begin
if Value < 0 then
Value := Trunc(Value / fr1CharX) * fr1CharX - fr1CharX / 2
else if Align = baRight then
Value := Round(Value / fr1CharX) * fr1CharX - fr1CharX / 2
else
Value := Trunc(Value / fr1CharX) * fr1CharX + fr1CharX / 2;
inherited;
end;
procedure TfrxDMPLineView.SetTop(Value: Extended);
begin
Value := Trunc(Value / fr1CharY) * fr1CharY + fr1CharY / 2;
inherited;
end;
procedure TfrxDMPLineView.SetWidth(Value: Extended);
begin
if Align = baWidth then
Value := Trunc(Value / fr1CharX) * fr1CharX
else
Value := Round(Value / fr1CharX) * fr1CharX;
inherited;
end;
procedure TfrxDMPLineView.SetFontStyle(const Value: TfrxDMPFontStyles);
begin
FFontStyle := Value;
ParentFont := False;
end;
procedure TfrxDMPLineView.SetParentFont(const Value: Boolean);
begin
inherited;
if Value then
if Page is TfrxDMPPage then
FFontStyle := TfrxDMPPage(Page).FontStyle;
end;
function TfrxDMPLineView.IsFontStyleStored: Boolean;
begin
Result := not ParentFont;
end;
//function TfrxDMPLineView.Diff(AComponent: TfrxComponent): String;
//var
// l: TfrxDMPLineView;
//begin
// Result := inherited Diff(AComponent);
// l := TfrxDMPLineView(AComponent);
// if FFontStyle <> l.FontStyle then
// Result := Result + DiffFontStyle(FFontStyle);
//end;
{$IFDEF FR_COM}
function TfrxDMPLineView.Get_FontStyle(out Value: frxFontStyle): HResult;
begin
Value := PInteger(@FontStyle)^;
Result := S_OK;
end;
function TfrxDMPLineView.Set_FontStyle(Value: frxFontStyle): HResult; stdcall;
type
PfrxDMPFontStyles = ^ TfrxDMPFontStyles;
var
dst: TfrxDMPFontStyles;
src: Integer;
begin
src := Value;
dst := PfrxDMPFontStyles(@src)^;
FontStyle := dst;
Result := S_OK;
end;
{$ENDIF}
{ TfrxDMPCommand }
class function TfrxDMPCommand.GetDescription: String;
begin
Result := frxResources.Get('obDMPCmd');
end;
procedure TfrxDMPCommand.SetLeft(Value: Extended);
begin
Value := Round(Value / fr1CharX) * fr1CharX;
inherited;
end;
procedure TfrxDMPCommand.SetTop(Value: Extended);
begin
Value := Round(Value / fr1CharY) * fr1CharY;
inherited;
end;
//function TfrxDMPCommand.Diff(AComponent: TfrxComponent): String;
//begin
// Result := inherited Diff(AComponent);
// if FCommand <> TfrxDMPCommand(AComponent).Command then
// Result := Result + frxStrToXML(FCommand);
//end;
function TfrxDMPCommand.ToChr: String;
var
i: Integer;
s, s1: String;
begin
Result := '';
s := FCommand;
s1 := '';
if Pos('#', s) = 1 then
begin
s := s + '#';
for i := 2 to Length(s) do
if s[i] = '#' then
begin
Result := Result + Chr(StrToInt(s1));
s1 := '';
end
else
s1 := s1 + s[i];
end
else
begin
for i := 1 to Length(s) do
begin
s1 := s1 + s[i];
if i mod 2 = 0 then
begin
Result := Result + Chr(StrToInt('$' + s1));
s1 := '';
end;
end;
end;
end;
{$IFDEF FR_COM}
function TfrxDMPCommand.Get_Command(out Value: WideString): HResult;
begin
Value := Command;
Result := S_OK;
end;
function TfrxDMPCommand.Set_Command(const Value: WideString): HResult;
begin
Command := Value;
Result := S_OK;
end;
{$ENDIF}
{ TfrxDMPPage }
constructor TfrxDMPPage.Create(AOwner: TComponent);
begin
inherited;
ResetFontOptions;
end;
procedure TfrxDMPPage.ResetFontOptions;
begin
Font.OnChange := nil;
Font.Name := 'Courier New';
Font.Size := 12;
Font.Style := [];
if fsxBold in FFontStyle then
Font.Style := Font.Style + [fsBold];
if fsxItalic in FFontStyle then
Font.Style := Font.Style + [fsItalic];
if fsxUnderline in FFontStyle then
Font.Style := Font.Style + [fsUnderline];
end;
procedure TfrxDMPPage.SetDefaults;
begin
inherited;
LeftMargin := fr1CharX / fr01cm;
RightMargin := fr1CharX / fr01cm;
TopMargin := fr1CharY / fr01cm;
BottomMargin := fr1CharY / fr01cm;
FPaperWidth := Trunc(FPaperWidth * fr01cm / fr1CharX) * fr1CharX / fr01cm;
FPaperHeight := Trunc(FPaperHeight * fr01cm / fr1CharY) * fr1CharY / fr01cm;
UpdateDimensions;
end;
procedure TfrxDMPPage.SetFontStyle(const Value: TfrxDMPFontStyles);
var
i: Integer;
l: TList;
c: TfrxComponent;
begin
FFontStyle := Value;
ResetFontOptions;
l := AllObjects;
for i := 0 to l.Count - 1 do
begin
c := l[i];
if c.ParentFont then
c.ParentFont := True;
end;
end;
procedure TfrxDMPPage.SetPaperHeight(const Value: Extended);
begin
inherited;
FPaperHeight := Round(FPaperHeight * fr01cm / fr1CharY) * fr1CharY / fr01cm;
UpdateDimensions;
end;
procedure TfrxDMPPage.SetPaperSize(const Value: Integer);
begin
inherited;
FPaperWidth := Round(FPaperWidth * fr01cm / fr1CharX) * fr1CharX / fr01cm;
FPaperHeight := Round(FPaperHeight * fr01cm / fr1CharY) * fr1CharY / fr01cm;
UpdateDimensions;
end;
procedure TfrxDMPPage.SetPaperWidth(const Value: Extended);
begin
inherited;
FPaperWidth := Round(FPaperWidth * fr01cm / fr1CharX) * fr1CharX / fr01cm;
UpdateDimensions;
end;
{$IFDEF FR_COM}
function TfrxDMPPage.Get_FontStyle(out Value: frxFontStyle): HResult;
begin
Value := PInteger(@FontStyle)^;
Result := S_OK;
end;
function TfrxDMPPage.Set_FontStyle(Value: frxFontStyle): HResult; stdcall;
type
PfrxDMPFontStyles = ^ TfrxDMPFontStyles;
var
dst: TfrxDMPFontStyles;
src: Integer;
begin
src := Value;
dst := PfrxDMPFontStyles(@src)^;
FontStyle := dst;
Result := S_OK;
end;
{$ENDIF}
initialization
RegisterClasses([TfrxDMPPage]);
frxObjects.RegisterObject1(TfrxDMPMemoView, nil, '', '', 0, 2, [ctDMP]);
frxObjects.RegisterObject1(TfrxDMPLineView, nil, '', '', 0, 5, [ctDMP]);
frxObjects.RegisterObject1(TfrxDMPCommand, nil, '', '', 0, 21, [ctDMP]);
finalization
UnRegisterClasses([TfrxDMPPage]);
frxObjects.UnRegister(TfrxDMPMemoView);
frxObjects.UnRegister(TfrxDMPLineView);
frxObjects.UnRegister(TfrxDMPCommand);
end.