参考lazarus的about的滚动字符功能，编写了一个字幕滚动控件（2024.03.02更新）

lazarus的about的滚动字挺好的，参考lazarus的about的滚动字符功能，编写了一个字幕滚动控件，增加了字体颜色/字体大小和斜体等功能:
scrollingtext.pas

unit ScrollingText;

interface

uses
  Classes, SysUtils, Forms, Controls, Graphics, StdCtrls, Buttons, ExtCtrls, ComCtrls,
  FPCAdds,lclintf,LazFileUtils;

type

  TLineType = record
     str:string;
     FontColor:TColor;
     FontStyle:TFontStyle;
     FontSize:integer;
     LineHeight:integer;
  end;

  TScrollingText = class(TCustomControl)
  private
    LineList:array of TLineType;
    FActive: boolean;
    FActiveLine: integer;   //the line over which the mouse hovers
    FBuffer: TBitmap;
    FLineHeight: integer;
    FLines: TStrings;
    FOffset: integer;
    FStepSize: integer;
    FTimer: TTimer;
    function ActiveLineIsURL: boolean;
    procedure DoTimer(Sender: TObject);
    procedure SetActive(const AValue: boolean);
    procedure Init;
    procedure DrawScrollingText(Sender: TObject);
    procedure SetLines(const AValue: TStrings);
  protected
    procedure DoOnChangeBounds; override;
    procedure MouseDown(Button: TMouseButton; Shift:TShiftState; X,Y:Integer); override;
    procedure MouseMove(Shift: TShiftState; X,Y: Integer); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Lines: TStrings read FLines write SetLines;
    property Active: boolean read FActive write SetActive;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('ScrollingText', [TScrollingText]);
end;

{ TScrollingText }

procedure TScrollingText.SetLines(const AValue: TStrings);
begin
  if (AValue <> nil) then
  begin
    if FActive then
      FTimer.Enabled:=false;
    FLines.Assign(AValue);
    Init;
    if FActive then
      FTimer.Enabled:=FActive;
  end;
end;

procedure TScrollingText.SetActive(const AValue: boolean);
begin
  FActive := AValue;
  if FActive then
    Init;
  FTimer.Enabled:=Active;
end;

procedure TScrollingText.Init;
var i,oldfontsize:integer;
  s:string;
  Linesnew: TStrings;
begin
  oldfontsize:=FBuffer.Canvas.Font.Size;
  setlength(LineList,FLines.Count);
  FLineHeight:=0;
  for i := 0 to FLines.Count-1 do
  begin
    s := Trim(FLines[i]);

    //skip empty lines
    if Length(s) > 0 then
    begin
      //check for bold format token
      if s[1] = '#' then
      begin
        s := copy(s, 2, Length(s) - 1);
        LineList[i].FontStyle := fsBold;
      end
      else
      if s[1] = '@' then
      begin
        s := copy(s, 2, Length(s) - 1);
        LineList[i].FontStyle := fsStrikeOut;
      end
      else
      if s[1] = '$' then
      begin
        s := copy(s, 2, Length(s) - 1);
        LineList[i].FontStyle := fsItalic;
      end
      else
      if s[1] = '!' then
      begin
        s := copy(s, 2, Length(s) - 1);
        LineList[i].FontStyle := fsUnderline;
      end
      else
      begin
        //check for url
        if (Pos('http://', s) = 1) or (Pos('https://', s) = 1) then
        begin
          if i = FActiveLine then
          begin
            LineList[i].FontStyle := fsUnderline;
            LineList[i].FontColor := clRed;
          end
          else
            LineList[i].FontColor := clBlue;
         end;
      end;
      if s[1] = 'C' then
      begin
        if s[2] = '1' then
         LineList[i].FontColor := clBlack;
        if s[2] = '2' then
         LineList[i].FontColor := clRed;
        if s[2] = '3' then
         LineList[i].FontColor := clYellow;
        if s[2] = '4' then
         LineList[i].FontColor := clGreen;
        if s[2] = '5' then
         LineList[i].FontColor := clBlue;
        s := copy(s, 3, Length(s) - 1);
      end;
      if s[1] = 'S' then
      begin
        if s[2] = '1' then
         LineList[i].FontSize := 9
        else
        if s[2] = '2' then
         LineList[i].FontSize := 12
        else
        if s[2] = '3' then
         LineList[i].FontSize := 14
        else
        if s[2] = '4' then
         LineList[i].FontSize := 16
         else
        if s[2] = '5' then
         LineList[i].FontSize := 18;
        s := copy(s, 3, Length(s) - 1);
      end
      else
      begin
        LineList[i].FontSize:=oldfontsize;
      end;
      LineList[i].str:=s;
      self.Canvas.Font.Size:=LineList[i].FontSize;
      LineList[i].LineHeight:=self.Canvas.TextHeight('X');
      FLineHeight:=FLineHeight+LineList[i].LineHeight;
    end;
  end;
  FBuffer.Width := Width;
  FBuffer.Height := Height;

  if FOffset = -1 then
    FOffset := FBuffer.Height;

  with FBuffer.Canvas do
  begin
    Brush.Color := clWhite;
    Brush.Style := bsSolid;
    FillRect(0, 0, Width, Height);
  end;
end;

procedure TScrollingText.DrawScrollingText(Sender: TObject);
begin
  if Active then
    Canvas.Draw(0,0,FBuffer);
end;

procedure TScrollingText.DoTimer(Sender: TObject);
var
  y,w: integer;
  s: string;
  i: integer;
begin
  if not Active then
    Exit;

  Dec(FOffset, FStepSize);

  with FBuffer.Canvas do
  begin
    Brush.Color := clWhite;
    Brush.Style := bsSolid;
    FillRect(0, 0, Width, Height);
  end;

  //FBuffer.Canvas.FillRect(Rect(0, 0, FBuffer.Width, FBuffer.Height));
  y:=0;
  for i:=0 to  FLines.Count - 1 do
  begin
    FBuffer.Canvas.Font.Size:=LineList[i].FontSize;
    FBuffer.Canvas.Font.Style:=[LineList[i].FontStyle];
    FBuffer.Canvas.Font.Color:=LineList[i].FontColor;
    w := FBuffer.Canvas.TextWidth(LineList[i].str);
    FBuffer.Canvas.TextOut((FBuffer.Width - w) div 2, FOffset + y, LineList[i].str);
    y:=y+ LineList[i].LineHeight;
  end;
  if FOffset+FLineHeight=0 then
    FOffset := FBuffer.Height;
  Invalidate;
end;

function TScrollingText.ActiveLineIsURL: boolean;
begin
  if (FActiveLine > 0) and (FActiveLine < FLines.Count) then
    Result := (Pos('http://', FLines[FActiveLine]) = 1) or (Pos('https://', FLines[FActiveLine]) = 1)
  else
    Result := False;
end;

procedure TScrollingText.DoOnChangeBounds;
begin
  inherited DoOnChangeBounds;

  Init;
end;

procedure TScrollingText.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
begin
  inherited MouseDown(Button, Shift, X, Y);

  if ActiveLineIsURL then
    OpenURL(FLines[FActiveLine]);
end;

procedure TScrollingText.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
  inherited MouseMove(Shift, X, Y);

  //calculate what line is clicked from the mouse position
  FActiveLine := (Y - FOffset) div FLineHeight;

  Cursor := crDefault;

  if (FActiveLine >= 0) and (FActiveLine < FLines.Count) and ActiveLineIsURL then
    Cursor := crHandPoint;
end;

constructor TScrollingText.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);

  ControlStyle := ControlStyle + [csOpaque];

  OnPaint := @DrawScrollingText;
  FLines := TStringList.Create;
  FTimer := TTimer.Create(nil);
  FTimer.OnTimer:=@DoTimer;
  FTimer.Interval:=30;
  FBuffer := TBitmap.Create;
  Parent:=TWinControl(AOwner);
  FStepSize := 1;
  FOffset := -1;
end;

destructor TScrollingText.Destroy;
begin
  LineList:=nil;
  FLines.Free;
  FTimer.Free;
  FBuffer.Free;
  inherited Destroy;
end;

initialization
   //init;

end.

scrollingtextpack.pas

{ This file was automatically created by Lazarus. Do not edit!
  This source is only used to compile and install the package.
 }

unit ScrollingTextPack;

{$warn 5023 off : no warning about unused units}
interface

uses
  ScrollingText, LazarusPackageIntf;

implementation

procedure Register;
begin
  RegisterUnit('ScrollingText', @ScrollingText.Register);
end;

initialization
  RegisterPackage('ScrollingTextPack', @Register);
end.

scrollingtextpack.lpk:

<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
  <Package Version="5">
    <PathDelim Value="\"/>
    <Name Value="ScrollingTextPack"/>
    <Type Value="RunAndDesignTime"/>
    <CompilerOptions>
      <Version Value="11"/>
      <PathDelim Value="\"/>
      <SearchPaths>
        <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
      </SearchPaths>
    </CompilerOptions>
    <Files>
      <Item>
        <Filename Value="ScrollingText.pas"/>
        <HasRegisterProc Value="True"/>
        <UnitName Value="ScrollingText"/>
      </Item>
      <Item>
        <Filename Value="scrollingtextpack.pas"/>
        <UnitName Value="ScrollingTextPack"/>
      </Item>
    </Files>
    <RequiredPkgs>
      <Item>
        <PackageName Value="LCL"/>
      </Item>
      <Item>
        <PackageName Value="FCL"/>
      </Item>
    </RequiredPkgs>
    <UsageOptions>
      <UnitPath Value="$(PkgOutDir)"/>
    </UsageOptions>
    <PublishOptions>
      <Version Value="2"/>
      <UseFileFilters Value="True"/>
    </PublishOptions>
  </Package>
</CONFIG>

demo：

unit unit3;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls,
  ScrollingText;

type

  { TForm1 }

  TForm1 = class(TForm)
    ScrollingText1: TScrollingText;
    procedure FormCreate(Sender: TObject);
  private

  public

  end;

var
  Form1: TForm1;

implementation

{$R *.lfm}

{ TForm1 }

procedure TForm1.FormCreate(Sender: TObject);
begin
  ScrollingText1.Active:=true;
end;

end.

lmf:

object Form1: TForm1
  Left = 397
  Height = 220
  Top = 36
  Width = 595
  Caption = 'Form1'
  ClientHeight = 220
  ClientWidth = 595
  DesignTimePPI = 144
  OnCreate = FormCreate
  object ScrollingText1: TScrollingText
    Left = 56
    Height = 192
    Top = 8
    Width = 496
    Lines.Strings = (
      '!C2S1下划线'
      '@C5S5删除线'
      '#C4S3粗体'
      '$S4斜体'
      'http://www.cnblogs.com/qiufeng2014/'
    )
    Active = True
  end
end

posted on 2024-03-02 07:50 秋·风阅读(192) 评论(2) 编辑收藏举报

会员力量，点亮园子希望

刷新页面返回顶部

秋·风

公告