aactrls.pas

AAFONT是一款Delphi控件

  Text.Assign(Value);
end;

//透明绘制
procedure TAAText.TransparentPaint;
begin
  CalcSize;
  DrawCanvas(Canvas);
end;

//默认文本创建默认标签
function TAAText.UseDefaultLabels: Boolean;
begin
  Result := not FText.IsLinesStored;
end;

{ TTextParam }

//--------------------------------------------------------//
//平滑文本参数类                                          //
//--------------------------------------------------------//

//创建
constructor TTextParam.Create(AOwner: TAAGraphicControl;
  ChangedProc: TNotifyEvent);
begin
  inherited;
  Lines.Text := csAATextCopyRight;
end;

//释放
destructor TTextParam.Destroy;
begin
  inherited;
end;

//文本存储
function TTextParam.IsLinesStored: Boolean;
begin
  Result := Lines.Text <> csAATextCopyRight;
end;

{ TAAScrollText }

//--------------------------------------------------------//
//平滑滚动文本控件                                        //
//--------------------------------------------------------//

//控件初始化
constructor TAAScrollText.Create(AOwner: TComponent);
begin
  inherited;
  ControlStyle := ControlStyle + [csOpaque]; //由控件绘制所有客户区
  FText := TScrollTextParam.Create(Self, OnLabelChanged);
  TextBmp := TBitmap.Create;
  TextBmp.PixelFormat := pf24bit;
  CurrBmp := TBitmap.Create;
  CurrBmp.PixelFormat := pf24bit;
  ScrollTimer := TAATimer.Create(Self);
  ScrollTimer.Enabled := False;
  ScrollTimer.OnTimer := OnScrollTimer;
  DelayTimer := TTimer.Create(Self);
  DelayTimer.Enabled := False;
  DelayTimer.OnTimer := OnDelayTimer;
  FCurrPos := 0;
  FRepeatCount := 0;
  FActive := True;
  RepeatDelay := 2000;
  ScrollStep := 1;
  ScrollDelay := 60;
  Color := clWhite;
  SetBounds(0, 0, 240, 280);
end;

//释放
destructor TAAScrollText.Destroy;
begin
  Active := False;
  ScrollTimer.Free;
  DelayTimer.Free;
  TextBmp.Free;
  CurrBmp.Free;
  FText.Free;
  inherited;
end;

//显示文本复位
procedure TAAScrollText.Reset;
var
  tActive: Boolean;
begin
  tActive := Active;
  FRepeatedCount := -1;
  Active := False;
  CreateText;
  FCurrPos := 0;
  Paint;
  Active := tActive;
end;

//绘制控件
procedure TAAScrollText.PaintCanvas;
var
  i: Integer;
  BkRed, BkGreen, BkBlue: Byte;
  tBkColor: TColor;

  //透明混合
  procedure DrawFade(y: Integer; Transparency: Integer);
  const
    MaxPixelCount = 32768;
  type
    PRGBTripleArray = ^TRGBTripleArray;
    TRGBTripleArray = array[0..MaxPixelCount] of TRGBTriple;
  var
    Row: PRGBTripleArray;
    x: Integer;
  begin
    Row := CurrBmp.ScanLine[y];
    for x := 0 to CurrBmp.Width - 1 do
    begin
      if Row[x].rgbtRed <> BkRed then
        Row[x].rgbtRed := Transparency * (Row[X].rgbtRed - BkRed) shr 8 + BkRed;
      if Row[x].rgbtGreen <> BkGreen then
        Row[x].rgbtGreen := Transparency * (Row[X].rgbtGreen - BkGreen) shr 8 + BkGreen;
      if Row[x].rgbtBlue <> BkBlue then
        Row[x].rgbtBlue := Transparency * (Row[X].rgbtBlue - BkBlue) shr 8 + BkBlue;
    end;
  end;
begin
  CurrBmp.Height := Height;
  CurrBmp.Width := Width;
  if FCurrPos + Height <= TextBmp.Height then //完整显示
    BitBlt(CurrBmp.Canvas.Handle, 0, 0, Width, Height, TextBmp.Canvas.Handle, 0,
      FCurrPos, SRCCopy)
  else
  begin                       //首尾相接
    BitBlt(CurrBmp.Canvas.Handle, 0, 0, Width, TextBmp.Height - FCurrPos,
      TextBmp.Canvas.Handle, 0, FCurrPos, SRCCopy);
    BitBlt(CurrBmp.Canvas.Handle, 0, TextBmp.Height - FCurrPos, Width, Height -
      (TextBmp.Height - FCurrPos), TextBmp.Canvas.Handle, 0, 0, SRCCopy);
  end;
  if FText.Fade then          //淡入淡出
  begin
    tBkColor := ColorToRGB(Color);
    BkRed := GetRValue(tBkColor);
    BkGreen := GetGValue(tBkColor);
    BkBlue := GetBValue(tBkColor);
    for i := 0 to FText.FadeHeight - 1 do
    begin
      DrawFade(i, 255 * i div (FText.FadeHeight - 1));
      DrawFade(Height - 1 - i, 255 * i div (FText.FadeHeight - 1));
    end;
  end;                        //绘制到控件画布
  if not (csDestroying in ComponentState) then
    BitBlt(Canvas.Handle, 0, 0, Width, Height, CurrBmp.Canvas.Handle, 0, 0, SRCCopy);
  if Assigned(OnPainted) then
    OnPainted(Self);
end;

//执行滚动
procedure TAAScrollText.OnScrollTimer(Sender: TObject);
begin
  if CurrPos = 0 then         //单次滚动完成
  begin
    FRepeatedCount := FRepeatedCount + 1;
    if (RepeatCount > 0) and (RepeatedCount >= RepeatCount) then
    begin                     //滚动完成
      Active := False;
      FRepeatedCount := -1;
      if Assigned(OnComplete) then
        OnComplete(Self);
      Exit;
    end else if DelayTimer.Interval > 0 then
    begin                     //循环延时
      ScrollTimer.Enabled := False;
      DelayTimer.Enabled := True;
      Exit;
    end;
  end;
  
  if (FScrollStep > 0) and (CurrPos + FScrollStep >= TextBmp.Height) then
    CurrPos := 0
  else if (FScrollStep < 0) and (CurrPos + FScrollStep < 0) then
    CurrPos := 0
  else
    CurrPos := CurrPos + FScrollStep; //当前位置增加
end;

//创建文本位图
procedure TAAScrollText.CreateText;
var
  i, j: Integer;
  DispLines: TStrings;
  CurrText: string;
  WrapLines: TStrings;
  CurrHeight: Integer;
  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
      TextBmp.Height := 0;
      TextBmp.Width := Width;
      TextBmp.Canvas.Brush.Color := Color;
      TextBmp.Canvas.Brush.Style := bsSolid;
      DispLines.Clear;
      DispLines.AddStrings(Lines);
      AAFont.Canvas := TextBmp.Canvas;
      AAFont.Effect.Assign(FText.FontEffect);
      if Fade then            //淡入淡出空白
        CurrHeight := FadeHeight
      else
        CurrHeight := 0;
      CurrHeight := CurrHeight + Height * HeadSpace div 100; //头部空白
      TextBmp.Canvas.Font.Assign(Font);
      for i := 0 to DispLines.Count - 1 do
      begin
        CurrText := DispLines[i]; //当前处理字符串
        if LabelEffect = leOnlyALine then
        begin
          TextBmp.Canvas.Font.Assign(Font);
          AAFont.Effect.Assign(FText.FontEffect);
        end;
        Fonts.Check(CurrText, TextBmp.Canvas.Font, AAFont.Effect); //检查字体标签
        Labels.Check(CurrText, CurrAlign); //检查用户标签
        TextHeight := AAFont.TextHeight(CurrText + ' ');
        TextWidth := AAFont.TextWidth(CurrText);
        if WordWrap and (TextWidth > Width) then //自动换行
        begin
          MaxCol := Width * Length(CurrText) div TextWidth;
          while AAFont.TextWidth(Copy(CurrText, 1, MaxCol)) > Width do
            Dec(MaxCol);
          WrapText(CurrText, WrapLines, MaxCol);
        end else if CurrText <> '' then
          WrapLines.Text := CurrText
        else
          WrapLines.Text := ' ';
        CurrHeight := CurrHeight + Round(TextHeight * (1 + RowPitch / 100)) *
          WrapLines.Count;
      end;
      TextBmp.Canvas.Brush.Color := Color;
      TextBmp.Canvas.Brush.Style := bsSolid;
      CurrHeight := CurrHeight + Height * TailSpace div 100; //尾部空白
      if CurrHeight < ClientHeight then
        CurrHeight := ClientHeight;
      TextBmp.Height := CurrHeight;
      if Assigned(FText.BackGround.Graphic) and not
        FText.BackGround.Graphic.Empty then
        DrawBackGround(TextBmp.Canvas, Rect(0, 0, TextBmp.Width,
          TextBmp.Height), FText.BackGround.Graphic, FText.BackGroundMode);

      DispLines.Clear;
      DispLines.AddStrings(Lines);
      TextBmp.Canvas.Brush.Style := bsClear;
      AAFont.Effect.Assign(FText.FontEffect);
      if Fade then            //淡入淡出空白
        CurrHeight := FadeHeight
      else
        CurrHeight := 0;
      CurrHeight := CurrHeight + Height * HeadSpace div 100; //头部空白
      TextBmp.Canvas.Font.Assign(Font);
      CurrAlign := Alignment; //默认对齐方式
      for i := 0 to DispLines.Count - 1 do
      begin
        CurrText := DispLines[i]; //当前处理字符串
        if LabelEffect = leOnlyALine then
        begin
          TextBmp.Canvas.Font.Assign(Font);
          AAFont.Effect.Assign(FText.FontEffect);
          CurrAlign := Alignment;
        end;
        Fonts.Check(CurrText, TextBmp.Canvas.Font, AAFont.Effect); //检查字体标签
        Labels.Check(CurrText, CurrAlign); //检查用户标签
        TextWidth := AAFont.TextWidth(CurrText);
        if WordWrap and (TextWidth > Width) then //自动换行
        begin
          MaxCol := Width * Length(CurrText) div TextWidth;
          while AAFont.TextWidth(Copy(CurrText, 1, MaxCol)) > Width 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 := 0;
            taCenter: x := (TextBmp.Width - TextWidth) div 2;
            taRightJustify: x := TextBmp.Width - TextWidth;
          else x := 0;
          end;
          y := CurrHeight;      //行间距
          AAFont.TextOut(x, y, CurrText);
          CurrHeight := CurrHeight + Round(TextHeight * (1 + RowPitch / 100));
        end;
      end;
      if Assigned(OnTextReady) then //调用OnTextReady事件
        OnTextReady(Self);
    end;
  finally
    WrapLines.Free;
    DispLines.Free;
    EndUpdate;
  end;
end;

//设置活动
procedure TAAScrollText.SetActive(const Value: Boolean);
begin
  if FActive <> Value then
  begin
    FActive := Value;
    ScrollTimer.Enabled := FActive;
    if not FActive then
      DelayTimer.Enabled := False;
  end;
end;

//设置循环延时
procedure TAAScrollText.SetRepeatDelay(const Value: Word);
begin
  if FRepeatDelay <> Value then
  begin
    FRepeatDelay := Value;
    if FRepeatDelay <= 0 then
      FRepeatDelay := 0;
    DelayTimer.Interval := Value;
  end;
end;

//设置滚动延时
procedure TAAScrollText.SetScrollDelay(const Value: Word);
begin
  if FScrollDelay <> Value then
  begin
    FScrollDelay := Value;
    if FScrollDelay <= 0 then
      FScrollDelay := 0;
    ScrollTimer.Interval := FScrollDelay;
  end;
end;

//设置每次滚动增量
procedure TAAScrollText.SetScrollStep(const Value: Integer);
begin
  if FScrollStep <> Value then
  begin
    FScrollStep := Value;
  end;
end;

//设置循环次数
procedure TAAScrollText.SetRepeatCount(const Value: TBorderWidth);
begin
  if FRepeatCount <> Value then
  begin
    FRepeatCount := Value;
    if FRepeatCount <= 0 then
      FRepeatCount := 0;
    Changed;
  end;
end;

//设置文本内容
procedure TAAScrollText.SetText(const Value: TScrollTextParam);
begin
  FText.Assign(Value);
end;

//重头开始滚动
procedure TAAScrollText.ReStart;
begin
  FRepeatedCount := -1;
  CurrPos := 0;
end;

//设置当前位置
procedure TAAScrollText.SetCurrPos(const Value: Integer);
begin
  if FCurrPos <> Value then
  begin
    FCurrPos := Value mod TextBmp.Height;
    if FCurrPos < 0 then
      Inc(FCurrPos, TextBmp.Height);
    Paint;
  end;
end;

//大小变化消息
function TAAScrollText.CanResize(var NewWidth,
  NewHeight: Integer): Boolean;
begin
  if NewWidth < 20 then NewWidth := 20;
  if NewHeight < 20 then NewHeight := 20;
  Result := inherited CanResize(NewWidth, NewHeight);
end;

//循环延时
procedure TAAScrollText.OnDelayTimer(Sender: TObject);
begin
  DelayTimer.Enabled := False;
  CurrPos := CurrPos + FScrollStep;
  if Active then
    ScrollTimer.Enabled := True;
end;

//创建默认字体集
procedure TAAScrollText.CreateDefFonts;
var
  FLabel: TFontLabel;
begin
  inherited;
  FLabel := Fonts.AddItem('Title4', '隶书', 22, clBlack, [fsBold], True, 2, 2);
  if Assigned(FLabel) then
  begin
    FLabel.Effect.Gradual.Enabled := True;
    FLabel.Effect.Gradual.Style := gsLeftToRight;
    FLabel.Effect.Gradual.StartColor := $00FF2200;