aafont.pas

平滑特效字体控件包是一个基于平滑（Anti-aliasing）和特效（Effect）字体 技术的控件包

   !    with PaintBox1 do // 在控件中心输出文本
   !      AAFont.TextOut((Width - W) div 2, (Height - H) div 2, S, 80, 0);
   !    AAFont.Canvas := Image1.Canvas; // 也可以切换到另一画布
   !    AAFont.TextOut(10, 10, S); // 绘制时将使用Image1.Canvas的字体属性
   !  finally
   !    AAFont.Free;
   !  end;
   !end;}
  private
    FCanvas: TCanvas;
    function GetQuality: TAAQuality;
    procedure SetQuality(const Value: TAAQuality);
  protected
    Mask: TAAMask;
    Blend: TAABlend;
  public
    constructor Create(ACanvas: TCanvas); virtual;
    {* 类构造器，参数为绘制平滑字体文本和计算文本大小时使用的画布。
     |<BR> 允许为nil，如果为nil，请在调用文本方法前对Canvas属性赋值}
    destructor Destroy; override;
    {* 类析构器}
    procedure TextOut(x, y: Integer; s: string; Alpha: TAlpha = 100;
      Blur: TBlurStrength = 0);
    {* 输出平滑字体文本到当前设置的Canvas中，使用它的字体属性和画刷设置。
     |<BR> 如果要输出背景透明的文本，需要将Canvas.Brush.Style设为bsClear。
     |<BR> 注：该方法不支持多行文本。
     |<PRE>
       x, y: Integer    - 文本输出位置
       s: string        - 要绘制的字符串
       Alpha: TAlpha    - 文本的不透明度，默认为完全不透明
       Blur: TBlurStrength  - 文本的模糊度，默认为不进行模糊处理
     |</PRE>}
    function TextExtent(s: string): TSize; virtual;
    {* 返回文本高、宽}
    function TextHeight(s: string): Integer; virtual;
    {* 返回指定文本的显示高度，使用当前的Canvas属性}
    function TextWidth(s: string): Integer; virtual;
    {* 返回指定文本的显示宽度，使用当前的Canvas属性}
    property Quality: TAAQuality read GetQuality write SetQuality;
    {* 平滑字体绘制精度}
    property Canvas: TCanvas read FCanvas write FCanvas;
    {* 用于平滑字体绘制输出和文本尺寸检测的画布}
  end;

{ TAAFontEx }

  TAAFontEx = class(TAAFont)
  {* 扩展的平滑特效字体绘制类，实现了阴影、渐变、纹理等特效。
   |<BR> 用户可手动TAAFontEx来绘制带特效的平滑字体文本，使用方法类似于TAAFont。}
  private
    FEffect: TAAEffect;
    procedure SetEffect(const Value: TAAEffect);
  protected
    function GetShadowPoint: TPoint;
    function GetTextPoint: TPoint;
    procedure CreateGradual;
    procedure DrawTiled(Canvas: TCanvas; Rect: TRect; G: TGraphic);
    procedure CreateForeBmp;
    procedure CreateNoiseBmp;
    procedure AddNoise(Amount: Byte);
  public
    constructor Create(ACanvas: TCanvas); override;
    {* 类构造器，参数为绘制平滑字体文本和计算文本大小时使用的画布。
     |<BR> 允许为nil，如果为nil，请在调用文本方法前对Canvas属性赋值}
    destructor Destroy; override;
    {* 类析构器}
    function TextExtent(s: string): TSize; override;
    {* 返回文本高、宽
     |<BR> 注：Effect参数中的阴影、旋转角度等设置将影响返回结果}
    procedure TextOut(x, y: Integer; s: string);
    {* 使用Effect设置的字体特效，输出平滑字体文本到当前设置的Canvas中，使用它的字体属性和画刷设置。
     |<BR> 如果要输出背景透明的文本，需要将Canvas.Brush.Style设为bsClear。
     |<BR> 注：该方法不支持多行文本。
     |<PRE>
       x, y: Integer    - 文本输出位置
       s: string        - 要绘制的字符串
     |</PRE>}
    property Effect: TAAEffect read FEffect write SetEffect;
    {* 平滑字体绘制时的特效参数}
  end;

const
  csMaxProgress = 255;

type
  TParentControl = class(TWinControl);
  TMyControl = class(TControl);
  TFontLabel = class;
  TFontLabels = class;
  TUserLabel = class;
  TUserLabels = class;
  TAAGraphicControl = class;

{ TFontLabel }

  TFontLabel = class(TCollectionItem)
  {* 字体标签列表项类，TFontLabels的子项，一般不需要用户直接创建}
  private
    FName: string;
    FFont: TFont;
    FEffect: TAAEffect;
    function GetFontLabels: TFontLabels;
    procedure Changed;
    procedure SetFont(const Value: TFont);
    procedure SetName(const Value: string);
    procedure OnEffectChanged(Sender: TObject);
    procedure SetEffect(const Value: TAAEffect);
  protected
    function GetDisplayName: string; override;
  public
    constructor Create(Collection: TCollection); override;
    {* 类构造器}
    destructor Destroy; override;
    {* 类析构器}
    procedure Assign(Source: TPersistent); override;
    {* 对象赋值方法}
    property FontLabels: TFontLabels read GetFontLabels;
    {* 所有者}
  published
    property Name: string read FName write SetName;
    {* 字体标签名}
    property Font: TFont read FFont write SetFont;
    {* 字体属性}
    property Effect: TAAEffect read FEffect write SetEffect;
    {* 平滑字体特效显示属性}
  end;

{ TFontLabels }

  TFontLabels = class(TOwnedCollection)
  {* 字体标签列表类，定义了在文本类控件中可使用的字体标签集，一般不需要用户直接创建}
  private
    FOnChanged: TNotifyEvent;
    function GetItem(Index: Integer): TFontLabel;
    procedure SetItem(Index: Integer; const Value: TFontLabel);
  protected
    procedure Changed;
    procedure Update(Item: TCollectionItem); override;
  public
    constructor Create(AOwner: TComponent);
    {* 类构造器}
    function AddItem(AName: string; AFontName: string; AFontSize: Integer;
      AFontColor: TColor; AFontEffect: TFontStyles; Shadow: Boolean;
      OffsetX, OffsetY: Integer): TFontLabel;
    {* 增加一个新的字体标签}
    function IndexOf(const Name: string): Integer;
    {* 根据标签名查找子项索引号}
    procedure Check(var AText: string; AFont: TFont; AEffect: TAAEffect);
    {* 检查可能带字体标签的字符串。
     |<BR> 如果找到相应的标签，删除字符串中的标签（包含<>标记），并用该标签
       定义的Font和Effect属性设置参数中的对应属性}
    property Items[Index: Integer]: TFontLabel read GetItem write SetItem; default;
    {* 字体标签项数组属性}
    property OnChanged: TNotifyEvent read FOnChanged write FOnChanged;
    {* 属性变更通知}
  end;

{ TUserLabel }

  TGetTextEvent = procedure(Sender: TUserLabel; var Text: string) of object;
  {* 取用户标签所对应的文本事件
   |<PRE>
     Sender: TUserLabel  - 产生该事件的对象
     Text: string        - 由用户返回该标签对应的文本，变量参数
   |</PRE>}
  TLabelStyle = (lsLeftJustify, lsCenter, lsRightJustify, lsRegOwner,
    lsRegOrganization, lsAppTitle, lsDate, lsTime, lsCustom);
  {* 用户标签类型，分对齐控制标签和文本标签，文本标签在运行时被指定的文本取代：
   |<PRE>
     lsLeftJustify      - 左对齐标签，不可见控制标签，决定文本对齐方式
     lsCenter           - 中心对齐标签，不可见控制标签，决定文本对齐方式
     lsRightJustify     - 右对齐标签，不可见控制标签，决定文本对齐方式
     lsRegOwner         - 注册表中用户名标签，系统定义标签
     lsRegOrganization  - 注册表中组织名标签，系统定义标签（NT下无效）
     lsAppTitle         - 应用程序标题标签，系统定义标签
     lsDate             - 当前日期标签，系统定义标签
     lsTime             - 当前时间标签，系统定义标签
     lsCustom           - 用户自定义标签类型
   |</PRE>}

  TUserLabel = class(TCollectionItem)
  {* 用户文本标签列表项类，TUserLabels的子项，一般不需要用户直接创建}
  private
    FName: string;
    FText: string;
    FOnGetText: TGetTextEvent;
    FStyle: TLabelStyle;
    function GetUserLabels: TUserLabels;
    procedure Changed;
    procedure SetName(const Value: string);
    procedure SetText(const Value: string);
    function GetText: string;
    procedure SetStyle(const Value: TLabelStyle);
    function IsTextStored: Boolean;
  protected
    function GetDisplayName: string; override;
  public
    constructor Create(Collection: TCollection); override;
    {* 类构造器}
    procedure Assign(Source: TPersistent); override;
    {* 对象赋值方法}
    property UserLabels: TUserLabels read GetUserLabels;
    {* 所有者}
  published
    property Name: string read FName write SetName;
    {* 用户标签名}
    property Text: string read GetText write SetText stored IsTextStored;
    {* 标签所对应的文本，运行期显示文本中的标签用该值代替}
    property Style: TLabelStyle read FStyle write SetStyle default lsCustom;
    {* 标签类型}
    property OnGetText: TGetTextEvent read FOnGetText write FOnGetText;
    {* 取用户标签所对应的文本事件，对系统标签也有效}
  end;

{ TUserLabels }

  TUserLabels = class(TOwnedCollection)
  {* 用户标签列表类，定义了在文本类控件中可使用的用户标签集，一般不需要用户直接创建}
  private
    RegOwner: string;
    RegOrganization: string;
    FOnChanged: TNotifyEvent;
    function GetItem(Index: Integer): TUserLabel;
    procedure SetItem(Index: Integer; const Value: TUserLabel);
    procedure InitRegInfo;
  protected
    procedure Changed;
    procedure Update(Item: TCollectionItem); override;
  public
    constructor Create(AOwner: TComponent);
    {* 类构造器}
    function AddItem(AName: string; AText: string; AStyle: TLabelStyle): TUserLabel;
    {* 增加一个新的用户标签}
    function IndexOf(const Name: string): Integer;
    {* 根据标签名查找子项索引}
    procedure Check(var AText: string; var Align: TAlignment);
    {* 检查可能带文本标签的字符串。
     |<BR> 如果找到相应的标签，将文本中的标签（包含<>符号）用标签的Text属性取代，
       同时，还将调用标签的OnGetText事件。如果是对齐标签，将设置参数中的Align属性。}
    property Items[Index: Integer]: TUserLabel read GetItem write SetItem; default;
    {* 用户标签项数组属性}
    property OnChanged: TNotifyEvent read FOnChanged write FOnChanged;
    {* 属性变更通知}
  end;

{ TPackParam }

  TPackParam = class(TPersistent)
  {* 打包的参数属性类}
  private
    FOwner: TControl;
  protected
    property Owner: TControl read FOwner;
  public
    constructor Create(AOwner: TControl); virtual;
    {* 类构造器}
    procedure Assign(Source: TPersistent); override;
    {* 对象赋值方法}
  end;

{ TDrag }

  TDrag = class(TPackParam)
  {* 打包的拖放相关属性类}
  private
    function GetDragCursor: TCursor;
    function GetDragKind: TDragKind;
    function GetDragMode: TDragMode;
    procedure SetDragCursor(const Value: TCursor);
    procedure SetDragKind(const Value: TDragKind);
    procedure SetDragMode(const Value: TDragMode);
  published
    property DragKind: TDragKind read GetDragKind write SetDragKind default dkDrag;
    {* 拖放类型，同TControl中定义}
    property DragCursor: TCursor read GetDragCursor write SetDragCursor default crDrag;
    {* 拖放光标，同TControl中定义}
    property DragMode: TDragMode read GetDragMode write SetDragMode default dmManual;
    {* 拖放模式，同TControl中定义}
  end;

{ TParentEffect }

  TParentEffect = class(TPackParam)
  {* 打包的父控件影响相关属性类}
  private
    function GetParentBiDiMode: Boolean;
    function GetParentColor: Boolean;
    function GetParentFont: Boolean;
    function GetParentShowHint: Boolean;
    procedure SetParentBiDiMode(const Value: Boolean);
    procedure SetParentColor(const Value: Boolean);
    procedure SetParentFont(const Value: Boolean);
    procedure SetParentShowHint(const Value: Boolean);
  protected
    property ParentBiDiMode: Boolean read GetParentBiDiMode write SetParentBiDiMode
      default True;
  published
    property ParentColor: Boolean read GetParentColor write SetParentColor default
      True;
    {* 使用父控件的颜色，同TControl中定义}
    property ParentFont: Boolean read GetParentFont write SetParentFont default True;
    {* 使用父控件的字体，同TControl中定义}
    property ParentShowHint: Boolean read GetParentShowHint write SetParentShowHint
      default True;
    {* 使用父控件的提示显示设置，同TControl中定义}
  end;

{ TCustomParam }

  TBackGroundMode = (bmTiled, bmStretched, bmCenter, bmNormal);
  {* 背景图像显示模式
   |<PRE>
     bmTiled            - 平铺显示
     bmStretched        - 自动缩放显示
     bmCenter           - 在中心位置显示
     bmNormal           - 在左上角显示
   |</PRE>}

  TCustomParam = class(TNotifyClass)
  {* 可定制的平滑字体控件参数基类，一般不需要用户直接创建}
  private
    FAlignment: TAlignment;
    FWordWrap: Boolean;
    FTransparent: Boolean;
    FLayout: TTextLayout;
    FOwner: TAAGraphicControl;
    FBackGround: TPicture;
    FBackGroundMode: TBackGroundMode;

    procedure BackGroundChanged(Sender: TObject);
    procedure SetAlignment(const Value: TAlignment);
    procedure SetLayout(const Value: TTextLayout);
    procedure SetTransparent(const Value: Boolean);
    procedure SetWordWrap(const Value: Boolean);
    procedure SetQuality(const Value: TAAQuality);
    procedure SetFontEffect(const Value: TAAEffect);
    function GetQuality: TAAQuality;
    function GetFontEffect: TAAEffect;
    function GetColor: TColor;
    function GetFont: TFont;
    procedure SetColor(const Value: TColor);
    procedure SetFont(const Value: TFont);
    procedure SetBackGround(const Value: TPicture);
    procedure SetBackGroundMode(const Value: TBackGroundMode);
    function IsColorStroed: Boolean;
  protected
    function IsBackEmpty: Boolean;
    property Owner: TAAGraphicControl read FOwner;
    property Font: TFont read GetFont write SetFont;
    {* 控件字体}
    property Quality: TAAQuality read GetQuality write SetQuality default aqNormal;
    {* 平滑字体显示精度}
    property Alignment: TAlignment read FAlignment write SetAlignment
      default taLeftJustify;
    {* 文本对齐方式}
    property Layout: TTextLayout read FLayout write SetLayout default tlTop;
    {* 文本垂直方向对齐方式}
    property WordWrap: Boolean read FWordWrap write SetWordWrap default False;
    {* 文本是否自动换行}
    property Transparent: Boolean read FTransparent write SetTransparent
      default False;
    {* 控件是否透明}
    property FontEffect: TAAEffect read GetFontEffect write SetFontEffect;
    {* 平滑特效字体属性}
    property BackGround: TPicture read FBackGround write SetBackGround;
    {* 控件背景图像}
    property BackGroundMode: TBackGroundMode read FBackGroundMode
      write SetBackGroundMode default bmCenter;
    {* 控件背景图像显示模式}
    property BackColor: TColor read GetColor write SetColor stored IsColorStroed;
    {* 控件背景颜色}
  public
    constructor Create(AOwner: TAAGraphicControl; ChangedProc: TNotifyEvent);
      reintroduce; virtual;
    {* 类构造器}
    destructor Destroy; override;
    {* 类析构器}
    procedure Assign(Source: TPersistent); override;
    {* 对象赋值方法}
  end;

{ TCustomTextParam }

  TLabelEffect = (leOnlyALine, leUntilNextLabel);
  {* 标签作用范围类型
   |<PRE>
     leOnlyALine        - 字体、控制标签仅在当前行有效，无标签的行字体、对齐等由默认值决定
     leUntilNextLabel   - 标签所对应的参数影响当前行和后续行，直到遇到下一标签为止
   |</PRE>}
  TRowPitch = -100..150;
  {* 行间隔类型，单位为字体高度的百分比，允许为负以产生特殊效果}

  TCustomTextParam = class(TCustomParam)
  {* 可定制的平滑字体文本类控件参数基类，一般不需要用户直接创建}
  private
    FLines: TStrings;
    FLabelEffect: TLabelEffect;
    FRowPitch: TRowPitch;
    FFontEffect: TAAEffect;

    procedure LinesChanged(Sender: TObject);
    procedure SetLines(const Value: TStrings);