www.pudn.com > 自动计划（autoplan）源代码___强烈推荐 .rar > ALScrollingText.pas
{
ALScrollingText v1.03
(C)1999-2000 Andrew Leigh
http://www.alphalink.com.au/~leigh/components
Description:
This component displays a horizontal scrolling text message with edge
fading.
History:
v1.0 03-Jul-1999 Initial release.
v1.01 10-Oct-1999 Fixed scroll resizing problem when font was changed.
v1.02 26-Jan-2000 Added ParentFont property, some mouse events and altered
default colors.
v1.03 30-Dec-2000 Fixed problem with Visible property not working properly
while component was enabled.
}
unit ALScrollingText;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls;
type
TTextLayout = (tlTop, tlCenter, tlBottom);
TTextDirection = (tdLeftToRight, tdRightToLeft);
TALScrollingText = class(TGraphicControl)
private
fText: String;
Timer: TTimer;
fSpeed: Integer;
fBackgroundColor: TColor;
BackBitmap: TBitmap;
DrawnBitmap: TBitmap;
WholeBitmap: TBitmap;
Position: Integer;
fEdgeFade: Boolean;
fEdgeFadeWidth: Integer;
fLayout: TTextLayout;
fTextDirection: TTextDirection;
fPixelJump: Integer;
fVisible: Boolean;
procedure SetText(const Value: String);
procedure SetSpeed(const Value: Integer);
procedure OnTimer(Sender: TObject);
procedure SetBackgroundColor(const Value: TColor);
procedure CMFontChanged(var Msg: TMessage); message CM_FontChanged;
procedure InvalidateEverything;
procedure SetEdgeFadeWidth(const Value: Integer);
function CalcColorIndex(StartColor, EndColor: TColor; Steps, ColorIndex: Integer): TColor;
procedure SetLayout(const Value: TTextLayout);
procedure SetTextDirection(const Value: TTextDirection);
procedure SetVisible(const Value: Boolean);
protected
procedure Paint; override;
procedure Loaded; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Resize; override;
published
property Text: String read fText write SetText;
property Speed: Integer read fSpeed write SetSpeed default 50;
property BackgroundColor: TColor read fBackgroundColor write SetBackgroundColor default clBtnFace;
property EdgeFadeWidth: Integer read fEdgeFadeWidth write SetEdgeFadeWidth default 15;
property Layout: TTextLayout read fLayout write SetLayout default tlCenter;
property TextDirection: TTextDirection read fTextDirection write SetTextDirection default tdLeftToRight;
property PixelJump: Integer read fPixelJump write fPixelJump default 1;
property Visible: Boolean read fVisible write SetVisible;
property Font;
property Enabled;
property ParentFont;
property OnMouseDown;
property OnMouseUp;
property OnClick;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('ALComps', [TALScrollingText]);
end;
{ TALScrollingText }
constructor TALScrollingText.Create(AOwner: TComponent);
begin
inherited;
BackBitmap := TBitmap.Create;
DrawnBitmap := TBitmap.Create;
WholeBitmap := TBitmap.Create;
WholeBitmap.Transparent := True;
Timer := TTimer.Create(nil);
Timer.OnTimer := OnTimer;
Width := 50;
Height := 18;
ParentFont := True;
fVisible := True;
fText := 'Text';
Speed := 50;
fEdgeFade := True;
fEdgeFadeWidth := 15;
fBackgroundColor := clBtnFace;
fLayout := tlCenter;
fTextDirection := tdLeftToRight;
fPixelJump := 1;
Position := -Width;
Font.Color := clWindowText;
end;
destructor TALScrollingText.Destroy;
begin
Timer.Free;
BackBitmap.Free;
DrawnBitmap.Free;
WholeBitmap.Free;
inherited;
end;
procedure TALScrollingText.Loaded;
begin
inherited;
InvalidateEverything;
if fTextDirection = tdLeftToRight then
Position := -(WholeBitmap.Width - Width)
else
Position := 0;
end;
procedure TALScrollingText.OnTimer(Sender: TObject);
begin
if Enabled then
begin
if fTextDirection = tdLeftToRight then
begin
Inc(Position, fPixelJump);
if Position >= 0 then
Position := -WholeBitmap.Width + Width;
end
else
begin
Dec(Position, fPixelJump);
if Position <= -(WholeBitmap.Width - Width) then
Position := 0;
end;
Paint;
end;
end;
procedure TALScrollingText.Paint;
begin
inherited;
BitBlt(DrawnBitmap.Canvas.Handle, 0, 0, Width, Height, BackBitmap.Canvas.Handle, 0, 0, SrcCopy);
DrawnBitmap.Canvas.Draw(Position, 0, WholeBitmap);
BitBlt(Canvas.Handle, 0, 0, Width, Height, DrawnBitmap.Canvas.Handle, 0, 0, SrcCopy);
end;
procedure TALScrollingText.InvalidateEverything;
var
i: Integer;
begin
with WholeBitmap do
begin
Canvas.Brush.Color := fBackgroundColor;
Canvas.FillRect(Rect(0, 0, Width, Height));
Canvas.Font := Self.Font;
Width := WholeBitmap.Canvas.TextWidth(fText) + (2 * Self.Width);
Height := Self.Height;
if (Self.Font.Color = clGreen) or (fBackgroundColor = clGreen) then
begin
TransparentColor := clRed;
Canvas.Font.Color := clRed;
end
else
begin
TransparentColor := clGreen;
Canvas.Font.Color := clGreen;
end;
if fLayout = tlTop then
Canvas.TextOut(Self.Width, 0, fText)
else if fLayout = tlCenter then
Canvas.TextOut(Self.Width, (Self.Height div 2) - (Canvas.TextHeight(fText) div 2), fText)
else
Canvas.TextOut(Self.Width, Self.Height - Canvas.TextHeight(fText), fText);
end;
with BackBitmap do
begin
Width := Self.Width;
Height := Self.Height;
Canvas.Brush.Color := Self.Font.Color;
Canvas.FillRect(Rect(0, 0, Self.Width, Self.Height));
if fEdgeFadeWidth > 0 then
begin
for i := 0 to fEdgeFadeWidth-1 do
begin
Canvas.Pen.Color := CalcColorIndex(fBackgroundColor, Self.Font.Color, fEdgeFadeWidth, i+1);
Canvas.MoveTo(i, 0);
Canvas.LineTo(i, Self.Height);
Canvas.MoveTo(Width-i-1, 0);
Canvas.LineTo(Width-i-1, Self.Height);
end;
end;
end;
DrawnBitmap.Width := Width;
DrawnBitmap.Height := Height;
end;
procedure TALScrollingText.CMFontChanged(var Msg: TMessage);
begin
inherited;
InvalidateEverything;
Msg.Result := 1;
end;
procedure TALScrollingText.Resize;
begin
inherited;
InvalidateEverything;
end;
procedure TALScrollingText.SetBackgroundColor(const Value: TColor);
begin
if fBackgroundColor <> Value then
begin
fBackgroundColor := Value;
InvalidateEverything;
end;
end;
procedure TALScrollingText.SetSpeed(const Value: Integer);
begin
if fSpeed <> Value then
begin
fSpeed := Value;
Timer.Interval := Value;
end;
end;
procedure TALScrollingText.SetText(const Value: String);
begin
if fText <> Value then
begin
fText := Value;
InvalidateEverything;
end;
end;
procedure TALScrollingText.SetEdgeFadeWidth(const Value: Integer);
begin
if fEdgeFadeWidth <> Value then
begin
fEdgeFadeWidth := Value;
InvalidateEverything;
end;
end;
procedure TALScrollingText.SetLayout(const Value: TTextLayout);
begin
if fLayout <> Value then
begin
fLayout := Value;
InvalidateEverything;
end;
end;
procedure TALScrollingText.SetTextDirection(const Value: TTextDirection);
begin
if fTextDirection <> Value then
begin
fTextDirection := Value;
if Value = tdLeftToRight then
Position := -(WholeBitmap.Width - Width)
else
Position := 0;
InvalidateEverything;
end;
end;
function TALScrollingText.CalcColorIndex(StartColor, EndColor: TColor; Steps, ColorIndex: Integer): TColor;
var
BeginRGBValue: Array[0..2] of Byte;
RGBDifference: Array[0..2] of Integer;
Red, Green, Blue: Byte;
NumColors: Integer;
begin
if (ColorIndex < 1) or (ColorIndex > Steps) then
raise ERangeError.Create('ColorIndex can''t be less than 1 or greater than ' + IntToStr(Steps));
NumColors := Steps;
Dec(ColorIndex);
BeginRGBValue[0] := GetRValue(ColorToRGB(StartColor));
BeginRGBValue[1] := GetGValue(ColorToRGB(StartColor));
BeginRGBValue[2] := GetBValue(ColorToRGB(StartColor));
RGBDifference[0] := GetRValue(ColorToRGB(EndColor)) - BeginRGBValue[0];
RGBDifference[1] := GetGValue(ColorToRGB(EndColor)) - BeginRGBValue[1];
RGBDifference[2] := GetBValue(ColorToRGB(EndColor)) - BeginRGBValue[2];
// Calculate the bands color
Red := BeginRGBValue[0] + MulDiv(ColorIndex, RGBDifference[0], NumColors - 1);
Green := BeginRGBValue[1] + MulDiv(ColorIndex, RGBDifference[1], NumColors - 1);
Blue := BeginRGBValue[2] + MulDiv(ColorIndex, RGBDifference[2], NumColors - 1);
Result := RGB(Red, Green, Blue);
end;
procedure TALScrollingText.SetVisible(const Value: Boolean);
begin
if Value <> fVisible then
begin
fVisible := Value;
Enabled := fVisible;
TGraphicControl(Self).Visible := fVisible;
end;
end;
end.