Mega Code Archive
Textanimator [component]
<![CDATA[
unit TextAnim;
interface
uses
{$IFDEF WIN32} Windows {$ELSE} WinTypes, WinProcs {$ENDIF}, Messages,
SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Menus, ExtCtrls;
type
PIntArray = ^TIntArray;
TIntArray = array[0..16383] of Integer;
PShortIntArray = ^TShortIntArray;
TShortIntArray = array[0..16383] of ShortInt;
TTextAnimStyle = (taAll, taRandom, taWave, taWind);
{ TTextAnimator }
TTextAnimator = class(TGraphicControl)
private
fDelay: Word;
fActive: Boolean;
fAutoSize: Boolean;
fAlignment: TAlignment;
fMaxFontStep: Word;
fStep: Word;
fColorAnimation: Boolean;
fColorStart: TColor;
fColorStop: TColor;
fStyle: TTextAnimStyle;
fTransparent: Boolean;
CharWidth: PIntArray;
CharStep: PIntArray;
CharDir: PShortIntArray;
MaxTextSize: TSize;
TextLen: Integer;
Timer: TTimer;
IsFontChanged: Boolean;
ColorDir: Integer;
ThisColor: Byte;
MaxDeltaRGB: Integer;
OffScreen: TBitmap;
Drawing: Boolean;
StartRGB: array[1..3] of Byte;
DeltaRGB: array[1..3] of Integer;
procedure SetDelay(Value: Word);
procedure SetStep(Value: Word);
procedure SetStyle(Value: TTextAnimStyle);
procedure SetActive(Value: Boolean);
procedure SetAutoSize_(Value: Boolean);
procedure SetMaxStep(Value: Word);
procedure SetAlignment(Value: TAlignment);
procedure SetTransparent(Value: Boolean);
procedure SetColorStart(Value: TColor);
procedure SetColorStop(Value: TColor);
function IsFontStored: Boolean;
function IsSizeStored: Boolean;
procedure TimerExpired(Sender: TObject);
procedure CMTextChanged(var Msg: TMessage); message CM_TEXTCHANGED;
procedure CMFontChanged(var Msg: TMessage); message CM_FONTCHANGED;
procedure ResetAnimation(ResetAll: Boolean);
procedure ResetColors;
function MakeFontColor: TColor;
procedure PaintFrame(ACanvas: TCanvas);
protected
procedure Paint; override;
procedure Loaded; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure AdjustClientSize;
procedure NextFrame;
published
property Active: Boolean read fActive write SetActive default True;
property Align;
property Alignment: TAlignment read fAlignment write SetAlignment default taCenter;
property AutoSize: Boolean read fAutoSize write SetAutoSize_ default True;
property Caption;
property ColorAnimation: Boolean read fColorAnimation write fColorAnimation default True;
property ColorStart: TColor read fColorStart write SetColorStart default clYellow;
property ColorStop: TColor read fColorStop write SetColorStop default clRed;
property Color;
property Delay: Word read fDelay write SetDelay default 70;
property DragCursor;
property DragMode;
property Enabled;
property Font stored IsFontStored;
property Height stored IsSizeStored;
property MaxStep: Word read fMaxFontStep write SetMaxStep default 20;
property ParentColor;
property ParentShowHint;
property PopupMenu;
property ShowHint;
property Step: Word read fStep write SetStep default 2;
property Style: TTextAnimStyle read fStyle write SetStyle default taWind;
property Transparent: Boolean read fTransparent write SetTransparent default True;
property Visible;
property Width stored IsSizeStored;
property OnClick;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDrag;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
end;
procedure Register;
implementation
type
TParentControl = class(TWinControl);
{ This procedure is copied from RxLibrary VCLUtils }
procedure CopyParentImage(Control: TControl; Dest: TCanvas);
var
I, Count, X, Y, SaveIndex: Integer;
DC: HDC;
R, SelfR, CtlR: TRect;
begin
if (Control = nil) or (Control.Parent = nil) then Exit;
Count := Control.Parent.ControlCount;
DC := Dest.Handle;
{$IFDEF WIN32}
with Control.Parent do ControlState := ControlState + [csPaintCopy];
try
{$ENDIF}
with Control do begin
SelfR := Bounds(Left, Top, Width, Height);
X := -Left; Y := -Top;
end;
{ Copy parent control image }
SaveIndex := SaveDC(DC);
try
SetViewportOrgEx(DC, X, Y, nil);
IntersectClipRect(DC, 0, 0, Control.Parent.ClientWidth,
Control.Parent.ClientHeight);
with TParentControl(Control.Parent) do begin
Perform(WM_ERASEBKGND, DC, 0);
PaintWindow(DC);
end;
finally
RestoreDC(DC, SaveIndex);
end;
{ Copy images of graphic controls }
for I := 0 to Count - 1 do begin
if Control.Parent.Controls[I] = Control then Break
else if (Control.Parent.Controls[I] <> nil) and
(Control.Parent.Controls[I] is TGraphicControl) then
begin
with TGraphicControl(Control.Parent.Controls[I]) do begin
CtlR := Bounds(Left, Top, Width, Height);
if Bool(IntersectRect(R, SelfR, CtlR)) and Visible then begin
{$IFDEF WIN32}
ControlState := ControlState + [csPaintCopy];
{$ENDIF}
SaveIndex := SaveDC(DC);
try
SetViewportOrgEx(DC, Left + X, Top + Y, nil);
IntersectClipRect(DC, 0, 0, Width, Height);
Perform(WM_PAINT, DC, 0);
finally
RestoreDC(DC, SaveIndex);
{$IFDEF WIN32}
ControlState := ControlState - [csPaintCopy];
{$ENDIF}
end;
end;
end;
end;
end;
{$IFDEF WIN32}
finally
with Control.Parent do ControlState := ControlState - [csPaintCopy];
end;
{$ENDIF}
end;
{ TTextAnimator }
constructor TTextAnimator.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := ControlStyle + [csOpaque {$IFDEF WIN32}, csReplicatable {$ENDIF}];
Randomize;
OffScreen := TBitmap.Create;
fActive := False;
fAutoSize := True;
fAlignment := taCenter;
fTransparent := True;
fColorAnimation := True;
fColorStart := clYellow;
fColorStop := clRed;
fStyle := taWind;
fStep := 2;
fDelay := 70;
fMaxFontStep := 20;
Font.Name := 'Times New Roman';
Font.Size := 10;
Font.Style := [fsBold];
IsFontChanged := False;
TextLen := 0;
CharWidth := nil;
CharStep := nil;
CharDir := nil;
Drawing := False;
ResetAnimation(True);
ResetColors;
Active := True;
end;
destructor TTextAnimator.Destroy;
begin
Active := False;
OffScreen.Free;
if CharWidth <> nil then FreeMem(CharWidth, TextLen * SizeOf(Integer));
if CharStep <> nil then FreeMem(CharStep, TextLen * SizeOf(Integer));
if CharDir <> nil then FreeMem(CharDir, TextLen * SizeOf(ShortInt));
inherited Destroy;
end;
procedure TTextAnimator.Loaded;
begin
inherited Loaded;
if fAutoSize then AdjustClientSize;
end;
procedure TTextAnimator.Paint;
begin
if not Drawing then
begin
Drawing := True;
try
OffScreen.Width := ClientWidth;
OffScreen.Height := ClientHeight;
PaintFrame(OffScreen.Canvas);
Canvas.Draw(0, 0, OffScreen);
finally
Drawing := False;
end;
end;
end;
procedure TTextAnimator.CMTextChanged(var Msg: TMessage);
begin
inherited;
ResetAnimation(True);
if fAutoSize then AdjustClientSize;
end;
procedure TTextAnimator.CMFontChanged(var Msg: TMessage);
begin
inherited;
ResetAnimation(False);
IsFontChanged := True;
if fAutoSize then AdjustClientSize;
end;
procedure TTextAnimator.AdjustClientSize;
begin
if not (csReading in ComponentState) then
SetBounds(Left, Top, MaxTextSize.CX , MaxTextSize.CY);
end;
procedure TTextAnimator.SetDelay(Value: Word);
begin
if fDelay <> Value then
begin
fDelay := Value;
if Assigned(Timer) then Timer.Interval := fDelay;
end;
end;
procedure TTextAnimator.SetMaxStep(Value: Word);
begin
if fMaxFontStep <> Value then
begin
fMaxFontStep := Value;
ResetAnimation(False);
if fAutoSize then AdjustClientSize;
if fStep > fMaxFontStep then
fStep := fMaxFontStep;
end;
end;
procedure TTextAnimator.SetStep(Value: Word);
begin
if Value > fMaxFontStep then
Value := fMaxFontStep;
if fStep <> Value then
fStep := Value;
end;
procedure TTextAnimator.SetStyle(Value: TTextAnimStyle);
begin
if fStyle <> Value then
begin
fStyle := Value;
ResetAnimation(False);
end;
end;
procedure TTextAnimator.SetActive(Value: Boolean);
begin
if fActive <> Value then
begin
fActive := Value;
if fActive then
begin
Timer := TTimer.Create(Self);
Timer.Interval := fDelay;
Timer.OnTimer := TimerExpired;
end
else
begin
Timer.Free;
Timer := nil;
end;
end;
end;
procedure TTextAnimator.SetAutoSize_(Value: Boolean);
begin
if fAutoSize <> Value then
begin
fAutoSize := Value;
if fAutoSize then AdjustClientSize;
end;
end;
procedure TTextAnimator.SetAlignment(Value: TAlignment);
begin
if fAlignment <> Value then
begin
fAlignment := Value;
Invalidate;
end;
end;
procedure TTextAnimator.SetTransparent(Value: Boolean);
begin
if fTransparent <> Value then
begin
fTransparent := Value;
Invalidate;
end;
end;
procedure TTextAnimator.SetColorStart(Value: TColor);
begin
if fColorStart <> Value then
begin
fColorStart := Value;
ResetColors;
end;
end;
procedure TTextAnimator.SetColorStop(Value: TColor);
begin
if fColorStop <> Value then
begin
fColorStop := Value;
ResetColors;
end;
end;
function TTextAnimator.IsFontStored: Boolean;
begin
Result := IsFontChanged;
end;
function TTextAnimator.IsSizeStored: Boolean;
begin
Result := not fAutoSize;
end;
procedure TTextAnimator.ResetAnimation(ResetAll: Boolean);
var
I: Integer;
begin
if ResetAll then
begin
if CharWidth <> nil then FreeMem(CharWidth, TextLen * SizeOf(Integer));
if CharStep <> nil then FreeMem(CharStep, TextLen * SizeOf(Integer));
if CharDir <> nil then FreeMem(CharDir, TextLen * SizeOf(ShortInt));
TextLen := Length(Caption);
GetMem(CharWidth, TextLen * SizeOf(Integer));
GetMem(CharStep, TextLen * SizeOf(Integer));
GetMem(CharDir, TextLen * SizeOf(ShortInt));
end;
for I := 0 to TextLen-1 do
begin
CharDir^[I] := 1;
case fStyle of
taAll: CharStep^[I] := 0;
taRandom: CharStep^[I] := Random(fMaxFontStep+1);
taWave: CharStep^[I] := Trunc(Sin(I / TextLen * PI) * fMaxFontStep);
taWind: CharStep^[I] := I * fMaxFontStep div TextLen;
end;
end;
OffScreen.Canvas.Font := Font;
OffScreen.Canvas.Font.Size := Font.Size + fMaxFontStep - 1;
MaxTextSize.CX := 0;
for I := 0 to TextLen-1 do
begin
CharWidth^[I] := OffScreen.Canvas.TextWidth(Caption[I+1]);
Inc(MaxTextSize.CX, CharWidth^[I]);
end;
MaxTextSize.CY := OffScreen.Canvas.TextHeight('X');
end;
procedure TTextAnimator.ResetColors;
var
I: Integer;
StartColor, StopColor: LongInt;
begin
StartColor := ColorToRGB(fColorStart);
StopColor := ColorToRGB(fColorStop);
StartRGB[1] := LoByte(LoWord(StartColor));
StartRGB[2] := HiByte(LoWord(StartColor));
StartRGB[3] := LoByte(HiWord(StartColor));
DeltaRGB[1] := LoByte(LoWord(StopColor)) - StartRGB[1];
DeltaRGB[2] := HiByte(LoWord(StopColor)) - StartRGB[2];
DeltaRGB[3] := LoByte(HiWord(StopColor)) - StartRGB[3];
MaxDeltaRGB := 0;
for I := 1 to 3 do
if MaxDeltaRGB < Abs(DeltaRGB[I]) then
MaxDeltaRGB := Abs(DeltaRGB[I]);
ThisColor := 0;
ColorDir := 1;
end;
function TTextAnimator.MakeFontColor: TColor;
var
I: Integer;
ColorRGB: array[1..3] of Byte;
begin
for I := 1 to 3 do
begin
ColorRGB[I] := StartRGB[I];
if ThisColor > Abs(DeltaRGB[I]) then
Inc(ColorRGB[I], DeltaRGB[I])
else if DeltaRGB[I] > 0 then
Inc(ColorRGB[I], ThisColor mod (DeltaRGB[I]+1))
else if DeltaRGB[I] < 0 then
Dec(ColorRGB[I], ThisColor mod (DeltaRGB[I]-1));
end;
Result := TColor(RGB(ColorRGB[1], ColorRGB[2], ColorRGB[3]));
Inc(ThisColor, ColorDir);
if (ThisColor = MaxDeltaRGB) or (ThisColor = 0) then ColorDir := -ColorDir;
end;
procedure TTextAnimator.NextFrame;
var
I: Integer;
begin
for I := 0 to TextLen-1 do
begin
Inc(CharStep^[I], fStep * CharDir^[I]);
if CharStep^[I] > fMaxFontStep then
begin
CharStep^[I] := 2 * fMaxFontStep - CharStep^[I];
CharDir^[I] := -1;
end;
if CharStep^[I] <= 0 then
begin
CharStep^[I] := -CharStep^[I];
CharDir^[I] := 1;
end;
end;
Refresh;
end;
procedure TTextAnimator.PaintFrame(ACanvas: TCanvas);
var
I, X, Y: Integer;
begin
case fAlignment of
taLeftJustify: X := 0;
taRightJustify: X := ClientWidth - MaxTextSize.CX;
else
X := (ClientWidth - MaxTextSize.CX) div 2;
end;
Y := (ClientHeight - MaxTextSize.CY) div 2;
ACanvas.Font := Font;
ACanvas.Brush.Color := Color;
if fTransparent then
begin
CopyParentImage(Self, ACanvas);
ACanvas.Brush.Style := bsCLear;
end
else
begin
ACanvas.FillRect(ClientRect);
ACanvas.Brush.Style := bsSolid;
end;
for I := 0 to TextLen-1 do
begin
if fColorAnimation then ACanvas.Font.Color := MakeFontColor;
ACanvas.Font.Size := Font.Size + CharStep^[I];
ACanvas.TextOut(X, Y, Caption[I+1]);
Inc(X, CharWidth^[I])
end;
end;
procedure TTextAnimator.TimerExpired(Sender: TObject);
begin
NextFrame;
end;
procedure Register;
begin
RegisterComponents('Plus', [TTextAnimator]);
end;
end.
]]>