frxgraphicutils.pas

Fastreport最新版本的补丁

{******************************************}
{                                          }
{             FastReport v4.0              }
{            Graphic routines              }
{                                          }
{         Copyright (c) 1998-2007          }
{         by Alexander Tzyganenko,         }
{            Fast Reports Inc.             }
{                                          }
{******************************************}

unit frxGraphicUtils;

interface

{$I frx.inc}

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


type
  TIntArray = array[0..MaxInt div 4 - 1] 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;
    FPrintScale: Extended;
    FRotation: Integer;
    FRTLReading: Boolean;
    FScaledRect: TRect;
    FScaleX: Extended;
    FScaleY: Extended;
    FText: TWideStrings;
    FWordBreak: Boolean;
    FWordWrap: Boolean;
    FWysiwyg: 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, Wysiwyg: Boolean; Rotation: Integer);
    procedure SetGaps(ParagraphGap, CharSpacing, LineSpacing: Extended);
    procedure SetDimensions(ScaleX, ScaleY, PrintScale: Extended;
      OriginalRect, ScaledRect: TRect);
    procedure SetText(Text: TWideStrings);
    procedure SetParaBreaks(FirstParaBreak, LastParaBreak: Boolean);
    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(var ParaBreak: Boolean): 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 = '?';

function BreakRussianWord(const s: WideString): String;
var
  i, j: Integer;
  CanBreak: Boolean;

  function Check1and5(const s: WideString): Boolean;
  var
    i: Integer;
  begin
    Result := False;
    if Length(s) >= 2 then
      for i := 1 to Length(s) do
        if Pos(s[i], glasn) <> 0 then
        begin
          Result := True;
          break;
        end;
  end;

begin
  Result := '';
  if Length(s) < 4 then Exit;

  for i := 1 to Length(s) do
  begin
    CanBreak := False;
    if Pos(s[i], soglasn) <> 0 then
    begin
      CanBreak := True;
      { 2 }
      if (i < Length(s)) and (Pos(s[i + 1], glasn) <> 0) then
        CanBreak := False;
      { 3 }
      if (i < Length(s)) and (Pos(s[i + 1], znaks) <> 0) then
        CanBreak := False;
    end;
    if Pos(s[i], glasn) <> 0 then
    begin
      CanBreak := True;
      { 4 }
      if (i < Length(s)) and (Pos(s[i + 1], znaks1) <> 0) then
        CanBreak := False;
      { 6 }
      if (i < Length(s) - 2) and (Pos(s[i + 1], soglasn) <> 0) and
        (s[i + 1] = s[i + 2]) and (Pos(s[i + 3], glasn) <> 0) then
        CanBreak := False;
    end;
    if CanBreak then
      Result := Result + Chr(i);
  end;

  { 1, 5 }
  for i := 1 to Length(Result) do
  begin
    j := Ord(Result[i]);
    if not (Check1and5(Copy(s, 1, j)) and Check1and5(Copy(s, j + 1, 255))) then
      Result[i] := #255;
  end;
  while Pos(#255, Result) <> 0 do
    Delete(Result, Pos(#255, Result), 1);
end;

procedure IncArray(Ar: PIntArray; x1, x2, n, one: Integer);
var
  xm: Integer;
begin
  if n <= 0 then Exit;
  xm := (x2 - x1 + 1) div 2;
  if xm = 0 then
    xm := 1;
  if n = 1 then
    Inc(Ar[x1 + xm - 1], one)
  else
  begin
    IncArray(Ar, x1, x1 + xm - 1, n div 2, one);
    IncArray(Ar, x1 + xm, x2, n - n div 2, one);
  end;
end;

function CreateRotatedFont(Font: TFont; Rotation: Integer): HFont;
var
  F: TLogFont;
begin
  GetObject(Font.Handle, SizeOf(TLogFont), @F);
  F.lfEscapement := Rotation * 10;
  F.lfOrientation := Rotation * 10;
  Result := CreateFontIndirect(F);
end;


{ TfrxHTMLTag }

procedure TfrxHTMLTag.Assign(Tag: TfrxHTMLTag);
begin
  Position := Tag.Position;
  Size := Tag.Size;
  AddY := Tag.AddY;
  Style := Tag.Style;
  Color := Tag.Color;
  Default := Tag.Default;
  Small := Tag.Small;
end;


{ TfrxHTMLTags }

constructor TfrxHTMLTags.Create;
begin
  FItems := TList.Create;
end;

destructor TfrxHTMLTags.Destroy;
begin
  Clear;
  FItems.Free;
  inherited;
end;

procedure TfrxHTMLTags.Clear;
var
  i: Integer;
begin
  for i := 0 to FItems.Count - 1 do
    TfrxHTMLTag(FItems[i]).Free;
  FItems.Clear;
end;

function TfrxHTMLTags.GetItems(Index: Integer): TfrxHTMLTag;
begin
  Result := TfrxHTMLTag(FItems[Index]);
end;

function TfrxHTMLTags.Count: Integer;
begin
  Result := FItems.Count;
end;

procedure TfrxHTMLTags.Add(Tag: TfrxHTMLTag);
begin
  FItems.Add(Tag);
end;


{ TfrxHTMLTagsList }

constructor TfrxHTMLTagsList.Create;
begin
  FItems := TList.Create;
  FAllowTags := True;
  GetMem(FTempArray, SizeOf(Integer) * 32768);
end;

destructor TfrxHTMLTagsList.Destroy;
begin
  Clear;
  FItems.Free;
  FreeMem(FTempArray, SizeOf(Integer) * 32768);
  inherited;
end;

procedure TfrxHTMLTagsList.Clear;
var
  i: Integer;
begin
  for i := 0 to FItems.Count - 1 do
    TfrxHTMLTags(FItems[i]).Free;
  FItems.Clear;
end;

procedure TfrxHTMLTagsList.NewLine;
begin
  if Count <> 0 then
    FItems.Add(TfrxHTMLTags.Create);
end;

procedure TfrxHTMLTagsList.Wrap(TagsCount: Integer; AddBreak: Boolean);
var
  i: Integer;
  Line, OldLine: TfrxHTMLTags;
  NewTag: TfrxHTMLTag;
begin
  OldLine := Items[Count - 1];
  if OldLine.Count <= TagsCount then
    Exit;

  NewLine;
  Line := Items[Count - 1];
  for i := TagsCount to OldLine.Count - 1 do
    Line.Add(OldLine[i]);
  OldLine.FItems.Count := TagsCount;
  if AddBreak then
  begin
    NewTag := TfrxHTMLTag.Create;
    OldLine.FItems.Add(NewTag);
    NewTag.Assign(TfrxHTMLTag(OldLine.FItems[TagsCount - 1]))
  end
  else if Line[0].Default then
    Line[0].Assign(OldLine[TagsCount - 1]);
end;

function TfrxHTMLTagsList.Count: Integer;
begin
  Result := FItems.Count;
end;

function TfrxHTMLTagsList.GetItems(Index: Integer): TfrxHTMLTags;
begin
  Result := TfrxHTMLTags(FItems[Index]);
end;

function TfrxHTMLTagsList.Add: TfrxHTMLTag;
var
  i: Integer;
begin
  Result := TfrxHTMLTag.Create;
  i := Count - 1;
  if i = -1 then
  begin
    FItems.Add(TfrxHTMLTags.Create);
    i := 0;
  end;
  Items[i].Add(Result);
end;

function TfrxHTMLTagsList.GetPrevTag: TfrxHTMLTag;
var
  Tags: TfrxHTMLTags;
begin
  Result := nil;
  Tags := Items[Count - 1];
  if Tags.Count > 1 then
    Result := Tags[Tags.Count - 2]
  else if Count > 1 then
  begin
    Tags := Items[Count - 2];
    Result := Tags[Tags.Count - 1];
  end;
end;

procedure TfrxHTMLTagsList.SetDefaults(DefColor: TColor; DefSize: Integer;
  DefStyle: TFontStyles);
begin
  FDefColor := DefColor;
  FDefSize := DefSize;
  FDefStyle := DefStyle;
  FAddY := 0;
  FColor := FDefColor;
  FSize := FDefSize;
  FStyle := FDefStyle;
  FPosition := 1;
  Clear;
end;

procedure TfrxHTMLTagsList.ExpandHTMLTags(var s: WideString);
var
  i, j, j1: Integer;
  b: Boolean;
  cl: WideString;

  procedure AddTag;
  var
    Tag, PrevTag: TfrxHTMLTag;
  begin
    Tag := Add;
    Tag.Position := FPosition; // this will help us to get position in the original text
    Tag.Size := FSize;
    Tag.Style := FStyle;
    Tag.Color := FColor;
    Tag.AddY := FAddY;
// when "Default" changes, we need to set Font.Style, Size and Color
    if FAllowTags then
    begin
      PrevTag := GetPrevTag;
      if PrevTag <> nil then
        Tag.Default := (FStyle = PrevTag.Style) and
                       (FColor = PrevTag.Color) and
                       (FSize = PrevTag.Size)
      else
        Tag.Default := (FStyle = FDefStyle) and (FColor = FDefColor) and (FSize = FDefSize);
    end
    else
      Tag.Default := True;
    Tag.Small := FSize <> FDefSize;
  end;

begin
  i := 1;
  if Length(s) = 0 then Exit;

  while i <= Length(s) do
  begin
    b := True;

    if FAllowTags then
      if s[i] = '<' then
      begin

        // <b>, <u>, <i> tags
        if (i + 2 <= Length(s)) and (s[i + 2] = '>') then
        begin
          case s[i + 1] of
            'b','B': FStyle := FStyle + [fsBold];
            'i','I': FStyle := FStyle + [fsItalic];
            'u','U': FStyle := FStyle + [fsUnderline];
            else
              b := False;
          end;
          if b then
          begin
            System.Delete(s, i, 3);
            Inc(FPosition, 3);
            continue;
          end;
        end

        // <sub>, <sup> tags
        else if (i + 4 <= Length(s)) and (s[i + 4] = '>') then
        begin
          if Pos('SUB>', AnsiUpperCase(s)) = i + 1 then
          begin
            FSize := Round(FDefSize / 1.5);
            FAddY := 1;
            b := True;
          end
          else if Pos('SUP>', AnsiUpperCase(s)) = i + 1 then
          begin
            FSize := Round(FDefSize / 1.5);
            FAddY := 0;
            b := True;
          end;
          if b then
          begin
            System.Delete(s, i, 5);
            Inc(FPosition, 5);
            continue;
          end;
        end

        // <strike> tag
        else if (i + 1 <= Length(s)) and ((s[i + 1] = 's') or (s[i + 1] = 'S')) then
        begin
          if Pos('STRIKE>', AnsiUpperCase(s)) = i + 1 then
          begin
            FStyle := FStyle + [fsStrikeOut];
            System.Delete(s, i, 8);
            Inc(FPosition, 8);
            continue;
          end;
        end

        // </b>, </u>, </i>, </strike>, </font>, </sub>, </sup> tags
        else if (i + 1 <= Length(s)) and (s[i + 1] = '/') then
        begin
          if (i + 3 <= Length(s)) and (s[i + 3] = '>') then
          begin
            case s[i + 2] of
              'b','B': FStyle := FStyle - [fsBold];
              'i','I': FStyle := FStyle - [fsItalic];
              'u','U': FStyle := FStyle - [fsUnderline];
              else
                b := False;
            end;
            if b then
            begin
              System.Delete(s, i, 4);
              Inc(FPosition, 4);
              continue;
            end;
          end
          else if (Pos('STRIKE>', AnsiUpperCase(s)) = i + 2) then
          begin