aafont.pas

是一个免费并开源的支持农历的月历控件

    procedure SetLabelEffect(const Value: TLabelEffect);
    procedure SetRowPitch(const Value: TRowPitch);
    procedure SetFontEffect(const Value: TAAEffect);
  protected
    function IsLinesStored: Boolean; virtual;
    property Lines: TStrings read FLines write SetLines stored IsLinesStored;
    {* 控件文本内容}
    property RowPitch: TRowPitch read FRowPitch write SetRowPitch default 20;
    {* 文本行间距}
    property LabelEffect: TLabelEffect read FLabelEffect write SetLabelEffect
      default leUntilNextLabel;
    {* 文本中字体、控制标签的作用范围}
    property FontEffect: TAAEffect read FFontEffect write SetFontEffect;
    {* 平滑特效字体属性}
  public
    constructor Create(AOwner: TAAGraphicControl; ChangedProc: TNotifyEvent);
      override;
    {* 类构造器}
    destructor Destroy; override;
    {* 类析构器}
    procedure Assign(Source: TPersistent); override;
    {* 对象赋值方法}
  end;

{ TAAGraphicControl }

  TProgress = 0..csMaxProgress;

  TAAGraphicControl = class(TGraphicControl)
  {* 平滑字体控件基类，所有平滑字体控件由该基类派生而来，一般不需要用户直接创建
   |<BR> 如果用户需要编写自己的平滑字体控件，可仔细分析该基类源码}
  private
    { Private declarations }
{$IFNDEF COMPILER6_UP}
    FAutoSize: Boolean;
{$ENDIF}
    FAAFont: TAAFontEx;
    FOnMouseLeave: TNotifyEvent;
    FOnMouseEnter: TNotifyEvent;
    FAutoUpdate: Boolean;
    FDrag: TDrag;
    FParentEffect: TParentEffect;
    FUpdateCount: Integer;
    FBorder: TBorderWidth;
    Inited: Boolean;
    Drawing: Boolean;
    AHeight: Integer;
    AWidth: Integer;

    procedure SetBorder(const Value: TBorderWidth);
    procedure SetDrag(const Value: TDrag);
    procedure SetParentEffect(const Value: TParentEffect);
    function GetWrapText(const Line, BreakStr: string;
      BreakChars: TSysCharSet; MaxCol: Integer): string;
    procedure SetAutoUpdate(const Value: Boolean);
  protected
    { Protected declarations }
{$IFDEF COMPILER6_UP}
    procedure SetAutoSize(Value: Boolean); override;
{$ELSE}
    procedure SetAutoSize(const Value: Boolean); virtual;
{$ENDIF}
    procedure OnEffectChanged(Sender: TObject);
    procedure CopyParentImage(Dest: TCanvas);
    procedure WrapText(const S: string; Strs: TStrings; Col: Integer);
    procedure Blend(DesBmp, BkBmp, ForeBmp: TBitmap; AProgress: TProgress);
    procedure DrawTiled(Canvas: TCanvas; Rect: TRect; G: TGraphic);
    procedure DrawBackGround(Canvas: TCanvas; Rect: TRect; G: TGraphic;
      Mode: TBackGroundMode);
    procedure WndProc(var message: TMessage); override;
    procedure PaintCanvas; virtual;
    procedure Paint; override;
    procedure Loaded; override;
    procedure LoadedEx; virtual;
    procedure Reset; virtual;
    procedure Resize; override;
    property UpdateCount: Integer read FUpdateCount;
    property AAFont: TAAFontEx read FAAFont;
{$IFDEF COMPILER6_UP}
    property AutoSize default True;
{$ELSE}
    property AutoSize: Boolean read FAutoSize write SetAutoSize default True;
{$ENDIF}
    property AutoUpdate: Boolean read FAutoUpdate write SetAutoUpdate default True;
    property Border: TBorderWidth read FBorder write SetBorder default 0;
    {* 控件边界保留宽度}
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    {* 类构造器}
    destructor Destroy; override;
    {* 类析构器}
    property Canvas;
    {* 控件画布}
    procedure BeginUpdate;
    {* 开始更新，调用该方法后，对控件属性的更改不会导致控件重绘，建议在批量修改
       控件时使用。
     |<BR> 注意该方法必须与EndUpate成对使用。}
    procedure EndUpdate;
    {* 结束更新，见BeginUpdate。用户结束更新后通常还应调用Changed方法通知控件重绘。}
    procedure Changed;
    {* 通知控件属性已变更，要求控件重绘}
  published
    { Published declarations }
    property Drag: TDrag read FDrag write SetDrag;
    {* 拖动相关属性打包}
    property ParentEffect: TParentEffect read FParentEffect write SetParentEffect;
    {* 父控件影响相关属性打包}
    property Align;
    property Anchors;
    property Constraints;
    property Enabled;
    property ShowHint;
    property Hint;
    property PopupMenu;
    property Visible;
    property OnClick;
    property OnContextPopup;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDock;
    property OnEndDrag;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;
    {* 鼠标移入控件内部事件}
    property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;
    {* 鼠标移出控件内部事件}
    property OnStartDock;
    property OnStartDrag;
  end;

{ TAACustomText }

  TAACustomText = class(TAAGraphicControl)
  {* 平滑字体文本类控件基类，所有使用多行文本的平滑字体控件由该基类派生而来，
     一般不需要用户直接创建。
   |<BR> 如果用户需要编写自己的平滑字体控件，可分析该基类源码}
  private
    { Private declarations }
    FFonts: TFontLabels;
    FOnTextReady: TNotifyEvent;
    FOnComplete: TNotifyEvent;
    FOnPainted: TNotifyEvent;
    FLabels: TUserLabels;
    FLabelsInited: Boolean;
    FFontsInited: Boolean;
    procedure SetFonts(const Value: TFontLabels);
    procedure SetLabels(const Value: TUserLabels);
  protected
    { Protected declarations }
    procedure CreateDefLabels; virtual;
    procedure CreateDefFonts; virtual;
    procedure CreateDefault;
    function UseDefaultLabels: Boolean; virtual;
    procedure LoadedEx; override;
    procedure OnLabelChanged(Sender: TObject);
    property OnComplete: TNotifyEvent read FOnComplete write FOnComplete;
    property OnTextReady: TNotifyEvent read FOnTextReady write FOnTextReady;
    property OnPainted: TNotifyEvent read FOnPainted write FOnPainted;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    {* 类构造器}
    destructor Destroy; override;
    {* 类析构器}
  published
    { Published declarations }
    property Fonts: TFontLabels read FFonts write SetFonts;
    {* 字体标签属性}
    property Labels: TUserLabels read FLabels write SetLabels;
    {* 用户标签属性}
  end;

var
  HSLRange: Integer = 240;
  {* HSL整数型颜色的范围值}

//HSL颜色与RGB色转换函数
function HSLtoRGB(H, S, L: Double): TColor;
{* HSL颜色转换为RGB颜色
 |<PRE>
   H, S, L: Double      - 分别为色调、饱和度、亮度分量，为"0"到"1"之间的小数
   Result: TColor       - 返回RGB颜色值
 |</PRE>}
function HSLRangeToRGB(H, S, L: Integer): TColor;
{* HSL颜色转换为RGB颜色
 |<PRE>
   H, S, L: Integer     - 分别为色调、饱和度、亮度分量，0..240
   Result: TColor       - 返回RGB颜色值
 |</PRE>}
procedure RGBtoHSL(RGB: TColor; var H, S, L: Double);
{* RGB颜色转换为HSL颜色
 |<PRE>
   Color: TColor        - RGB颜色值
   H, S, L: Integer     - 输出分别为色调、饱和度、亮度分量，为"0"到"1"之间的小数
 |</PRE>}
procedure RGBtoHSLRange(RGB: TColor; var H, S, L: Integer);
{* RGB颜色转换为HSL颜色
 |<PRE>
   Color: TColor        - RGB颜色值
   H, S, L: Integer     - 输出分别为色调、饱和度、亮度分量，0..240
 |</PRE>}

implementation

{$R-}

const
  ItalicAdjust = 0.3;                   //斜体字宽度校正系数
  SDuplicateString = 'Duplicate string!';

function HSLtoRGB(H, S, L: Double): TColor;
var
  M1, M2: Double;

  function HueToColourValue(Hue: Double): Byte;
  var
    V: Double;
  begin
    if Hue < 0 then
      Hue := Hue + 1
    else if Hue > 1 then
      Hue := Hue - 1;
    if 6 * Hue < 1 then
      V := M1 + (M2 - M1) * Hue * 6
    else if 2 * Hue < 1 then
      V := M2
    else if 3 * Hue < 2 then
      V := M1 + (M2 - M1) * (2 / 3 - Hue) * 6
    else
      V := M1;
    Result := Round(255 * V)
  end;
var
  R, G, B: Byte;
begin
  if S = 0 then
  begin
    R := Round(255 * L);
    G := R;
    B := R
  end
  else
  begin
    if L <= 0.5 then
      M2 := L * (1 + S)
    else
      M2 := L + S - L * S;
    M1 := 2 * L - M2;
    R := HueToColourValue(H + 1 / 3);
    G := HueToColourValue(H);
    B := HueToColourValue(H - 1 / 3)
  end;
  Result := RGB(R, G, B)
end;

function HSLRangeToRGB(H, S, L: Integer): TColor;
begin
  Result := HSLtoRGB(H / (HSLRange - 1), S / HSLRange, L / HSLRange)
end;

procedure RGBtoHSL(RGB: TColor; var H, S, L: Double);
  function Max(a, b: Double): Double;
  begin
    if a > b then
      Result := a
    else
      Result := b
  end;
  function Min(a, b: Double): Double;
  begin
    if a < b then
      Result := a
    else
      Result := b
  end;
var
  R, G, B, D, Cmax, Cmin: Double;
begin
  R := GetRValue(RGB) / 255;
  G := GetGValue(RGB) / 255;
  B := GetBValue(RGB) / 255;
  Cmax := Max(R, Max(G, B));
  Cmin := Min(R, Min(G, B));
  L := (Cmax + Cmin) / 2;
  if Cmax = Cmin then
  begin
    H := 0;
    S := 0
  end
  else
  begin
    D := Cmax - Cmin;
    if L < 0.5 then
      S := D / (Cmax + Cmin)
    else
      S := D / (2 - Cmax - Cmin);
    if R = Cmax then
      H := (G - B) / D
    else if G = Cmax then
      H := 2 + (B - R) / D
    else
      H := 4 + (R - G) / D;
    H := H / 6;
    if H < 0 then
      H := H + 1
  end
end;

procedure RGBtoHSLRange(RGB: TColor; var H, S, L: Integer);
var
  Hd, Sd, Ld: Double;
begin
  RGBtoHSL(RGB, Hd, Sd, Ld);
  H := Round(Hd * (HSLRange - 1));
  S := Round(Sd * HSLRange);
  L := Round(Ld * HSLRange);
end;

procedure StrectchDrawGraphic(ACanvas: TCanvas; ARect: TRect; AGraphic: TGraphic;
  BkColor: TColor);
var
  Bmp: TBitmap;
begin
  if AGraphic is TIcon then
  begin
    // TIcon 不支持缩放绘制，通过 TBitmap 中转
    Bmp := TBitmap.Create;
    try
      Bmp.Canvas.Brush.Color := BkColor;
      Bmp.Canvas.Brush.Style := bsSolid;
      Bmp.Width := AGraphic.Width;
      Bmp.Height := AGraphic.Height;
      //Bmp.Canvas.FillRect(Rect(0, 0, Bmp.Width, Bmp.Height));
      Bmp.Canvas.Draw(0, 0, AGraphic);
      ACanvas.StretchDraw(ARect, Bmp);
    finally
      Bmp.Free;
    end;
  end
  else
    ACanvas.StretchDraw(ARect, AGraphic);
end;

type
  TLogPal = record
    lpal: TLogPalette;
    dummy: array[0..255] of TPaletteEntry;
  end;

var
  HGrayPal: HPALETTE = 0;
  LogPal: TLogPal;

//初始化灰度位图
procedure InitGrayPal;
var
  i: Integer;
begin
  LogPal.lpal.palVersion := $300;
  LogPal.lpal.palNumEntries := 256;
  for i := 0 to 255 do
  begin
    LogPal.dummy[i].peRed := i;
    LogPal.dummy[i].peGreen := i;
    LogPal.dummy[i].peBlue := i;
    LogPal.dummy[i].peFlags := 0;
  end;
  HGrayPal := CreatePalette(LogPal.lpal);
end;

{ TAAMask }

//--------------------------------------------------------//
//平滑字体蒙板类                                          //
//--------------------------------------------------------//

//赋值
procedure TAAMask.Assign(Source: TPersistent);
begin
  if Source is TAAMask then
  begin
    FWidth := TAAMask(Source).Width;
    FHeight := TAAMask(Source).Height;
    Quality := TAAMask(Source).Quality;
    BytesLineGray := TAAMask(Source).BytesLineGray;
    BytesLineMask := TAAMask(Source).BytesLineMask;
    ReAllocMem(FpMaskBuff, FHeight * BytesLineMask);
    CopyMemory(FpMaskBuff, TAAMask(Source).FpMaskBuff, FHeight * BytesLineMask);
  end
  else
  begin
    inherited Assign(Source);
  end;
end;

//初始化
constructor TAAMask.Create(AOwner: TAAFont);
begin