marquee.pas

实现字幕滚动的原码,自己下载一下看,可以做为公告提示!

{
Delphi 5 Developer's Guide
Copyright (c) 1995,99 Xavier Pacheco and Steve Teixeira
}
unit Marquee;

interface

uses
  SysUtils, Windows, Classes, Forms, Controls, Graphics,
  Messages, ExtCtrls, Dialogs;

const
  ScrollPixels = 2; // num of pixels for each scroll
  TimerInterval = 50; // time between scrolls in ms

type
  TScrollInterval = 0..10000;

type
  TJustification = (tjCenter, tjLeft, tjRight);

  EMarqueeError = class(Exception);

  TMarquee = class(TCustomPanel)
  private
    MemBitmap: TBitmap;
    InsideRect: TRect;
    FItems: TStringList;
    FJust: TJustification;
    FScrollDown: Boolean;
    LineHi: Integer;
    CurrLine: Integer;
    VRect: TRect;
    //FScrollPixels:Integer;
    FTimer: TTimer;
    FScrollInterval: TScrollInterval;
    FScroolLoop: Boolean;
    FActive: Boolean;
    FOnDone: TNotifyEvent;
    procedure SetItems(Value: TStringList);
    procedure DoTimerOnTimer(Sender: TObject);
    procedure PaintLine(R: TRect; LineNum: Integer);
    procedure SetLineHeight;
    procedure SetStartLine;
    procedure IncLine;
    procedure SetActive(Value: Boolean);
    //滚动间隔时间(毫秒)
    procedure SetScrollInterval(Value: TScrollInterval);
    //循环滚动
    procedure SetScroolLoop(Value: Boolean);
  protected
    procedure Paint; override;
    procedure FillBitmap; virtual;
    //消息捕获，控制是否能滚屏       WM_MBUTTONDOWN WM_MBUTTONUP
    //procedure SetSrollText_MouseDown(var MsgMouse: TMessage); message
    //  WM_MBUTTONDOWN;
    //procedure SetSrollText_MouseUp(var MsgMouse: TMessage); message
    //  WM_MBUTTONUP;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property ScrollDown: Boolean read FScrollDown write FScrollDown;
    property Justify: TJustification read FJust write FJust default tjCenter;
    property Items: TStringList read FItems write SetItems;
    property OnDone: TNotifyEvent read FOnDone write FOnDone;
    { Publish inherited properties: }
    property Active: Boolean read FActive write SetActive;
    property Align;
    property Alignment;
    property Anchors;
    property BevelInner;
    property BevelOuter;
    property BevelWidth;
    property BorderWidth;
    property BorderStyle;
    property Color;
    property Ctl3D;
    property Font;
    //添加属性：时间间隔
    property ScrollInterval: TScrollInterval read FScrollInterval write
      SetScrollInterval default 50;
    //添加属性：是否循环
    property ScroolLoop: Boolean read FScroolLoop write SetScroolLoop default
      True;
    property Locked;
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property Visible;
    property OnClick;
    property OnDblClick;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnResize;
  end;
procedure Register;
implementation
//自定义ICO
{$R *.DCR}

constructor TMarquee.Create(AOwner: TComponent);
{ constructor for TMarquee class }

  procedure DoTimer;
    { procedure sets up TMarquee's timer }
  begin
    FTimer := TTimer.Create(Self);
    with FTimer do
    begin
      Enabled := False;
      Interval := FScrollInterval;
      OnTimer := DoTimerOnTimer;
    end;
  end;

begin
  inherited Create(AOwner);
  FItems := TStringList.Create; { instanciate string list }
  FScrollInterval := 40;
  FScroolLoop := True;
  DoTimer; { set up timer }
  { set instance variable default values }
  Width := 100;
  Height := 75;
  FActive := False;
  FScrollDown := False;
  FJust := tjLeft;
  BevelWidth := 1;
  BevelInner := bvRaised;
  BevelOuter := bvLowered;
  BorderStyle := bsNone;
  Caption := '';
end;

destructor TMarquee.Destroy;
{ destructor for TMarquee class }
begin
  SetActive(False);
  FTimer.Free; // free allocated objects
  FItems.Free;
  inherited Destroy;
end;

procedure TMarquee.DoTimerOnTimer(Sender: TObject);
{ This method is executed in respose to a timer event }
begin
  IncLine;
  { only repaint within borders }
  InvalidateRect(Handle, @InsideRect, False);
end;

procedure TMarquee.IncLine;
{ this method is called to increment a line }
begin
  if not FScrollDown then // if Marquee is scrolling upward
  begin
    { Check to see if marquee has scrolled to end yet }
    if FItems.Count * LineHi + ClientRect.Bottom -
      ScrollPixels >= CurrLine then
      { not at end, so increment current line }
      Inc(CurrLine, ScrollPixels)
    else
    begin
      //如果可以循环，则重新定位行数
      if FScroolLoop then
        SetStartLine;
      SetActive(FScroolLoop);

    end;
  end
  else
  begin // if Marquee is scrolling downward
    { Check to see if marquee has scrolled to end yet }
    if CurrLine >= ScrollPixels then
      { not at end, so decrement current line }
      Dec(CurrLine, ScrollPixels)
    else
    begin
      //如果可以循环，则重新定位行数
      if FScroolLoop then
        SetStartLine;
      SetActive(FScroolLoop);
    end;
  end;
end;

procedure TMarquee.SetItems(Value: TStringList);
begin
  if FItems <> Value then
    FItems.Assign(Value);
end;

procedure TMarquee.SetLineHeight;
{ this virtual method sets the LineHi instance variable }
var
  Metrics: TTextMetric;
begin
  { get metric info for font }
  GetTextMetrics(Canvas.Handle, Metrics);
  { adjust line height }
  LineHi := Metrics.tmHeight + Metrics.tmInternalLeading;
end;

procedure TMarquee.SetStartLine;
{ this virtual method initializes the CurrLine instance variable }
begin
  // initialize current line to top if scrolling up, or...
  if not FScrollDown then
    CurrLine := 0
      // bottom if scrolling down
  else
    CurrLine := VRect.Bottom - Height;
end;

procedure TMarquee.PaintLine(R: TRect; LineNum: Integer);
{ this method is called to paint each line of text onto MemBitmap }
const
  Flags: array[TJustification] of DWORD = (DT_CENTER, DT_LEFT, DT_RIGHT);
var
  S: string;
begin
  { Copy next line to local variable for clarity }
  S := FItems.Strings[LineNum];
  { Draw line of text onto memory bitmap }
  DrawText(MemBitmap.Canvas.Handle, PChar(S), Length(S), R,
    Flags[FJust] or DT_SINGLELINE or DT_TOP); //
end;

procedure TMarquee.FillBitmap;
var
  y, i: Integer;
  R: TRect;
begin
  SetLineHeight; // set height of each line
  { VRect rectangle represents entire memory bitmap }
  VRect := Rect(0, 0, Width, LineHi * FItems.Count + Height * 2);
  { InsideRect rectangle represents interior of beveled border }
  InsideRect := Rect(BevelWidth, BevelWidth, Width - (2 * BevelWidth),
    Height - (2 * BevelWidth));
  R := Rect(InsideRect.Left, 0, InsideRect.Right, VRect.Bottom);
  SetStartLine;
  MemBitmap.Width := Width; // initialize memory bitmap
  with MemBitmap do
  begin
    Height := VRect.Bottom;
    with Canvas do
    begin
      Font := Self.Font;
      Brush.Color := Color;
      FillRect(VRect);
      Brush.Style := bsClear;
    end;
  end;
  y := Height;
  i := 0;
  repeat
    R.Top := y;
    PaintLine(R, i);
    { increment y by the height (in pixels) of a line }
    inc(y, LineHi);
    inc(i);
  until i >= FItems.Count; // repeat for all lines
end;

procedure TMarquee.Paint;
{ this virtual method is called in response to a }
{ Windows paint message }
begin
  if FActive then
    { Copy from memory bitmap to screen }
    BitBlt(Canvas.Handle, 0, 0, InsideRect.Right, InsideRect.Bottom,
      MemBitmap.Canvas.Handle, 0, CurrLine, srcCopy)
  else
    inherited Paint;
end;

procedure TMarquee.SetActive(Value: Boolean);
{ called to activate/deactivate the marquee }
begin
  if Value and (not FActive) and (FItems.Count > 0) then
  begin
    FActive := True; // set active flag
    MemBitmap := TBitmap.Create;
    FillBitmap; // Paint Image on bitmap
    FTimer.Enabled := True; // start timer
  end
  else if (not Value) and FActive then
  begin
    FTimer.Enabled := False; // disable timer,
    if Assigned(FOnDone) {// fire OnDone event,} then
      FOnDone(Self);
    FActive := False; // set FActive to False
    MemBitmap.Free; // free memory bitmap
    Invalidate; // clear control window
  end;
end;

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

procedure TMarquee.SetScrollInterval(Value: TScrollInterval);
begin
  if FScrollInterval <> Value then
  begin
    //SetActive(False);   //重新调用会导致重新滚动文字
    FTimer.Enabled := False;
    FScrollInterval := Value;
    FTimer.Interval := FScrollInterval;
    FTimer.Enabled := True;
    //SetActive(True);
  end;
end;

procedure TMarquee.SetScroolLoop(Value: Boolean);
begin
  if FScroolLoop <> Value then
    FScroolLoop := Value;
end;

{procedure TMarquee.SetSrollText_MouseDown(var MsgMouse: TMessage);
var
  obj: TObject;
begin
  if MsgMouse.LParam = WM_MBUTTONDOWN then
  begin
    obj := Tobject(MsgMouse.lParam);
    if (obj <> nil) and (obj is TMarquee)then
    begin
      FTimer.Enabled := False;
      FActive := False;
    end
  end;
end;

procedure TMarquee.SetSrollText_MouseUp(var MsgMouse: TMessage);
var
  obj: TObject;
begin
  if MsgMouse.LParam = WM_MBUTTONUP then
  begin
    obj := Tobject(MsgMouse.lParam);
    if (obj <> nil) and (obj is TMarquee)then
    begin
      FTimer.Enabled := True;
      FActive := True;
    end
  end;
end;
}
end.