Ticker-Text

[sakura]

Und jetzt das pixelweise Scrollen als kleine liebe Komponente.

Delphi-Quellcode:

unit uDPTicker;

interface

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

type
  TdpTicker = class(TGraphicControl)
  private
    FTimer: TTimer;
    FXPos, FTextWidth: Integer;
    FRunAtDesignTime: Boolean;
    procedure OnTimer(Sender: TObject);
    function GetCaption: TCaption;
    procedure SetCaption(const Value: TCaption);
    function GetSpeed: Integer;
    procedure SetSpeed(const Value: Integer);
    procedure SetRunAtDesignTime(const Value: Boolean);
  protected
    procedure Paint; override;
    procedure SetEnabled(Value: Boolean); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Speed: Integer read GetSpeed write SetSpeed;
    property Caption: TCaption read GetCaption write SetCaption;
    property RunAtDesignTime: Boolean read FRunAtDesignTime write SetRunAtDesignTime;

    property Align;
    property Anchors;
    property Color;
    property Enabled;
    property Constraints;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Font;
    property Height;
    property ParentColor;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property Width;
    property Visible;
    property OnClick;
    property OnContextPopup;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDock;
    property OnEndDrag;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnStartDock;
    property OnStartDrag;

  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Delphi-PRAXiS', [TdpTicker]);
end;

{ TdpTicker }

constructor TdpTicker.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Width := 150;
  Height := 25;
  FTimer := TTimer.Create(Self);
  FTimer.Interval := 15;
  FTimer.OnTimer := OnTimer;
  FRunAtDesignTime := False;
  FTimer.Enabled := not (csDesigning in ComponentState);
end;

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

function TdpTicker.GetCaption: TCaption;
begin
  Result := inherited Caption;
end;

function TdpTicker.GetSpeed: Integer;
begin
  Result := FTimer.Interval;
end;

procedure TdpTicker.OnTimer(Sender: TObject);
begin
  Paint;
end;

procedure TdpTicker.Paint;
var
  Bmp: TBitmap;
begin
  Bmp := TBitmap.Create;
  try
    Bmp.Canvas.Brush.Color := Color;
    Bmp.Canvas.Brush.Style := bsSolid;

    Bmp.Canvas.Font.Assign(Font);
    Bmp.Width := Width;
    Bmp.Height := Height;

    Bmp.Canvas.TextOut(FXPos, (Height - Canvas.TextHeight(Caption)) div 2,
        Caption);
    Dec(FXPos);
    if FXPos + FTextWidth < 0 then
      FXPos := Width;

    Canvas.CopyRect(Canvas.ClipRect, Bmp.Canvas, Canvas.ClipRect);
  finally
    Bmp.Free;
  end;
end;

procedure TdpTicker.SetCaption(const Value: TCaption);
begin
  inherited Caption := Value;
  FXPos := Width;
  if Canvas <> nil then
    FTextWidth := Canvas.TextWidth(Caption);
end;

procedure TdpTicker.SetEnabled(Value: Boolean);
begin
  inherited Enabled := Value;
  FTimer.Enabled := ((not (csDesigning in ComponentState)) or FRunAtDesignTime)
      and Enabled;
end;

procedure TdpTicker.SetRunAtDesignTime(const Value: Boolean);
begin
  FRunAtDesignTime := Value;
  FTimer.Enabled := ((not (csDesigning in ComponentState)) or FRunAtDesignTime)
      and Enabled;
end;

procedure TdpTicker.SetSpeed(const Value: Integer);
begin
  FTimer.Interval := Value;
end;

end.

......