home *** CD-ROM | disk | FTP | other *** search
/ Chip 2002 March / Chip_2002-03_cd1.bin / zkuste / delphi / kompon / d13456 / TEXTANIM.ZIP / TextAnim.pas < prev   
Pascal/Delphi Source File  |  2001-12-29  |  15KB  |  536 lines
  1. {------------------------------------------------------------------------------}
  2. {                                                                              }
  3. {  TTextAnimator v1.4 - based on NervousText applet from Sun Microsystems.     }
  4. {  by Kambiz R. Khojasteh                                                      }
  5. {                                                                              }
  6. {  kambiz@delphiarea.com                                                       }
  7. {  http://www.delphiarea.com                                                   }
  8. {                                                                              }
  9. {------------------------------------------------------------------------------}
  10.  
  11. unit TextAnim;
  12.  
  13. interface
  14.  
  15. uses
  16.   {$IFDEF WIN32} Windows {$ELSE} WinTypes, WinProcs {$ENDIF}, Messages,
  17.   SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Menus, ExtCtrls;
  18.  
  19. type
  20.  
  21.   PIntArray = ^TIntArray;
  22.   TIntArray = array[0..16383] of Integer;
  23.   PShortIntArray = ^TShortIntArray;
  24.   TShortIntArray = array[0..16383] of ShortInt;
  25.  
  26.   TTextAnimStyle = (taAll, taRandom, taWave, taWind);
  27.  
  28. { TTextAnimator }
  29.  
  30.   TTextAnimator = class(TGraphicControl)
  31.   private
  32.     fDelay: Word;
  33.     fActive: Boolean;
  34.     fAutoSize: Boolean;
  35.     fAlignment: TAlignment;
  36.     fMaxFontStep: Word;
  37.     fStep: Word;
  38.     fColorAnimation: Boolean;
  39.     fColorStart: TColor;
  40.     fColorStop: TColor;
  41.     fStyle: TTextAnimStyle;
  42.     fTransparent: Boolean;
  43.     CharWidth: PIntArray;
  44.     CharStep: PIntArray;
  45.     CharDir: PShortIntArray;
  46.     MaxTextSize: TSize;
  47.     TextLen: Integer;
  48.     Timer: TTimer;
  49.     IsFontChanged: Boolean;
  50.     ColorDir: Integer;
  51.     ThisColor: Byte;
  52.     MaxDeltaRGB: Integer;
  53.     OffScreen: TBitmap;
  54.     Drawing: Boolean;
  55.     StartRGB: array[1..3] of Byte;
  56.     DeltaRGB: array[1..3] of Integer;
  57.     procedure SetDelay(Value: Word);
  58.     procedure SetStep(Value: Word);
  59.     procedure SetStyle(Value: TTextAnimStyle);
  60.     procedure SetActive(Value: Boolean);
  61.     procedure SetAutoSize_(Value: Boolean);
  62.     procedure SetMaxStep(Value: Word);
  63.     procedure SetAlignment(Value: TAlignment);
  64.     procedure SetTransparent(Value: Boolean);
  65.     procedure SetColorStart(Value: TColor);
  66.     procedure SetColorStop(Value: TColor);
  67.     function IsFontStored: Boolean;
  68.     function IsSizeStored: Boolean;
  69.     procedure TimerExpired(Sender: TObject);
  70.     procedure CMTextChanged(var Msg: TMessage); message CM_TEXTCHANGED;
  71.     procedure CMFontChanged(var Msg: TMessage); message CM_FONTCHANGED;
  72.     procedure ResetAnimation(ResetAll: Boolean);
  73.     procedure ResetColors;
  74.     function MakeFontColor: TColor;
  75.     procedure PaintFrame(ACanvas: TCanvas);
  76.   protected
  77.     procedure Paint; override;
  78.     procedure Loaded; override;
  79.   public
  80.     constructor Create(AOwner: TComponent); override;
  81.     destructor Destroy; override;
  82.     procedure AdjustClientSize;
  83.     procedure NextFrame;
  84.   published
  85.     property Active: Boolean read fActive write SetActive default True;
  86.     property Align;
  87.     property Alignment: TAlignment read fAlignment write SetAlignment default taCenter;
  88.     property AutoSize: Boolean read fAutoSize write SetAutoSize_ default True;
  89.     property Caption;
  90.     property ColorAnimation: Boolean read fColorAnimation write fColorAnimation default True;
  91.     property ColorStart: TColor read fColorStart write SetColorStart default clYellow;
  92.     property ColorStop: TColor read fColorStop write SetColorStop default clRed;
  93.     property Color;
  94.     property Delay: Word read fDelay write SetDelay default 70;
  95.     property DragCursor;
  96.     property DragMode;
  97.     property Enabled;
  98.     property Font stored IsFontStored;
  99.     property Height stored IsSizeStored;
  100.     property MaxStep: Word read fMaxFontStep write SetMaxStep default 20;
  101.     property ParentColor;
  102.     property ParentShowHint;
  103.     property PopupMenu;
  104.     property ShowHint;
  105.     property Step: Word read fStep write SetStep default 2;
  106.     property Style: TTextAnimStyle read fStyle write SetStyle default taWind;
  107.     property Transparent: Boolean read fTransparent write SetTransparent default True;
  108.     property Visible;
  109.     property Width stored IsSizeStored;
  110.     property OnClick;
  111.     property OnDblClick;
  112.     property OnDragDrop;
  113.     property OnDragOver;
  114.     property OnEndDrag;
  115.     property OnMouseDown;
  116.     property OnMouseMove;
  117.     property OnMouseUp;
  118.   end;
  119.  
  120. procedure Register;
  121.  
  122. implementation
  123.  
  124. {$IFDEF WIN32}
  125.   {$R *.d32}
  126. {$ELSE}
  127.   {$R *.d16}
  128. {$ENDIF}
  129.  
  130. type
  131.   TParentControl = class(TWinControl);
  132.   
  133. { This procedure is copied from RxLibrary VCLUtils }
  134. procedure CopyParentImage(Control: TControl; Dest: TCanvas);
  135. var
  136.   I, Count, X, Y, SaveIndex: Integer;
  137.   DC: HDC;
  138.   R, SelfR, CtlR: TRect;
  139. begin
  140.   if (Control = nil) or (Control.Parent = nil) then Exit;
  141.   Count := Control.Parent.ControlCount;
  142.   DC := Dest.Handle;
  143. {$IFDEF WIN32}
  144.   with Control.Parent do ControlState := ControlState + [csPaintCopy];
  145.   try
  146. {$ENDIF}
  147.     with Control do begin
  148.       SelfR := Bounds(Left, Top, Width, Height);
  149.       X := -Left; Y := -Top;
  150.     end;
  151.     { Copy parent control image }
  152.     SaveIndex := SaveDC(DC);
  153.     try
  154.       SetViewportOrgEx(DC, X, Y, nil);
  155.       IntersectClipRect(DC, 0, 0, Control.Parent.ClientWidth,
  156.         Control.Parent.ClientHeight);
  157.       with TParentControl(Control.Parent) do begin
  158.         Perform(WM_ERASEBKGND, DC, 0);
  159.         PaintWindow(DC);
  160.       end;
  161.     finally
  162.       RestoreDC(DC, SaveIndex);
  163.     end;
  164.     { Copy images of graphic controls }
  165.     for I := 0 to Count - 1 do begin
  166.       if Control.Parent.Controls[I] = Control then Break
  167.       else if (Control.Parent.Controls[I] <> nil) and
  168.         (Control.Parent.Controls[I] is TGraphicControl) then
  169.       begin
  170.         with TGraphicControl(Control.Parent.Controls[I]) do begin
  171.           CtlR := Bounds(Left, Top, Width, Height);
  172.           if Bool(IntersectRect(R, SelfR, CtlR)) and Visible then begin
  173. {$IFDEF WIN32}
  174.             ControlState := ControlState + [csPaintCopy];
  175. {$ENDIF}
  176.             SaveIndex := SaveDC(DC);
  177.             try
  178.               SetViewportOrgEx(DC, Left + X, Top + Y, nil);
  179.               IntersectClipRect(DC, 0, 0, Width, Height);
  180.               Perform(WM_PAINT, DC, 0);
  181.             finally
  182.               RestoreDC(DC, SaveIndex);
  183. {$IFDEF WIN32}
  184.               ControlState := ControlState - [csPaintCopy];
  185. {$ENDIF}
  186.             end;
  187.           end;
  188.         end;
  189.       end;
  190.     end;
  191. {$IFDEF WIN32}
  192.   finally
  193.     with Control.Parent do ControlState := ControlState - [csPaintCopy];
  194.   end;
  195. {$ENDIF}
  196. end;
  197.  
  198. { TTextAnimator }
  199.  
  200. constructor TTextAnimator.Create(AOwner: TComponent);
  201. begin
  202.   inherited Create(AOwner);
  203.   ControlStyle := ControlStyle + [csOpaque {$IFDEF WIN32}, csReplicatable {$ENDIF}];
  204.   Randomize;
  205.   OffScreen := TBitmap.Create;
  206.   fActive := False;
  207.   fAutoSize := True;
  208.   fAlignment := taCenter;
  209.   fTransparent := True;
  210.   fColorAnimation := True;
  211.   fColorStart := clYellow;
  212.   fColorStop := clRed;
  213.   fStyle := taWind;
  214.   fStep := 2;
  215.   fDelay := 70;
  216.   fMaxFontStep := 20;
  217.   Font.Name := 'Times New Roman';
  218.   Font.Size := 10;
  219.   Font.Style := [fsBold];
  220.   IsFontChanged := False;
  221.   TextLen := 0;
  222.   CharWidth := nil;
  223.   CharStep := nil;
  224.   CharDir := nil;
  225.   Drawing := False;
  226.   ResetAnimation(True);
  227.   ResetColors;
  228.   Active := True;
  229. end;
  230.  
  231. destructor TTextAnimator.Destroy;
  232. begin
  233.   Active := False;
  234.   OffScreen.Free;
  235.   if CharWidth <> nil then FreeMem(CharWidth, TextLen * SizeOf(Integer));
  236.   if CharStep <> nil then FreeMem(CharStep, TextLen * SizeOf(Integer));
  237.   if CharDir <> nil then FreeMem(CharDir, TextLen * SizeOf(ShortInt));
  238.   inherited Destroy;
  239. end;
  240.  
  241. procedure TTextAnimator.Loaded;
  242. begin
  243.   inherited Loaded;
  244.   if fAutoSize then AdjustClientSize;
  245. end;
  246.  
  247. procedure TTextAnimator.Paint;
  248. begin
  249.   if not Drawing then
  250.   begin
  251.     Drawing := True;
  252.     try
  253.       OffScreen.Width := ClientWidth;
  254.       OffScreen.Height := ClientHeight;
  255.       PaintFrame(OffScreen.Canvas);
  256.       Canvas.Draw(0, 0, OffScreen);
  257.     finally
  258.       Drawing := False;
  259.     end;
  260.   end;
  261. end;
  262.  
  263. procedure TTextAnimator.CMTextChanged(var Msg: TMessage);
  264. begin
  265.   inherited;
  266.   ResetAnimation(True);
  267.   if fAutoSize then AdjustClientSize;
  268. end;
  269.  
  270. procedure TTextAnimator.CMFontChanged(var Msg: TMessage);
  271. begin
  272.   inherited;
  273.   ResetAnimation(False);
  274.   IsFontChanged := True;
  275.   if fAutoSize then AdjustClientSize;
  276. end;
  277.  
  278. procedure TTextAnimator.AdjustClientSize;
  279. begin
  280.   if not (csReading in ComponentState) then
  281.     SetBounds(Left, Top, MaxTextSize.CX , MaxTextSize.CY);
  282. end;
  283.  
  284. procedure TTextAnimator.SetDelay(Value: Word);
  285. begin
  286.   if fDelay <> Value then
  287.   begin
  288.     fDelay := Value;
  289.     if Assigned(Timer) then Timer.Interval := fDelay;
  290.   end;
  291. end;
  292.  
  293. procedure TTextAnimator.SetMaxStep(Value: Word);
  294. begin
  295.   if fMaxFontStep <> Value then
  296.   begin
  297.     fMaxFontStep := Value;
  298.     ResetAnimation(False);
  299.     if fAutoSize then AdjustClientSize;
  300.     if fStep > fMaxFontStep then
  301.       fStep := fMaxFontStep;
  302.   end;
  303. end;
  304.  
  305. procedure TTextAnimator.SetStep(Value: Word);
  306. begin
  307.   if Value > fMaxFontStep then
  308.     Value := fMaxFontStep;
  309.   if fStep <> Value then
  310.     fStep := Value;
  311. end;
  312.  
  313. procedure TTextAnimator.SetStyle(Value: TTextAnimStyle);
  314. begin
  315.   if fStyle <> Value then
  316.   begin
  317.     fStyle := Value;
  318.     ResetAnimation(False);
  319.   end;
  320. end;
  321.  
  322. procedure TTextAnimator.SetActive(Value: Boolean);
  323. begin
  324.   if fActive <> Value then
  325.   begin
  326.     fActive := Value;
  327.     if fActive then
  328.     begin
  329.       Timer := TTimer.Create(Self);
  330.       Timer.Interval := fDelay;
  331.       Timer.OnTimer := TimerExpired;
  332.     end
  333.     else
  334.     begin
  335.       Timer.Free;
  336.       Timer := nil;
  337.     end;
  338.   end;
  339. end;
  340.  
  341. procedure TTextAnimator.SetAutoSize_(Value: Boolean);
  342. begin
  343.   if fAutoSize <> Value then
  344.   begin
  345.     fAutoSize := Value;
  346.     if fAutoSize then AdjustClientSize;
  347.   end;
  348. end;
  349.  
  350. procedure TTextAnimator.SetAlignment(Value: TAlignment);
  351. begin
  352.   if fAlignment <> Value then
  353.   begin
  354.     fAlignment := Value;
  355.     Invalidate;
  356.   end;
  357. end;
  358.  
  359. procedure TTextAnimator.SetTransparent(Value: Boolean);
  360. begin
  361.   if fTransparent <> Value then
  362.   begin
  363.     fTransparent := Value;
  364.     Invalidate;
  365.   end;
  366. end;
  367.  
  368. procedure TTextAnimator.SetColorStart(Value: TColor);
  369. begin
  370.   if fColorStart <> Value then
  371.   begin
  372.     fColorStart := Value;
  373.     ResetColors;
  374.   end;
  375. end;
  376.  
  377. procedure TTextAnimator.SetColorStop(Value: TColor);
  378. begin
  379.   if fColorStop <> Value then
  380.   begin
  381.     fColorStop := Value;
  382.     ResetColors;
  383.   end;
  384. end;
  385.  
  386. function TTextAnimator.IsFontStored: Boolean;
  387. begin
  388.   Result := IsFontChanged;
  389. end;
  390.  
  391. function TTextAnimator.IsSizeStored: Boolean;
  392. begin
  393.   Result := not fAutoSize;
  394. end;
  395.  
  396. procedure TTextAnimator.ResetAnimation(ResetAll: Boolean);
  397. var
  398.   I: Integer;
  399. begin
  400.   if ResetAll then
  401.   begin
  402.     if CharWidth <> nil then FreeMem(CharWidth, TextLen * SizeOf(Integer));
  403.     if CharStep <> nil then FreeMem(CharStep, TextLen * SizeOf(Integer));
  404.     if CharDir <> nil then FreeMem(CharDir, TextLen * SizeOf(ShortInt));
  405.     TextLen := Length(Caption);
  406.     GetMem(CharWidth, TextLen * SizeOf(Integer));
  407.     GetMem(CharStep, TextLen * SizeOf(Integer));
  408.     GetMem(CharDir, TextLen * SizeOf(ShortInt));
  409.   end;
  410.   for I := 0 to TextLen-1 do
  411.   begin
  412.     CharDir^[I] := 1;
  413.     case fStyle of
  414.       taAll: CharStep^[I] := 0;
  415.       taRandom: CharStep^[I] := Random(fMaxFontStep+1);
  416.       taWave: CharStep^[I] := Trunc(Sin(I / TextLen * PI) * fMaxFontStep);
  417.       taWind: CharStep^[I] := I * fMaxFontStep div TextLen;
  418.     end;
  419.   end;
  420.   OffScreen.Canvas.Font := Font;
  421.   OffScreen.Canvas.Font.Size := Font.Size + fMaxFontStep - 1;
  422.   MaxTextSize.CX := 0;
  423.   for I := 0 to TextLen-1 do
  424.   begin
  425.     CharWidth^[I] := OffScreen.Canvas.TextWidth(Caption[I+1]);
  426.     Inc(MaxTextSize.CX, CharWidth^[I]);
  427.   end;
  428.   MaxTextSize.CY := OffScreen.Canvas.TextHeight('X');
  429. end;
  430.  
  431. procedure TTextAnimator.ResetColors;
  432. var
  433.   I: Integer;
  434.   StartColor, StopColor: LongInt;
  435. begin
  436.   StartColor := ColorToRGB(fColorStart);
  437.   StopColor := ColorToRGB(fColorStop);
  438.   StartRGB[1] := LoByte(LoWord(StartColor));
  439.   StartRGB[2] := HiByte(LoWord(StartColor));
  440.   StartRGB[3] := LoByte(HiWord(StartColor));
  441.   DeltaRGB[1] := LoByte(LoWord(StopColor)) - StartRGB[1];
  442.   DeltaRGB[2] := HiByte(LoWord(StopColor)) - StartRGB[2];
  443.   DeltaRGB[3] := LoByte(HiWord(StopColor)) - StartRGB[3];
  444.   MaxDeltaRGB := 0;
  445.   for I := 1 to 3 do
  446.     if MaxDeltaRGB < Abs(DeltaRGB[I]) then
  447.       MaxDeltaRGB := Abs(DeltaRGB[I]);
  448.   ThisColor := 0;
  449.   ColorDir := 1;
  450. end;
  451.  
  452. function TTextAnimator.MakeFontColor: TColor;
  453. var
  454.   I: Integer;
  455.   ColorRGB: array[1..3] of Byte;
  456. begin
  457.   for I := 1 to 3 do
  458.   begin
  459.     ColorRGB[I] := StartRGB[I];
  460.     if ThisColor > Abs(DeltaRGB[I]) then
  461.       Inc(ColorRGB[I], DeltaRGB[I])
  462.     else if DeltaRGB[I] > 0 then
  463.       Inc(ColorRGB[I], ThisColor mod (DeltaRGB[I]+1))
  464.     else if DeltaRGB[I] < 0 then
  465.       Dec(ColorRGB[I], ThisColor mod (DeltaRGB[I]-1));
  466.   end;
  467.   Result := TColor(RGB(ColorRGB[1], ColorRGB[2], ColorRGB[3]));
  468.   Inc(ThisColor, ColorDir);
  469.   if (ThisColor = MaxDeltaRGB) or (ThisColor = 0) then ColorDir := -ColorDir;
  470. end;
  471.  
  472. procedure TTextAnimator.NextFrame;
  473. var
  474.   I: Integer;
  475. begin
  476.   for I := 0 to TextLen-1 do
  477.   begin
  478.     Inc(CharStep^[I], fStep * CharDir^[I]);
  479.     if CharStep^[I] > fMaxFontStep then
  480.     begin
  481.       CharStep^[I] := 2 * fMaxFontStep - CharStep^[I];
  482.       CharDir^[I] := -1;
  483.     end;
  484.     if CharStep^[I] <= 0 then
  485.     begin
  486.       CharStep^[I] := -CharStep^[I];
  487.       CharDir^[I] := 1;
  488.     end;
  489.   end;
  490.   Refresh;
  491. end;
  492.  
  493. procedure TTextAnimator.PaintFrame(ACanvas: TCanvas);
  494. var
  495.   I, X, Y: Integer;
  496. begin
  497.   case fAlignment of
  498.     taLeftJustify: X := 0;
  499.     taRightJustify: X := ClientWidth - MaxTextSize.CX;
  500.   else
  501.     X := (ClientWidth - MaxTextSize.CX) div 2;
  502.   end;
  503.   Y := (ClientHeight - MaxTextSize.CY) div 2;
  504.   ACanvas.Font := Font;
  505.   ACanvas.Brush.Color := Color;
  506.   if fTransparent then
  507.   begin
  508.     CopyParentImage(Self, ACanvas);
  509.     ACanvas.Brush.Style := bsCLear;
  510.   end
  511.   else
  512.   begin
  513.     ACanvas.FillRect(ClientRect);
  514.     ACanvas.Brush.Style := bsSolid;
  515.   end;
  516.   for I := 0 to TextLen-1 do
  517.   begin
  518.     if fColorAnimation then ACanvas.Font.Color := MakeFontColor;
  519.     ACanvas.Font.Size := Font.Size + CharStep^[I];
  520.     ACanvas.TextOut(X, Y, Caption[I+1]);
  521.     Inc(X, CharWidth^[I])
  522.   end;
  523. end;
  524.  
  525. procedure TTextAnimator.TimerExpired(Sender: TObject);
  526. begin
  527.   NextFrame;
  528. end;
  529.  
  530. procedure Register;
  531. begin
  532.   RegisterComponents('Delphi Area', [TTextAnimator]);
  533. end;
  534.  
  535. end.
  536.