fctext.pas

一套及时通讯的原码

unit fctext;
{
//
// Common Text handling routines
//
// Copyright (c) 1999 by Woll2Woll Software
//
//
// 5/20/99 - Added to correct bug where text was not painted in the proper position when rotated.  -ksw
// 6/4/99 - Use font's charset
// 3/30/2001 - Added TempCanvas for Screen optimizations.
// 3/30/2001 - Added support for full text justification (be careful using this with extrusions as this will be slower to paint).
// 3/30/2001 - Need to add a margin property for text options.
//             Also update the calculations for extrusions with no rotation.
//             Also, make this be dbbindable or make another dbbindable version of this control.
// 9/26/2001 - Paintbitmap not large enough so not working on statusbar right aligned.
}

interface

//uses Classes, Graphics, Windows, SysUtils, Messages, Math, fcCommon, Dialogs, Forms;
uses SysUtils, Windows, Messages, Classes, Controls, Forms, Math, Dialogs,
    Graphics, Menus, StdCtrls, buttons, extctrls, fcCommon;

type
  TfcVAlignment = (vaTop, vaVCenter, vaBottom);

  TfcTextStyle = (fclsDefault, fclsLowered, fclsRaised,
    fclsOutline);

  TfcOrientation = (fcTopLeft, fcTopRight, fcBottomLeft, fcBottomRight,
    fcTop, fcRight, fcLeft, fcBottom);

  TfcTextOption = (toShowAccel, toShowEllipsis, toFullJustify);
  TfcTextOptions = set of TfcTextOption;

type
  {
  // Any component that uses TfcText MUST implement this interface.
  // The Invalidate method can just be the one defined in TControl, so
  // it does not need to be redefined.
  //
  // If the component is Delphi 4 only, then GetTextEnabled can be
  // implemented as:
  //
  // function IfcTextControl.GetTextEnabled = GetEnabled;
  //
  // This works, because Delphi 4 declares a GetEnabled access method
  // that is available to descendant classes.  Otherwise, just implement
  // a method that returns the state of the Enabled property
  // (i.e. "result := Enabled;").
  //
  // AdjustBounds will be called whenever a property of TfcText is
  // manipulated such that the rect that the text uses changes.
  // TfcCustomLabel uses this method in conjunction with the AutoSize
  // property to resize the label if neccessary.
  }
{
  IfcTextControl = interface
    procedure Invalidate;
    procedure AdjustBounds;
    function GetTextEnabled: Boolean;
  end;
}
  TfcTextCallbacks = record
    Invalidate: TfcProcMeth;
    AdjustBounds: TfcProcMeth;
    GetTextEnabled: TfcBoolFunc;
  end;

  TfcText = class;

  {
  // Properties related to the Shadow effects of TfcText.
  //
  // Properties:
  // - Color:   The color of the shadow.
  //
  // - Enabled: Determines whether or not to actually display the
  //            shadow.
  //
  // - XOffset, YOffset: Determines how much and in what direction,
  //            the shadow is offset from the main text.  Negative
  //            values are valid.
  //
  // Methods:
  // - EffectiveOffset: Returns an empty point (x: 0, y: 0) if shadows
  //            are disabled, otherwise returns Point(XOffset, YOffset).
  }

  TfcShadowEffects = class(TPersistent)
  private
    FText: TfcText;

    // Property Storage Variables
    FColor: TColor;
    FEnabled: Boolean;
    FXOffset: Integer;
    FYOffset: Integer;

    // Property Access Methods
    procedure SetColor(Value: TColor);
    procedure SetEnabled(Value: Boolean);
    procedure SetXOffset(Value: Integer);
    procedure SetYOffset(Value: Integer);
  protected
    procedure AssignTo(Dest: TPersistent); override;
  public
    constructor Create(Text: TfcText);
    function EffectiveOffset: TPoint;
  published
    // Published Properties
    property Color: TColor read FColor write SetColor default clBtnShadow;
    property Enabled: Boolean read FEnabled write SetEnabled default False;
    property XOffset: Integer read FXOffset write SetXOffset default 10;
    property YOffset: Integer read FYOffset write SetYOffset default 10;
  end;

  {
  // Properties related to 3d text effects such as embossing, extrusion,
  // etc.
  //
  // Properties:
  // - Color:    The color of the extrusion nearest to the actual
  //             text.
  //
  // - Depth:    How many pixels (layers) the extrusion is.  The larger
  //             this value, the more layers need to be painted and,
  //             therefore, the slower the algorithm.
  //
  // - Enabled:  Determines whether or not to paint the extrusion.
  //
  // - Orientation: Determines the direction that the extrusion points away from
  //             from the text.
  }

  TfcExtrudeEffects = class(TPersistent)
  private
    FText: TfcText;

    // Property Storage Variables
    FDepth: Integer;
    FEnabled: Boolean;
    FFarColor: TColor;
    FNearColor: TColor;
    FOrientation: TfcOrientation;
    FStriated: Boolean;

    // Property Access Methods
    procedure SetDepth(Value: Integer);
    procedure SetEnabled(Value: Boolean);
    procedure SetFarColor(Value: TColor);
    procedure SetNearColor(Value: TColor);
    procedure SetOrientation(Value: TfcOrientation);
    procedure SetStriated(Value: Boolean);
  protected
    procedure AssignTo(Dest: TPersistent); override;
  public
    constructor Create(Text: TfcText);
    function EffectiveDepth(CheckOrient: Boolean): TSize;
  published
    // Published Properties
    property Depth: Integer read FDepth write SetDepth default 10;
    property Enabled: Boolean read FEnabled write SetEnabled default False;
    property FarColor: TColor read FFarColor write SetFarColor default clBlack;
    property NearColor: TColor read FNearColor write SetNearColor default clBlack;
    property Orientation: TfcOrientation read FOrientation write SetOrientation default fcBottomRight;
    property Striated: Boolean read FStriated write SetStriated default False;
  end;

  TfcDisabledColors = class(TPersistent)
  private
    FText: TfcText;
    FHighlightColor: TColor;
    FShadeColor: TColor;
    procedure SetHighlightColor(Value: TColor);
    procedure SetShadeColor(Value: TColor);
  protected
    procedure AssignTo(Dest: TPersistent); override;
  public
    constructor Create(Text: TfcText);
  published
    property HighlightColor: TColor read FHighlightColor write SetHighlightColor default clBtnHighlight;
    property ShadeColor: TColor read FShadeColor write SetShadeColor default clBtnShadow;
  end;

  TfcText = class(TPersistent)
  private
    FRect: TRect;

    // Property storage variables
    FAlignment: TAlignment;
    FCanvas: TCanvas;
    FPaintCanvas:TCanvas;

    FDisabledColors: TfcDisabledColors;
    FExtrudeEffects: TfcExtrudeEffects;
    FHighlightColor: TColor;
    FFlags: UINT;
    FFont: TFont;
    FLineSpacing: Integer;
    FOptions: TfcTextOptions;
    FOutlineColor: TColor;
    FRotation: Integer;
    FScaledFont: Boolean;
    FShadeColor: TColor;
    FShadow: TfcShadowEffects;
    FStyle: TfcTextStyle;
    FText: string;
    FCallbacks: TfcTextCallbacks;
    FTextRect: TRect;
    FVAlignment: TfcVAlignment;
    FWordWrap: Boolean;
    FDoubleBuffered: boolean;
    InDraw:Boolean;

    // Property access methods
    function GetAngle: Extended;
    procedure SetAlignment(Value: TAlignment);
    procedure SetHighlightColor(Value: TColor);
    procedure SetLineSpacing(Value: Integer);
    procedure SetOptions(Value: TfcTextOptions);
    procedure SetOutlineColor(Value: TColor);
    procedure SetRotation(Value: Integer);
    procedure SetScaledFont(Value: Boolean);
    procedure SetShadeColor(Value: TColor);
    procedure SetStyle(Value: TfcTextStyle);
    procedure SetText(Value: string);
    procedure SetTextRect(Value: TRect);
    procedure SetVAlignment(Value: TfcVAlignment);
    procedure SetWordWrap(Value: Boolean);
  protected
    FPaintBitmap:TBitmap;
    // Protected methods
    function GetCanvas: TCanvas; virtual;
    function GetLogFont: TLogFont; virtual;
    function GetTextSize: TSize; virtual;
    function CalcTextSize(IgnoreRect: Boolean): TSize; virtual;
    function CalcRect(IgnoreRect: Boolean): TRect; virtual;
    procedure DrawHighlight; virtual;
    procedure DrawOutline; virtual;
    procedure DrawShadow(r: TRect); virtual;
    procedure DrawEmbossed(Raised: Boolean);
    procedure DrawText(r: TRect); virtual;

    procedure AssignTo(Dest: TPersistent); override;

    property Angle: Extended read GetAngle;
    property Font: TFont read FFont;
  public
    Patch: Variant;

    constructor Create(ACallbacks: TfcTextCallbacks; ACanvas: TCanvas; AFont: TFont);
    destructor Destroy; override;

    // Fancy Text Routines
    function CalcDrawRect(IgnoreRect: Boolean): TRect; virtual;
    procedure CallInvalidate; virtual;
    procedure Draw; virtual;
    procedure DrawStandardText; virtual;
    procedure DrawOutlineText; virtual;
    procedure DrawEmbossedText(Raised: Boolean); virtual;
    procedure DrawExtrusion;
    procedure PrepareCanvas; virtual;
    procedure UpdateFont(Value: TFont); virtual;

    property Alignment: TAlignment read FAlignment write SetAlignment;
    property Canvas: TCanvas read GetCanvas write FCanvas;
    property Callbacks: TfcTextCallbacks read FCallbacks write FCallbacks;
    property DisabledColors: TfcDisabledColors read FDisabledColors write FDisabledColors;
    property ExtrudeEffects: TfcExtrudeEffects read FExtrudeEffects write FExtrudeEffects;
    property Flags: UINT read FFlags write FFlags;
    property HighlightColor: TColor read FHighlightColor write SetHighlightColor default clBtnHighlight;
    property LineSpacing: Integer read FLineSpacing write SetLineSpacing default 5;
    property Options: TfcTextOptions read FOptions write SetOptions default [toShowAccel];
    property OutlineColor: TColor read FOutlineColor write SetOutlineColor default clBlack;
    property Rotation: Integer read FRotation write SetRotation default 0;
    property ScaledFont: Boolean read FScaledFont write SetScaledFont;
    property ShadeColor: TColor read FShadeColor write SetShadeColor default clBtnShadow;
    property Shadow: TfcShadowEffects read FShadow write FShadow;
    property Style: TfcTextStyle read FStyle write SetStyle default fclsDefault;
    property Text: string read FText write SetText;
    property TextRect: TRect read FTextRect write SetTextRect;
    property VAlignment: TfcVAlignment read FVAlignment write SetVAlignment;
    property WordWrap: Boolean read FWordWrap write SetWordWrap default False;
    property DoubleBuffered: boolean read FDoubleBuffered write FDoubleBuffered default False;
  end;

  TfcCaptionText = class(TfcText)
  published
    property Alignment;
    property DisabledColors;
    property ExtrudeEffects;
    property HighlightColor;
    property LineSpacing;
    property Options;
    property OutlineColor;
    property Rotation;
    property ShadeColor;
    property Shadow;
    property Style;
    property VAlignment;
    property WordWrap;
    property DoubleBuffered;
  end;

  function MakeCallbacks(InvalidateProc, AdjustBoundsProc: TfcProcMeth;
    GetTextEnabledProc: TfcBoolFunc): TfcTextCallbacks;

implementation

const
  OFFSETCOORD: array[TfcOrientation] of TPoint = (
    (x: 1; y: 1) {TopLeft}, (x: -1; y: 1) {TopRight},
    (x: 1; y: -1) {BottomLeft}, (x: -1; y: -1) {BottomRight},
    (x: 0; y: 1) {Top}, (x: -1; y: 0) {Right},
    (x: 1; y: 0) {Left}, (x: 0; y: -1) {Bottom}
  );

{ RSW - Trunc has problems in C++ Builder during compile time }
function fcTrunc(val: Extended): Longint;
begin
   result:= Round(Val-0.4999); { Changed from -0.5 }
end;

function MakeCallbacks(InvalidateProc, AdjustBoundsProc: TfcProcMeth;
  GetTextEnabledProc: TfcBoolFunc): TfcTextCallbacks;
begin
  result.Invalidate := InvalidateProc;
  result.AdjustBounds := AdjustBoundsProc;
  result.GetTextEnabled := GetTextEnabledProc;
end;

constructor TfcDisabledColors.Create(Text: TfcText);
begin
  inherited Create;
  FText := Text;
  FHighlightColor := clBtnHighlight;
  FShadeColor := clBtnShadow;
end;

procedure TfcDisabledColors.SetHighlightColor(Value: TColor);
begin
  if FHighlightColor <> Value then
  begin
    FHighlightColor := Value;
    FText.Callbacks.Invalidate;
  end;
end;

procedure TfcDisabledColors.SetShadeColor(Value: TColor);
begin
  if FShadeColor <> Value then
  begin
    FShadeColor := Value;
    FText.Callbacks.Invalidate;
  end;
end;

// TfcShadowEffects

procedure TfcShadowEffects.AssignTo(Dest: TPersistent);
begin
  with Dest as TfcShadowEffects do
  begin
    Color := self.Color;
    Enabled := self.Enabled;
    XOffset := self.XOffset;
    YOffset := self.YOffset;
  end;
end;

constructor TfcShadowEffects.Create(Text: TfcText);
begin
  inherited Create;

  FText := Text;

  FColor := clBtnShadow;
  FXOffset := 10;
  FYOffset := 10;
end;

function TfcShadowEffects.EffectiveOffset: TPoint;
begin
  result := Point(0,0);
  if Enabled then result := Point(XOffset, YOffset);
  if FText.ExtrudeEffects.Enabled then
    with OFFSETCOORD[FText.ExtrudeEffects.Orientation] do begin
      if not ((x >= 0) = (result.x > 0)) then
        result.x := 0
      else if not ((x <= 0) = (result.x < 0)) then
        result.x := 0;

      if not ((y >= 0) = (result.y > 0)) then
        result.y := 0
      else if not ((y <= 0) = (result.y < 0)) then
        result.y := 0;
    end;
end;

procedure TfcShadowEffects.SetColor(Value:TColor);
begin
  if FColor <> Value then
  begin
    FColor := Value;
    FText.CallInvalidate;
  end;
end;

procedure TfcShadowEffects.SetEnabled(Value: Boolean);
begin
  if FEnabled <> Value then