scrolltext.pas

ScrollText_V1.0-自动字幕控件

{******************************************************************************
*              自动字幕控件 - TScrollText                                     *
*                                                                             *
*      功能： 在指定位置显示滚动字幕                                          *
*      版本： V1.03                                                           *
*      作者： 顾中军                                                          *
*      用法：                                                                 *
*        1、Active:        用于设置控件是否处于活动状态                       *
*        2、Interval:      用于设置字幕滚动周期（毫秒）                       *
*        3、ScrollText:    用于设置滚动字幕                                   *
*        4、Step:          用于设置每次滚动像素点数                           *
*        5、ScrollDirect:  用于指示滚动方向                                   *
*        6、其它属性及事件句柄的使用同TLabel控件                              *
*      实现：                                                                 *
*          2005.2.18 灵感忽来，很快实现了左右滚动功能                         *
*          2005.2.19 加上了上下滚动功能，并完善了代码                         *
*          2005.2.20 加上滚动完一屏后触发相关事件的功能                       *
*      说明：                                                                 *
*          两年前，我曾用截断字符串的方法做过一个滚动字幕控件，不过那东东只能 *
*      由右向左滚动，而且还有问题。                                           *
*          这次却是在晚上静坐时忽然来的灵感，在查看了TCustomLabel的源码后，我 *
*      确定可以用简单的方法实现滚动字幕，马上动手一试，哈，还真可以！         *
*          这个版本的实现也有限制，主要是Alignment及Layout属性在左右、上下滚  *
*      动时分别各有限制。实际上，要让其没有限制应该是可以实现的，不过，我以为 *
*      现在这样的实现挺好，没必要为了无限制而加上一大堆代码！                 *
*          最后声明一下，这个东东只有300余行代码（包括注释*.*），所以你爱怎么 *
*      用它或修改它，都完全没问题啦。只是希望你如果作了改进，能给我发一份；此 *
*      外，如果你是在它的基础上改进而来，至少得提一下来源噢。                 *
*          祝你愉快！！！                                                     *
*                                                                             *
*      Email:     [e-mail]                                           *
******************************************************************************}

unit ScrollText;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, StdCtrls, ExtCtrls;

type
  TScrollDirect = (sdLeft, sdRight, sdUp, sdDown);
  TFrameScrolledEvent = procedure (Direct: TScrollDirect; CurPos: Integer;
       var Abort: Boolean) of object;

  TScrollText = class(TCustomLabel)
  private
    FActive:    boolean;       //处于滚动显示状态?
    FInterval:  integer;       //定时器间隔
    FLastPos:   integer;       //上一次滚动位置，滚动显示信息用
    FStep:      Integer;       //每次滚动像素点数
    FTimer:     TTimer;        //定时器
    FText:      string;        //滚动显示原始信息
    FTxtWidth:  integer;       //滚动显示信息长
    FTxtHeight: Integer;       //滚动显示信息高
    FDirect:    TScrollDirect; //滚动方向
    FFrameScrolledEvent: TFrameScrolledEvent;   //滚动完一屏后触发的事件
    procedure ScrollTimer(Sender: TObject);
    procedure SetActive(Value: boolean);
    procedure SetInterval(Value: integer);
    procedure SetText(const Value: string);
    procedure SetStep(Value: Integer);
    procedure SetDirect(Value: TScrollDirect);
    procedure SetAlignment(Value: TAlignment);
    procedure SetLayout(Value: TTextLayout);
  protected
    procedure DoDrawText(var Rect: TRect; Flags: Longint); override;
    function GetLabelText: string; override;
    procedure SetName(const Value: TComponentName); override;

    property AutoSize default false;
    property Caption;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Reset;
  published
    property Active :boolean read FActive write SetActive default true;
    property Align;
    property Alignment write SetAlignment default taLeftJustify;
    property Anchors;
    //property BiDiMode;
    property Color;
    property Constraints;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    //property FocusControl;
    property Font;
    property Interval: integer read FInterval write SetInterval default 200;
    property Layout write SetLayout default tlCenter;
    //property ParentBiDiMode;
    property ParentColor;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    //property ShowAccelChar;
    property ShowHint;
    property ScrollDirection: TScrollDirect read FDirect write SetDirect
                 default sdLeft;
    property ScrollText: string read FText write SetText;
    property Step: Integer read FStep write SetStep default 5;
    property Transparent;
    property Visible;
    //property WordWrap;
    property OnClick;
    property OnContextPopup;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDock;
    property OnEndDrag;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnStartDock;
    property OnStartDrag;
    property OnFrameScrolled: TFrameScrolledEvent
        read FFrameScrolledEvent write FFrameScrolledEvent;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Standard', [TScrollText]);
end;

constructor TScrollText.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  AutoSize  := false;
  WordWrap  := false;
  FActive   := true;
  FDirect   := sdLeft;
  FTimer    := TTimer.Create(Self);
  FTimer.OnTimer  := ScrollTimer;
  FTimer.Enabled  := FActive;
  FInterval       := 200;
  FTimer.Interval := FInterval;

  FLastPos := 0;
  FStep    := 5;
  Color    := clGreen;
  Font.Charset := GB2312_CHARSET;
  Font.Color   := clAqua;
  Font.Height  := -12;
  Font.Name    := '宋体';
  Width  := 200;
  Layout := tlCenter;
end;

destructor TScrollText.Destroy;
begin
  FTimer.Free;
  inherited Destroy;
end;

procedure TScrollText.ScrollTimer(Sender: TObject);
var
  bAbort: Boolean;
begin
  if FStep = 0 then Exit;
  Active         := False;
  FTimer.OnTimer := nil;
  bAbort         := False;
  case FDirect of
    sdLeft:            //由右向左滚动
      begin
        Dec(FLastPos, FStep);
        if (FLastPos < 0) and (Abs(FLastPos) > FTxtWidth) then
        begin
          if Assigned(FFrameScrolledEvent) then
            FFrameScrolledEvent(FDirect, FLastPos, bAbort);
          if not bAbort then
            FLastPos   := Self.ClientWidth - 1;
        end;
      end;
    sdRight:           //由左向右滚动
      begin
        Inc(FLastPos, FStep);
        if (FLastPos > 0) and (FLastPos > Self.ClientWidth) then
        begin
          if Assigned(FFrameScrolledEvent) then
            FFrameScrolledEvent(FDirect, FLastPos, bAbort);
          if not bAbort then
            FLastPos   := - FTxtWidth + 1;
        end;
      end;
    sdUp:              //由下向上滚动
      begin
        Dec(FLastPos, FStep);
        if (FLastPos < 0) and (Abs(FLastPos) > FTxtHeight) then
        begin
          if Assigned(FFrameScrolledEvent) then
            FFrameScrolledEvent(FDirect, FLastPos, bAbort);
          if not bAbort then
            FLastPos   := Self.ClientHeight - 1;
        end;
      end;
    sdDown:            //由上向下滚动
      begin
        Inc(FLastPos, FStep);
        if (FLastPos > 0) and (FLastPos > Self.ClientHeight) then
        begin
          if Assigned(FFrameScrolledEvent) then
            FFrameScrolledEvent(FDirect, FLastPos, bAbort);
          if not bAbort then
            FLastPos   := - FTxtHeight + 1;
        end;
      end;
  end;
  Self.Invalidate;
  if not bAbort then
    Active         := True;
  FTimer.OnTimer   := ScrollTimer;
end;

procedure TScrollText.SetActive(Value: Boolean);
begin
  if FActive <> Value then
  begin
    FActive        := Value;
    FTimer.Enabled := Value;
  end;
end;

procedure TScrollText.SetInterval(Value: Integer);
begin
  if FInterval <> Value then
  begin
    FInterval       := Value;
    FTimer.Interval := Value;
  end;
end;

procedure TScrollText.SetText(const Value: String);
var
  ARect: TRect;
  iWidth: Integer;

  function CalcTxtHeight: Integer;
  begin                   //计算显示当前文本所需高度
    Result := DrawText(Canvas.Handle,
                       PChar(FText),
                       Length(FText),
                       ARect,
                       DT_CALCRECT
                      );
  end;

  function CalcTxtWidth: Integer;
  begin                   //计算显示当前文本所需宽度
    DrawText(Canvas.Handle,
             PChar(FText),
             Length(FText),
             ARect,
             DT_CALCRECT
            );
    Result := ARect.Right - ARect.Left;
  end;

  function CalcTxtWidth_2: Integer;
  var      //似乎还是本方法计算得准确一些！DrawText得出的结果总是小了不少
    i, iLen: Integer;
  begin
    Result := Abs(Self.Font.Height) * Length(FText) div 2;
    with TStringList.Create do
      try
        Text := FText;
        if Count > 1 then
        begin
          iLen := 0;
          for i:=0 to Count-1 do
            if Length(Strings[i]) > iLen then
              iLen := Length(Strings[i]);
          Result   := Abs(Self.Font.Height) * iLen div 2;
        end;
      finally
        Free;
      end;
  end;

begin
  FText      := Value;
  ARect      := Self.ClientRect;
  FTxtWidth  := CalcTxtWidth(); // Canvas.TextWidth(Value);
  FTxtHeight := CalcTxtHeight();// Canvas.TextHeight(Value);
  iWidth     := CalcTxtWidth_2();
  if FTxtWidth < iWidth then
    FTxtWidth := iWidth;
  FLastPos   := 0;

  Self.Invalidate;
end;

procedure TScrollText.DoDrawText(var Rect: TRect; Flags: Longint);
begin
  case FDirect of               //关键！虽然只几行代码^o^
    sdLeft, sdRight:  Rect.Left := Rect.Left + Self.FLastPos;
    sdUp, sdDown:     Rect.Top  := Rect.Top  + Self.FLastPos;
  end;
  inherited DoDrawText(Rect, Flags);
end;

function TScrollText.GetLabelText: String;
begin
  Result := Self.FText;
end;

procedure TScrollText.SetName(const Value: TComponentName);
var
  bChangeText: Boolean;
begin
  bChangeText := (Name = FText);
  inherited SetName(Value);

  if (csDesigning in ComponentState) and (not(csLoading in ComponentState)) then
    if bChangeText then
      ScrollText := Value;//设置设计时的初始文本
end;

procedure TScrollText.SetStep(Value: Integer);
begin                     
  if (FStep <> Value) and (Value < Self.ClientWidth) then
    FStep := Value;       //设置每次滚动像素点数
end;

procedure TScrollText.SetDirect(Value: TScrollDirect);
begin
  if FDirect <> Value then
  begin
    FDirect := Value;     //设置滚动方向
    case Value of
      sdLeft, sdRight:    //左右滚动
        begin
          Self.WordWrap := false;
          Alignment     := taLeftJustify; //则Alignment始终为taLeftJustify
        end;
      sdUp, sdDown:       //上下滚动
        begin
          Self.WordWrap := true;
          Layout        := tlTop;         //则Layout始终为tlTop
        end;
    end;
    ScrollText := FText;  //重新赋值是为了重新计算FTxtHeight, FTxtWidth
  end;
end;

procedure TScrollText.SetAlignment(Value: TAlignment);
begin
  if Alignment <> Value then
  begin
    case FDirect of       //左右滚动时，则Alignment始终为taLeftJustify
      sdLeft, sdRight: inherited Alignment := taLeftJustify;
      sdUp, sdDown:    inherited Alignment := Value;
    end;
  end;
end;

procedure TScrollText.SetLayout(Value: TTextLayout);
begin
  if Layout <> Value then
  begin
    case FDirect of
      sdLeft, sdRight: inherited Layout := Value;
      sdUp, sdDown:    inherited Layout := tlTop; //上下滚动时,Layout始终为tlTop 
    end;
  end;
end;

procedure TScrollText.Reset;  //复位，即让显示回到原位
begin
  Self.FLastPos := 0;
  Self.Invalidate;
end;

end.