gmresource.pas

GmPrintSuite 2.96.7] a

{******************************************************************************}
{                                                                              }
{                              GmResource.pas                                  }
{                                                                              }
{           Copyright (c) 2003 Graham Murt  - www.MurtSoft.co.uk               }
{                                                                              }
{   Feel free to e-mail me with any comments, suggestions, bugs or help at:    }
{                                                                              }
{                           [e-mail]                              }
{                                                                              }
{******************************************************************************}

unit GmResource;

interface

{$I GMPS.INC}

uses Windows, SyncObjs, Forms, Classes, Graphics, GmTypes,
  {$IFDEF D5+}
  contnrs,
  {$ENDIF}
  StdCtrls;

type
  TGmNeedRichEditEvent     = procedure(Sender: TObject; var ARichEdit: TCustomMemo) of object;

  // *** TGmObjectList ***

  {$IFDEF D5+}
  TGmObjectList = TObjectList;
  {$ELSE}
  TGmObjectList = class(TObject)
  private
    FList: TList;
    function GetCount: integer;
    function GetItem(index: integer): TObject;
    procedure SetItem(index: integer; AObject: TObject);
  public
    constructor Create(const OwnsObjects: Boolean = True);
    destructor Destroy; override;
    function Extract(AObject: TObject): TObject;
    function IndexOf(AObject: TObject): integer;
    procedure Add(AObject: TObject);
    procedure Clear;
    procedure Delete(index: integer);
    procedure Insert(Index: integer; AObject: TObject);
    property Count: integer read GetCount;
    property Items[index: integer]: TObject read GetItem write SetItem; default;
  end;
  {$ENDIF}

  // *** TGmReferenceList ***

  TGmReferenceList = class(TStringList)
  private
    function GetValue(index: integer): integer;
    procedure SetValue(index: integer; Value: integer);
  public
    procedure AddValue(Value: integer);
    procedure DecValueAtIndex(index: integer);
    procedure IncValueAtIndex(index: integer);
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToStream(Stream: TStream); override;
    property Value[index: integer]: integer read GetValue write SetValue; default;
  end;

  //----------------------------------------------------------------------------

  // *** TGmResourceList ***

  TGmResourceList = class(TGmObjectList)
  private
    FReferenceList: TGmReferenceList;
  public
    constructor Create; virtual;
    destructor Destroy; override;
    procedure DeleteResource(AResource: TObject);
    procedure LoadFromStream(Stream: TStream); virtual; abstract;
    procedure SaveToStream(Stream: TStream); virtual; abstract;
    property ReferenceList: TGmReferenceList read FReferenceList;
  end;

  //----------------------------------------------------------------------------

  // *** TGmBrush ***

  TGmBrush = class(TPersistent)
  private
    FColor: TColor;
    FStyle: TBrushStyle;
    // events...
    FOnChange: TNotifyEvent;
    procedure Changed;
    procedure SetColor(const Value: TColor);
    procedure SetStyle(const Value: TBrushStyle);
  public
    constructor Create;
    procedure Assign(Source: TPersistent); override;
    procedure AssignToCanvas(ACanvas: TCanvas);
    procedure LoadFromStream(Stream: TStream);
    procedure SaveToStream(Stream: TStream);
    property Color: TColor read FColor write SetColor default clWhite;
    property Style: TBrushStyle read FStyle write SetStyle default bsClear;
    // events...
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
  end;

  //----------------------------------------------------------------------------

  // *** TGmBrushList ***

  TGmBrushList = class(TGmResourceList)
  private
    function GetBrush(index: integer): TGmBrush;
    procedure SetBrush(index: integer; ABrush: TGmBrush);
  public
    function AddBrush(ABrush: TGmBrush): TGmBrush;
    function IndexOf(ABrush: TGmBrush): integer;
    //procedure DeleteBrush(ABrush: TGmBrush);
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToStream(Stream: TStream); override;
    property Brush[index: integer]: TGmBrush read GetBrush write SetBrush; default;
  end;

  //----------------------------------------------------------------------------

  // *** TGmFont ***

  TGmFont = class(TPersistent)
  private
    FSize: integer;
    FStyle: TFontStyles;
    FAngle: Extended;
    FColor: TColor;
    FCharset: TFontCharset;
    FName: string;
    // events...
    FOnChange: TNotifyEvent;
    procedure Changed;
    procedure SetSize(Value: integer);
    procedure SetStyle(Value: TFontStyles);
    procedure SetAngle(Value: Extended);
    procedure SetColor(Value: TColor);
    procedure SetCharset(Value: TFontCharset);
    procedure SetName(Value: string);
  public
    constructor Create;
    procedure Assign(Source: TPersistent); override;
    procedure AssignToCanvas(ACanvas: TCanvas);
    procedure AssignToFont(AFont: TFont);
    procedure LoadFromStream(Stream: TStream);
    procedure SaveToStream(Stream: TStream);
    property Size: integer read FSize write SetSize default 12;
    property Style: TFontStyles read FStyle write SetStyle default [];
    property Angle: Extended read FAngle write SetAngle;
    property Color: TColor read FColor write SetColor default clBlack;
    property Charset: TFontCharset read FCharset write SetCharset default DEFAULT_CHARSET;
    property Name: string read FName write SetName;
    // events...
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
  end;

  //----------------------------------------------------------------------------

  // *** TGmFontList ***

  TGmFontList = class(TGmResourceList)
  private
    function GetFont(index: integer): TGmFont;
    procedure SetFont(index: integer; AFont: TGmFont);
  public
    function AddFont(AFont: TGmFont): TGmFont;
    function IndexOf(AFont: TGmFont): integer;
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToStream(Stream: TStream); override;
    property Font[index: integer]: TGmFont read GetFont write SetFont; default;
  end;

  //----------------------------------------------------------------------------

  // *** TGmPen ***

  TGmPen = class(TPersistent)
  private
    FWidth: integer;
    FColor: TColor;
    FStyle: TPenStyle;
    FMode: TPenMode;
    // events...
    FOnChange: TNotifyEvent;
    procedure Changed;
    procedure SetColor(Value: TColor);
    procedure SetMode(Value: TPenMode);
    procedure SetStyle(Value: TPenStyle);
    procedure SetWidth(Value: integer);
  public
    procedure Assign(Source: TPersistent); override;
    procedure AssignToCanvas(Canvas: TCanvas; Ppi: integer);
    procedure AssignToPen(APen: TPen);
    procedure LoadFromStream(Stream: TStream);
    procedure SaveToStream(Stream: TStream);
    property Color: TColor read FColor write SetColor default clBlack;
    property Mode: TPenMode read FMode write SetMode default pmCopy;
    property Style: TPenStyle read FStyle write SetStyle default psSolid;
    property Width: integer read FWidth write SetWidth;
    // events...
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
  end;

  //----------------------------------------------------------------------------

  // *** TGmPenList ***

  TGmPenList = class(TGmResourceList)
  private
    function GetPen(index: integer): TGmPen;
    procedure SetPen(index: integer; APen: TGmPen);
  public
    function AddPen(APen: TGmPen): TGmPen;
    function IndexOf(APen: TGmPen): integer;
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToStream(Stream: TStream); override;
    property Pen[index: integer]: TGmPen read GetPen write SetPen; default;
  end;

  //----------------------------------------------------------------------------

  
  // *** TGmGraphicList ***

  TGmGraphicList = class(TGmResourceList)
  private
    FGraphicCompare: Boolean;
    function GetGraphic(index: integer): TGraphic;
    function GetGraphicType(AGraphic: TGraphic): TGmGraphicType;
    procedure SetGraphic(index: integer; Graphic: TGraphic);
  public
    constructor Create; override;
    function AddGraphic(AGraphic: TGraphic): TGraphic;
    function IndexOf(AGraphic: TGraphic): integer;
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToStream(Stream: TStream); override;
    property GraphicCompare: Boolean read FGraphicCompare write FGraphicCompare default True;
    property Graphic[index: integer]: TGraphic read GetGraphic write SetGraphic;
  end;

  //----------------------------------------------------------------------------

  // *** TGmCustomMemoList ***

  TGmCustomMemoList = class(TGmResourceList)
  private
    FParentForm: TForm;
    // events...
    FNeedRichEdit: TGmNeedRichEditEvent;
    function GetMemo(index: integer): TCustomMemo;
    function GetMemoType(AMemo: TCustomMemo): TGmMemoType;
    procedure SetMemo(index: integer; AMemo: TCustomMemo);
  public
    constructor Create; override;
    destructor Destroy; override;
    function AddMemo(AMemo: TCustomMemo): TCustomMemo;
    function CreateMemo: TCustomMemo;
    function IndexOf(AMemo: TCustomMemo): integer;
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToStream(Stream: TStream); override;
    property Memo[index: integer]: TCustomMemo read GetMemo write SetMemo;
    // events...
    property OnNeedRichEdit: TGmNeedRichEditEvent read FNeedRichEdit write FNeedRichEdit;
  end;

  //----------------------------------------------------------------------------

  // *** TGmResourceTable ***

  TGmResourceTable = class(TPersistent)
  private
    FBrushList: TGmBrushList;
    FCustomMemoList: TGmCustomMemoList;
    FFontList: TGmFontList;
    FPenList: TGmPenList;
    FGraphicList: TGmGraphicList;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Clear;
    procedure LoadFromStream(Stream: TStream);
    procedure SaveToStream(Stream: TStream);
    property BrushList: TGmBrushList read FBrushList;
    property CustomMemoList: TGmCustomMemoList read FCustomMemoList;
    property FontList: TGmFontList read FFontList;
    property PenList: TGmPenList read FPenList;
    property GraphicList: TGmGraphicList read FGraphicList;
  end;

  TGmFontMapper = class
  private
    FRenderBitmap: TBitmap;
    FCharSpacing: array of integer;
    FCalcPpi: integer;
    FDestPpi: integer;
    FWrapText: Boolean;
    procedure GmDrawText(ACanvas: TCanvas; X, Y: integer; ARect: PRect; AText: string; const Spacing: array of integer);
    procedure CalculateCharSpacing(ACanvas: TCanvas; AText: string);
  public
    constructor Create;
    destructor Destroy; override;
    function TextExtent(ACanvas: TCanvas; AText: string): TGmSize;
    function TextHeight(ACanvas: TCanvas; AText: string): Extended;
    function TextWidth(ACanvas: TCanvas; AText: string): Extended;
    function TextBox(ACanvas: TCanvas; ARect: TRect; AText: string; Alignment: TAlignment; const AFastDraw: Boolean = False): Extended;
    function TextBoxHeight(AFont: TFont; ARect: TRect; AText: string): Extended;
    procedure TextOut(ACanvas: TCanvas; X, Y: integer; ARect: PRect; AText: string; const AFastDraw: Boolean = False);
    property WrapText: Boolean read FWrapText write FWrapText default True;
  end;

var
  GmFontMapper: TGmFontMapper;

  function PenToString(APen: TPen): string;
  procedure PenFromString(APen: TPen; AString: string);

implementation

uses SysUtils, GmConst, GmStream, GmFuncs, JPeg, GmRtfFuncs, ComCtrls;

//------------------------------------------------------------------------------

function PenToString(APen: TPen): string;
var
  AValues: TStringList;
begin
  AValues := TStringList.Create;
  try
    AValues.Add(IntToStr(APen.Color));
    AValues.Add(IntToStr(APen.Width));
    AValues.Add(IntToStr(Ord(APen.Style)));
    AValues.Add(IntToStr(Ord(APen.Mode)));
    Result := AValues.CommaText;
  finally
    AValues.Free;
  end;
end;

procedure PenFromString(APen: TPen; AString: string);
var
  AValues: TStringList;
begin
  AValues := TStringList.Create;
  try
    AValues.CommaText := AString;
    APen.Color := StrToInt(AValues[0]);
    APen.Width := StrToInt(AValues[1]);
    APen.Style := TPenStyle(StrToInt(AValues[2]));
    APen.Mode  := TPenMode(StrToInt(AValues[3]));
  finally
    AValues.Free;
  end;
end;

function CompareBrushes(Brush1, Brush2: TGmBrush): Boolean;
begin
  Result := (Brush1.Color = Brush2.Color) and (Brush1.Style = Brush2.Style);
end;

function CompareFonts(Font1, Font2: TGmFont): Boolean;
begin
  Result := (Font1.Name = Font2.Name) and
            (Font1.Size = Font2.Size) and
            (Font1.Charset = Font2.Charset) and
            (Font1.Angle = Font2.Angle) and
            (Font1.Color = Font2.Color) and
            (Font1.Style = Font2.Style);
end;

function ComparePens(Pen1, Pen2: TGmPen): Boolean;
begin
  Result := (Pen1.Color = Pen2.Color) and
            (Pen1.Mode = Pen2.Mode) and
            (Pen1.Style = Pen2.Style) and
            (Pen1.Width = Pen2.Width)
end;

function CompareGraphics(Graphic1, Graphic2: TGraphic): Boolean;
var
  Stream1,
  Stream2: TMemoryStream;
begin
  Result := False;
  if (Graphic1.Height <> Graphic2.Height) or
     (Graphic1.Width <> Graphic2.Width) then Exit;
  Stream1 := TMemoryStream.Create;
  Stream2 := TMemoryStream.Create;
  try
    Stream1.Clear;
    Stream2.Clear;
    Graphic1.SaveToStream(Stream1);
    Graphic2.SaveToStream(Stream2);
    if Stream1.Size <> Stream2.Size then Exit;
    Result := CompareMem(Stream1.Memory, Stream2.Memory, Stream1.Size);
  finally
    Stream1.Free;
    Stream2.Free;
  end;
end;

//------------------------------------------------------------------------------

{$IFDEF DELPHI4}

// A class which owns the objects it contains similar to the D5+ TObjectList class
// needed for D4 compatability... 

// *** TGmObjectList ***

constructor TGmObjectList.Create(const OwnsObjects: Boolean = True);
begin
  inherited Create;
  FList := TList.Create;
end;

destructor TGmObjectList.Destroy;
begin
  Clear;
  FList.Free;
  inherited Destroy;
end;

function TGmObjectList.Extract(AObject: TObject): TObject;
var
  ObjectIndex: integer;
begin
  Result := nil;
  ObjectIndex := IndexOf(AObject);
  if ObjectIndex = -1 then Exit;
  Result := Items[ObjectIndex];
  FList.Delete(ObjectIndex);
end;

function TGmObjectList.IndexOf(AObject: TObject): integer;
begin
  Result := FList.IndexOf(AObject);
end;

function TGmObjectList.GetCount: integer;
begin
  Result := FList.Count;
end;

function TGmObjectList.GetItem(index: integer): TObject;
begin