{******************************************************************************
*              自動字幕控件 - 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:     iamdream@yeah.net                                           *
******************************************************************************}

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.