frxgraphicutils.pas

解決fastreport3.18版以上中文字問題

{******************************************}
{                                          }
{             FastReport v3.0              }
{            Graphic routines              }
{                                          }
{         Copyright (c) 1998-2005          }
{         by Alexander Tzyganenko,         }
{            Fast Reports Inc.             }
{                                          }
{******************************************}
{從fastreport3.18版修改unicode以來,對中文支持一直就有問題,
 把charset改非default_charset顯示漢字只顯示一半,其他修改
 並未真正解決這個問題.這個解決了這個問題,把它替換掉原來
 source下的frxgraphicunit.pas編譯一下即可.
}

unit frxGraphicUtils;

interface

{$I frx.inc}

uses
  SysUtils, Windows, Messages, Classes, Graphics, Controls, Forms, Dialogs,
  frxClass, frxUnicodeUtils
{$IFDEF Delphi6}
, Variants
{$ENDIF};


type
  TIntArray = array[1..MaxInt div 4] of Integer;
  PIntArray = ^TIntArray;

  TfrxHTMLTag = class(TObject)
  public
    Position: Integer;
    Size: Integer;
    AddY: Integer;
    Style: TFontStyles;
    Color: Integer;
    Default: Boolean;
    Small: Boolean;
    procedure Assign(Tag: TfrxHTMLTag);
  end;

  TfrxHTMLTags = class(TObject)
  private
    FItems: TList;
    procedure Add(Tag: TfrxHTMLTag);
    function GetItems(Index: Integer): TfrxHTMLTag;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Clear;
    function Count: Integer;
    property Items[Index: Integer]: TfrxHTMLTag read GetItems; default;
  end;

  TfrxHTMLTagsList = class(TObject)
  private
    FAllowTags: Boolean;
    FAddY: Integer;
    FColor: LongInt;
    FDefColor: LongInt;
    FDefSize: Integer;
    FDefStyle: TFontStyles;
    FItems: TList;
    FPosition: Integer;
    FSize: Integer;
    FStyle: TFontStyles;
    FTempArray: PIntArray;
    procedure NewLine;
    procedure Wrap(TagsCount: Integer; AddBreak: Boolean);
    function Add: TfrxHTMLTag;
    function FillCharSpacingArray(var ar: PIntArray; const s: WideString;
      Canvas: TCanvas; LineIndex, Add: Integer; Convert: Boolean): Integer;
    function GetItems(Index: Integer): TfrxHTMLTags;
    function GetPrevTag: TfrxHTMLTag;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Clear;
    procedure SetDefaults(DefColor: TColor; DefSize: Integer;
      DefStyle: TFontStyles);
    procedure ExpandHTMLTags(var s: WideString);
    function Count: Integer;
    property AllowTags: Boolean read FAllowTags write FAllowTags;
    property Items[Index: Integer]: TfrxHTMLTags read GetItems; default;
    property Position: Integer read FPosition write FPosition;
  end;

  TfrxDrawText = class(TObject)
  private
// internals
    FBMP: TBitmap;
    FLocked: Boolean;
    FCanvas: TCanvas;
    FDefPPI: Integer;
    FScrPPI: Integer;
    FTempArray: PIntArray;

// data passed by SetXXX calls
    FFontSize: Integer;
    FHTMLTags: TfrxHTMLTagsList;
    FCharSpacing: Extended;
    FLineSpacing: Extended;
    FOptions: Integer;
    FOriginalRect: TRect;
    FParagraphGap: Extended;
    FPlainText: WideString;
    FRotation: Integer;
    FRTLReading: Boolean;
    FScaledRect: TRect;
    FScaleX: Extended;
    FScaleY: Extended;
    FText: TWideStrings;
    FWordBreak: Boolean;
    FWordWrap: Boolean;

    function GetWrappedText: WideString;
    function IsPrinter(C: TCanvas): Boolean;
    procedure DrawTextLine(C: TCanvas; const s: WideString;
      X, Y, DX, LineIndex: Integer; Align: TfrxHAlign; var fh, oldfh: HFont);
    procedure WrapTextLine(s: WideString; Width, FirstLineWidth,
      CharSpacing: Integer);
  public
    constructor Create;
    destructor Destroy; override;

// Call these methods in the same order
    procedure SetFont(Font: TFont);
    procedure SetOptions(WordWrap, HTMLTags, RTLReading, WordBreak,
      Clipped: Boolean; Rotation: Integer);
    procedure SetGaps(ParagraphGap, CharSpacing, LineSpacing: Extended);
    procedure SetDimensions(ScaleX, ScaleY: Extended; OriginalRect, ScaledRect: TRect);
    procedure SetText(Text: TWideStrings);
    function DeleteTags(const Txt: WideString): WideString;

// call these methods only after methods listed above
    procedure DrawText(C: TCanvas; HAlign: TfrxHAlign; VAlign: TfrxVAlign);
    function CalcHeight: Extended;
    function CalcWidth: Extended;
    function LineHeight: Extended;
    function TextHeight: Extended;
// returns the text that don't fit in the bounds
    function GetInBoundsText: WideString;
    function GetOutBoundsText: WideString;
    function UnusedSpace: Extended;

// call these methods before and after doing something
    procedure Lock;
    procedure Unlock;

    property Canvas: TCanvas read FCanvas;
    property DefPPI: Integer read FDefPPI;
    property ScrPPI: Integer read FScrPPI;
    property WrappedText: WideString read GetWrappedText;
  end;


var
  frxDrawText: TfrxDrawText;

implementation

uses frxPrinter;

const
  glasn: String = '琅ㄈ斡圯捱';
  soglasn: String = '谅媚魄墒颂拖醒以罩棕佘?';
  znaks: String = '苴';
  znaks1: String = '?';

{ 橡噔桦?镥疱眍襦 镱 耠钽囔, 镳桧