aactrls.pas

AAFONT是一款Delphi控件

//绘制画布
procedure TAALinkLabel.PaintCanvas;
begin
  if FMouseIn or (FadeStyle <> fsNone) then
    Bitblt(Canvas.Handle, 0, 0, Width, Height, BlendBmp.Canvas.Handle, 0, 0,
      SRCCOPY)
  else
    inherited;
end;

//淡入淡出
procedure TAALinkLabel.OnFadeTimer(Sender: TObject);
begin
  if Abs(NewProg - Progress) > 1 then
    NewProg := Progress;
  case FadeStyle of
    fsIn: begin               //淡入
        NewProg := NewProg + csMaxProgress * FadeTimer.Interval div HotLink.FadeDelay;
        if NewProg > csMaxProgress then
        begin
          NewProg := csMaxProgress;
          FadeStyle := fsNone;
        end;
        Progress := Round(NewProg);
      end;
    fsOut: begin              //淡出
        NewProg := NewProg - csMaxProgress * FadeTimer.Interval div HotLink.FadeDelay;
        if NewProg < 0 then
        begin
          NewProg := 0;
          FadeStyle := fsNone;
        end;
        Progress := Round(NewProg);
      end;
    fsNone: begin             //无
        FadeTimer.Enabled := False;
      end;
  end;
end;

//绘制热点画布
procedure TAALinkLabel.DrawHot;
var
  OffPoint: TPoint;
  th, tw: Integer;
  AAEffect: TAAEffect;
begin
  BeginUpdate;
  try
    AAEffect := TAAEffect.Create(nil);
    AAEffect.Assign(AAFont.Effect);

    AAFont.Canvas := HotBmp.Canvas;
    AAFont.Effect.Assign(HotLink.FontEffect);
    HotBmp.Canvas.Font.Assign(Font); //字体
    HotBmp.Canvas.Font.Color := HotLink.Color;
    if HotLink.UnderLine then
      HotBmp.Canvas.Font.Style := HotBmp.Canvas.Font.Style + [fsUnderline];
    th := AAFont.TextHeight(Caption); //文本高度
    tw := AAFont.TextWidth(Caption); //文本宽度
    if AutoSize and (Align = alNone) then //自动设定大小
    begin
      OffPoint := Point(Border, Border);
    end else begin
      case Effect.Alignment of //水平对齐方式
        taLeftJustify: OffPoint.x := Border;
        taCenter: OffPoint.x := (ClientWidth - tw) div 2;
        taRightJustify: OffPoint.x := ClientWidth - Border - tw;
      end;
      case Effect.Layout of   //垂直对齐方式
        tlTop: OffPoint.y := Border;
        tlCenter: OffPoint.y := (ClientHeight - th) div 2;
        tlBottom: OffPoint.y := ClientHeight - Border - th;
      end;
    end;
    HotBmp.Height := ClientHeight;
    HotBmp.Width := ClientWidth;
    HotBmp.Canvas.Brush.Color := HotLink.BackColor;
    HotBmp.Canvas.Brush.Style := bsSolid;
    if HotLink.Transparent then
    begin
      CopyParentImage(HotBmp.Canvas);
    end else if not HotLink.IsBackEmpty then
    begin
      DrawBackGround(HotBmp.Canvas, Rect(0, 0, HotBmp.Width, HotBmp.Height),
        HotLink.BackGround.Graphic, HotLink.BackGroundMode);
    end else
    begin
      HotBmp.Canvas.FillRect(ClientRect);
    end;
    HotBmp.Canvas.Brush.Style := bsClear;
    AAFont.TextOut(OffPoint.x, OffPoint.y, Caption); //平滑字体输出

    AAFont.Effect.Assign(AAEffect);
    AAEffect.Free;
  finally
    EndUpdate;
  end;
end;

//鼠标移入开始淡入
procedure TAALinkLabel.CMMouseEnter(var Message: TMessage);
begin
  if Enabled then
  begin
    FMouseIn := True;
    DrawMem;
    DrawHot;
    if HotLink.Fade then
    begin
      FadeStyle := fsIn;
    end else
      Progress := csMaxProgress;
  end;
  inherited;
end;

//鼠标称出开始淡出
procedure TAALinkLabel.CMMouseLeave(var Message: TMessage);
begin
  if Enabled then
  begin
    if HotLink.Fade then
    begin
      FadeStyle := fsOut;
    end else
      Progress := 0;
    FMouseIn := False;
  end;
  inherited;
end;

//点击控件
procedure TAALinkLabel.Click;
var
  Wnd: THandle;
begin
  if HotLink.URL <> EmptyStr then
  begin
    if Parent is TForm then
      Wnd := Parent.Handle
    else
      Wnd := 0;               //NULL;
    ShellExecute(Wnd, nil, PChar(HotLink.URL), nil, nil, SW_SHOWNORMAL);
  end;
  inherited;
end;

//属性已装载
procedure TAALinkLabel.LoadedEx;
begin
  inherited;
  Reset;
end;

//设置淡入淡出进度
procedure TAALinkLabel.SetProgress(const Value: TProgress);
begin
  if FProgress <> Value then
  begin
    FProgress := Value;
    Blend(BlendBmp, MemBmp, HotBmp, Progress);
    Paint;
  end;
end;

//设置启用
procedure TAALinkLabel.SetEnabled(Value: Boolean);
begin
  inherited;
  if not Value then
  begin
    FadeStyle := fsNone;
    Progress := 0;
  end;
end;

//设置淡入淡出
procedure TAALinkLabel.SetFadeStyle(const Value: TFadeStyle);
begin
  if FFadeStyle <> Value then
  begin
    FFadeStyle := Value;
    FadeTimer.Enabled := FFadeStyle <> fsNone;
  end;
end;

//设置链接参数
procedure TAALinkLabel.SetHotLink(const Value: THotLink);
begin
  FHotLink.Assign(Value);
end;

{ TAAText }

//--------------------------------------------------------//
//平滑特效超链接标签                                      //
//--------------------------------------------------------//

//调整尺寸
procedure TAAText.CalcSize;
var
  i, j: Integer;
  DispLines: TStrings;
  WrapLines: TStrings;
  CurrText: string;
  CurrAlign: TAlignment;
  TextWidth: Integer;
  TextHeight: Integer;
  AWidth, AHeight: Integer;
  xFree, yFree: Boolean;
  MaxCol: Integer;
begin
  BeginUpdate;
  DispLines := nil;
  WrapLines := nil;
  try
    DispLines := TStringList.Create; //临时文本
    WrapLines := TStringList.Create;
    with FText do
    begin
      xFree := not WordWrap and AutoSize and (Align in [alNone, alLeft, alRight]);
      yFree := AutoSize and (Align in [alNone, alTop, alBottom]);
      if xFree then AWidth := 0
      else AWidth := ClientWidth;
      if yFree then AHeight := 0
      else AHeight := ClientHeight;
      if xFree or yFree then
      begin
        DispLines.Clear;
        DispLines.AddStrings(Lines);
        AAFont.Canvas := Canvas;
        AAFont.Effect.Assign(FText.FontEffect);
        Canvas.Font.Assign(Font);
        for i := 0 to DispLines.Count - 1 do
        begin
          CurrText := DispLines[i]; //当前处理字符串
          if LabelEffect = leOnlyALine then
          begin
            Canvas.Font.Assign(Font);
            AAFont.Effect.Assign(FText.FontEffect);
          end;
          Fonts.Check(CurrText, Canvas.Font, AAFont.Effect); //检查字体标签
          Labels.Check(CurrText, CurrAlign); //检查用户标签
          TextWidth := AAFont.TextWidth(CurrText);
          if WordWrap and (TextWidth > AWidth) then //自动换行
          begin
            MaxCol := AWidth * Length(CurrText) div TextWidth;
            while AAFont.TextWidth(Copy(CurrText, 1, MaxCol)) > AWidth do
              Dec(MaxCol);
            WrapText(CurrText, WrapLines, MaxCol);
          end else if CurrText <> '' then
            WrapLines.Text := CurrText
          else
            WrapLines.Text := ' ';
          if xFree and (TextWidth > AWidth) then //确定宽度
          begin
            AWidth := TextWidth;
          end;
          if yFree then       //确定高度
          begin
            for j := 0 to WrapLines.Count - 1 do
            begin
              CurrText := WrapLines[j];
              TextHeight := AAFont.TextHeight(CurrText + ' ');
              Inc(AHeight, TextHeight);
              if (i < DispLines.Count - 1) or (j < WrapLines.Count - 1) then
                Inc(AHeight, Round(TextHeight * RowPitch / 100));
            end;
          end;
        end;
        if xFree then ClientWidth := AWidth + 2 * Border;
        if yFree then ClientHeight := AHeight + 2 * Border;
      end;
    end;
  finally
    DispLines.Free;
    WrapLines.Free;
    EndUpdate;
  end;
end;

//创建
constructor TAAText.Create(AOwner: TComponent);
begin
  inherited;
  ControlStyle := ControlStyle + [csReplicatable];
  FText := TTextParam.Create(Self, OnLabelChanged);
  TextBmp := TBitmap.Create;
  TextBmp.PixelFormat := pf24bit;
  Width := 46;
  Height := 12;
end;

//创建显示文本
procedure TAAText.CreateText;
begin
  CalcSize;
  TextBmp.Canvas.Brush.Color := Color;
  TextBmp.Canvas.Brush.Style := bsSolid;
  TextBmp.Width := ClientWidth;
  TextBmp.Height := ClientHeight;
  if FText.Transparent then     //透明
  begin
    CopyParentImage(TextBmp.Canvas); //复制父控件画布
  end else if not FText.IsBackEmpty then
  begin                   //绘制背景图
    DrawBackGround(TextBmp.Canvas, Rect(0, 0, TextBmp.Width, TextBmp.Height),
      FText.BackGround.Graphic, FText.BackGroundMode);
  end else
  begin                   //填充背景色
    TextBmp.Canvas.FillRect(ClientRect);
  end;
  TextBmp.Canvas.Brush.Style := bsClear;
  DrawCanvas(TextBmp.Canvas);
end;

//释放
destructor TAAText.Destroy;
begin
  TextBmp.Free;
  FText.Free;
  inherited;
end;

//绘制
procedure TAAText.DrawCanvas(ACanvas: TCanvas);
var
  i, j: Integer;
  DispLines: TStrings;
  WrapLines: TStrings;
  CurrText: string;
  CurrAlign: TAlignment;
  x, y: Integer;
  TextWidth: Integer;
  TextHeight: Integer;
  MaxCol: Integer;
begin
  BeginUpdate;
  DispLines := nil;
  WrapLines := nil;
  try
    DispLines := TStringList.Create; //临时文本
    WrapLines := TStringList.Create;
    with FText do
    begin
      DispLines.AddStrings(Lines);
      ACanvas.Brush.Color := Color;
      ACanvas.Brush.Style := bsClear;
      ACanvas.Font.Assign(Font);
      AAFont.Canvas := ACanvas;
      AAFont.Effect.Assign(FText.FontEffect);
      CurrAlign := Alignment; //默认对齐方式
      y := Border;
      for i := 0 to DispLines.Count - 1 do
      begin
        if y > ClientHeight - Border then
          Break;
        CurrText := DispLines[i]; //当前处理字符串
        if LabelEffect = leOnlyALine then
        begin
          ACanvas.Font.Assign(Font);
          AAFont.Effect.Assign(FText.FontEffect);
          CurrAlign := Alignment;
        end;
        Fonts.Check(CurrText, ACanvas.Font, AAFont.Effect); //检查字体标签
        Labels.Check(CurrText, CurrAlign); //检查用户标签
        TextWidth := AAFont.TextWidth(CurrText);
        if WordWrap and (TextWidth > ClientWidth - 2 * Border) then //自动换行
        begin
          MaxCol := (ClientWidth - 2 * Border) * Length(CurrText) div TextWidth;
          while AAFont.TextWidth(Copy(CurrText, 1, MaxCol)) > ClientWidth - 2
            * Border do
            Dec(MaxCol);
          WrapText(CurrText, WrapLines, MaxCol);
        end else if CurrText <> '' then
          WrapLines.Text := CurrText
        else
          WrapLines.Text := ' ';
        for j := 0 to WrapLines.Count - 1 do
        begin
          CurrText := WrapLines[j];
          TextHeight := AAFont.TextHeight(CurrText + ' ');
          TextWidth := AAFont.TextWidth(CurrText);
          case CurrAlign of   //对齐方式
            taLeftJustify: x := Border;
            taCenter: x := (ClientWidth - TextWidth) div 2;
            taRightJustify: x := ClientWidth - Border - TextWidth;
          else x := 0;
          end;
          AAFont.TextOut(x, y, CurrText);
          y := y + Round(TextHeight * (1 + RowPitch / 100));
        end;
      end;
      AAFont.Effect.Assign(FText.FontEffect);
    end;
  finally
    DispLines.Free;
    WrapLines.Free;
    EndUpdate;
  end;
end;

//控件属性已装载
procedure TAAText.LoadedEx;
begin
  inherited;
  Reset;
end;

//绘制画布
procedure TAAText.PaintCanvas;
begin
  if Text.Transparent then
    TransparentPaint    //透明
  else
    Bitblt(Canvas.Handle, 0, 0, Width, Height, TextBmp.Canvas.Handle, 0, 0,
      SRCCOPY);
end;

//复位
procedure TAAText.Reset;
begin
  if not Text.Transparent then
    CreateText;
  inherited;
end;

//设置文本
procedure TAAText.SetText(const Value: TTextParam);
begin