{SuperMarquee - Komponente für Delphi 2-4
 dies ist nur eine Test - Komponente
 by Dipl.-Ing. Thomas Speiser Copyright MMIX

 KKTU Comp [SuperMarquee]
 Version 1.3 mit BackGroundbild, verschiedene Schatten, Laufzähler, Blinker}

unit SuperMarquee;

interface

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

type
   TMoveTo = (MTNone,MTLeft, MTCenter,MTRight);
   TSpeed  = (sLow, sMiddle, sHigh);
   TStyle  = (stNone, stRaised, stRecessed);

   TSuperMarquee = class(TGraphicControl)
   private
      { Private declarations }
      FActive, FAutoSize, FStretch, FBlink: Boolean;
      FMoveTo: TMoveTo;
      FSpeed: TSpeed;
      FStyle: TStyle;
      FTimer: TTimer;
      FMoveCount: Integer;
      FOutText: String;
      X, Y, I, Blink: Integer;
      FBitmap, FBackGround: TBitmap;
      R: TRect;
      procedure SetBlink(Value: Boolean);
      procedure SetBackGround(Value: TBitmap);
      procedure SetSpeed(Value: TSpeed);
      procedure SetStretch(Value: Boolean);
      procedure SetBitmap(Value: TBitmap);
      procedure SetActive(Value: Boolean);
      procedure ShowText(s: string);
// Veränderungen im Formular
      procedure WMWindowPosChanged(var Message: TWMWindowPosChanged); message WM_WINDOWPOSCHANGED;
      procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
   protected
      { Protected declarations }
      procedure AdjustBounds; dynamic;
      procedure SetAutoSize(Value: Boolean); virtual;
      procedure TimerFired(Sender: TObject);
      procedure Paint; override;

      procedure NoneClick(Sender: TObject);
      procedure RaisedClick(Sender: TObject);
      procedure RecessedClick(Sender: TObject);

      procedure LowClick(Sender: TObject);
      procedure MiddleClick(Sender: TObject);
      procedure HighClick(Sender: TObject);

      procedure MTNoneClick(Sender: TObject);
      procedure LeftClick(Sender: TObject);
      procedure CenterClick(Sender: TObject);
      procedure RightClick(Sender: TObject);
   public
      constructor Create(AOwner: TComponent); override;
      destructor Destroy; override;
   published
      { Published declarations }
      property Active: Boolean read FActive write SetActive default False;
      property Align;
      property AutoSize: Boolean read FAutoSize write SetAutoSize default True;
      property Color;
      property Caption;
      property BackGround: TBitmap read FBackGround write SetBackGround;
      property Blinking: Boolean read FBlink write SetBlink;
      property Bitmap: TBitmap read FBitmap write SetBitmap;
      property MoveCount: Integer read FMoveCount write FMoveCount default 0;
      property MoveTo: TMoveTo read FMoveTo write FMoveTo default MTLeft;
      property Font;
      property ShowHint;
      property Speed: TSpeed read FSpeed write SetSpeed default sLow;
      property Style: TStyle read FStyle write FStyle default stRecessed;
      property Stretch: Boolean read FStretch write SetStretch default False;
      property Visible;
   end;

procedure Register;

implementation

{Schalter für Center}
const Add_IT: Boolean = True;
      Del_IT: Boolean = False;

type
    Attr = record
      Color: Integer;
      Text: String[150];
    end;

var Seg: Array[1..20] of Attr;
    a,b,Count,x,y,old, Runs: integer;
    s,c: string;

procedure Register;
begin
   RegisterComponents('KKTU Comp', [TSuperMarquee]);
end;

constructor TSuperMarquee.Create(AOwner: TComponent);
begin
   inherited Create(AOwner);
   FBitmap := TBitmap.Create;
   FBackGround := TBitmap.Create;
   ShowHint := True;
   FActive := False;
   FStretch := False;
   FAutoSize := True;
   FBlink := False;
   FMoveCount:=0;
   FSpeed := sLow;
   FStyle := stRecessed;

   FMoveTo := MTLeft;
   FTimer := TTimer.Create(Self);
   with FTimer do begin
      Enabled := False;
      OnTimer := TimerFired;
      Interval := 300;
   end;
   i:= 0;
   Blink:= 1;
   Runs:=1;
   Width:= 76;
   Height:= 17;
end;

destructor TSuperMarquee.Destroy;
begin
   SetActive(False);
   FTimer.Enabled := False;
   FTimer.OnTimer := nil;
   FTimer.Free;
   FBitmap.Free;
   FBackGround.Free;
   inherited Destroy;
end;

procedure TSuperMarquee.SetSpeed(Value: TSpeed);
begin
   if FActive then
      FTimer.Enabled := False;
   if Value <> FSpeed then
   begin
      case Value of
         sLow: begin
            FTimer.Interval := 300;
          end;
         sMiddle: begin
            FTimer.Interval := 120;
          end;
         sHigh: begin
            FTimer.Interval := 60;
          end;
      end;
      FSpeed := Value;
   end;
   if FActive then
      FTimer.Enabled := True;
end;

procedure TSuperMarquee.ShowText(s: string);
var i: integer;
   // TmpR: TRect;
begin
{Eingabemaske %Farbe&String&
z.B.: "%green&Test des Textes&%blue& von SuperMarquee&"}

if s <> '' then begin
Count:=0;
Old:=0;
FOutText:='';

 a:=1; b:=pos('&',s);
 repeat
 Delete(s,a,1); inc(Count);

 c:=Copy(s,a,b-a-1);
 Seg[Count].Color:=1;
 c:=LowerCase(c);
 if c = 'red' then Seg[Count].Color:=clRed;
 if c = 'black' then Seg[Count].Color:=clBlack;
 if c = 'yellow' then Seg[Count].Color:=clYellow;
 if c = 'green' then Seg[Count].Color:=clGreen;
 if c = 'blue' then Seg[Count].Color:=clBlue;
 if c = 'aqua' then Seg[Count].Color:=clAqua;
 if c = 'fuchsia' then Seg[Count].Color:=clFuchsia;
 if c = 'gray' then Seg[Count].Color:=clGray;
 if c = 'lime' then Seg[Count].Color:=clLime;
 if c = 'ltgray' then Seg[Count].Color:=clLtGray;
 if c = 'maroon' then Seg[Count].Color:=clMaroon;
 if c = 'fuchsia' then Seg[Count].Color:=clFuchsia;
 if c = 'navy' then Seg[Count].Color:=clNavy;
 if c = 'olive' then Seg[Count].Color:=clOlive;
 if c = 'purple' then Seg[Count].Color:=clPurple;
 if c = 'silver' then Seg[Count].Color:=clSilver;
 if c = 'teal' then Seg[Count].Color:=clTeal;
 if c = 'white' then Seg[Count].Color:=clWhite;

 a:=pos('&',s); Delete(s,a,1); b:=pos('&',s);
 Seg[Count].Text:=Copy(s,a,b-a);
 Delete(s,b,1); a:=pos('%',s); b:=pos('&',s);
{FOutText wird decodet}
 FOutText:=FOutText+Seg[Count].Text;
 until pos('%',s) = 0;
 Hint:=FOutText;
 end;

if FBackGround.Empty = True then begin
{Hintergrund wird erneuert}
  Canvas.Brush.Color:=Color;
  Canvas.Brush.Style := bsSolid;
  R := GetClientRect;
  Canvas.FillRect(R); end else begin
if FStretch then Canvas.StretchDraw(R,BackGround) else
BitBlt(Canvas.Handle, R.Left, R.Top, FBackGround.Width, FBackGround.Height, FBackGround.Canvas.Handle, 0, 0, SRCCOPY); end;

{Transparente Schrift}
  Canvas.Brush.Style := bsClear;

{Wenn MTNone, dann soll x immer zentriert werden}
if FMoveTo = MTNone then X := (Width - Canvas.TextWidth(FOutText)) div 2;

if (Blink >= 5) and (FBlink) then Blink:=0 else begin

 if Count > 0 then begin
 for i:=1 to Count do begin

 case FStyle of
   stRaised: begin
      Canvas.Font.Color:=Font.Color;
      Canvas.TextOut(X+old,Y-1,Seg[i].Text); end;

   stRecessed: begin
      Canvas.Font.Color:=Font.Color;
      Canvas.TextOut(X+old+2,Y+1,Seg[i].Text); end;
 end;

{Die Arrayeinträge werden hier in Canvas Anweisungen umgewandelt}
 Canvas.Font.Color:=Seg[i].Color;
 Canvas.TextOut(X+old+1,Y,Seg[i].Text); old:=canvas.TextWidth(Seg[i].Text)+old;
 Seg[i].Color:=0; Seg[i].Text:='';
 end; end;
 end;

{Abschneiden der Enden}
{  Canvas.Brush.Color:=Color;
  TmpR:=Rect(0,0,2,Height);
  Canvas.FillRect(TmpR);
  TmpR:=Rect(Width-2,0,Width,Height);
  Canvas.FillRect(TmpR);}

inc(Blink);
end;

procedure TSuperMarquee.Paint;
begin
  R:=Rect(0,0,Width,Height);
  Canvas.Font.Assign(Font);
{Position justieren}
  Y := (Height - Canvas.TextHeight(Caption)) div 2;

if (not Active) and (FBitmap.Empty = True) then begin
  X := (Width - Canvas.TextWidth(FOutText)) div 2;
  ShowText(Caption); end;

{if FBitmap.Empty = False then begin
  X := (Width - Canvas.TextWidth('Bitmap')) div 2;
  Canvas.TextOut(X,Y,'Bitmap'); end;}
end;

procedure TSuperMarquee.TimerFired(Sender: TObject);

procedure Test_MoveCount;
begin
{MoveCount Überprüfung}
 if FMoveCount <> 0 then begin if FMoveCount <= Runs then begin FActive:=False;
 FTimer.Enabled:=False; Paint; end; inc(Runs); end;
end;

begin
 case FMoveTo of
   MTLeft: begin
{Bild links}
    if FBitmap.Empty = False then begin
        inc(i,5);
        BitBlt(Canvas.Handle,0,0, FBitmap.Width, FBitmap.Height, FBitmap.Canvas.Handle, i, 0, SRCCOPY);
       if i >= FBitmap.Width then begin i:=0-FBitmap.Width; Test_MoveCount; end; end else begin
{Text links}
           dec(x,10); ShowText(Caption);
           if x+Canvas.TextWidth(FOutText) <= 0 then begin x:=width; Test_MoveCount; end;
           end; end;

   MTCenter: begin
{Bild center}
    if FBitmap.Empty = False then begin
       if i+FBitmap.Width <= 0 then begin Del_IT:=False; Add_IT:=True end;
       if i >= FBitmap.Width then begin Add_IT:=False; Del_IT:=True; Test_MoveCount; end;
           if Add_IT then inc(i,5);
           if Del_IT then dec(i,5);
           BitBlt(Canvas.Handle,0,0, FBitmap.Width, FBitmap.Height, FBitmap.Canvas.Handle, i, 0, SRCCOPY); end else begin
{Text center}
           if Add_IT then inc(x,10);
           if Del_IT then dec(x,10);
           ShowText(Caption);
           if x <= 0 then begin Del_IT:=False; Add_IT:=True; Test_MoveCount; end;
           if x+Canvas.TextWidth(FOutText) >= width then begin Add_IT:=False; Del_IT:=True; end;
           end; end;

   MTRight: begin
{Bild rechts}
    if FBitmap.Empty = False then begin
        dec(i,5);
        BitBlt(Canvas.Handle,0,0, FBitmap.Width, FBitmap.Height, FBitmap.Canvas.Handle, i, 0, SRCCOPY);
       if i <= 0-FBitmap.Width then begin i:=FBitmap.Width; Test_MoveCount; end; end else begin
{Bild rechts}
           Inc(X,10);
           ShowText(Caption);
           if x >= width then begin x:=0-Canvas.TextWidth(FOutText); Test_MoveCount; end;
           end; end;
   MTNone: ShowText(Caption);
   end;
end;

procedure TSuperMarquee.SetActive(Value: Boolean);
begin
   Runs:=1;
   if FActive <> Value then
   begin
       FTimer.Enabled := Value;
       FActive := Value;
   end;
end;

procedure TSuperMarquee.MTNoneClick(Sender: TObject);
begin
   MoveTo := MTNone;
end;

procedure TSuperMarquee.LeftClick(Sender: TObject);
begin
   MoveTo := MTLeft;
end;

procedure TSuperMarquee.CenterClick(Sender: TObject);
begin
   MoveTo := MTCenter;
end;

procedure TSuperMarquee.RightClick(Sender: TObject);
begin
   MoveTo := MTRight;
end;

procedure TSuperMarquee.LowClick(Sender: TObject);
begin
   Speed := sLow;
end;

procedure TSuperMarquee.MiddleClick(Sender: TObject);
begin
   Speed := sMiddle;
end;

procedure TSuperMarquee.HighClick(Sender: TObject);
begin
   Speed := sHigh;
end;

procedure TSuperMarquee.NoneClick(Sender: TObject);
begin
   Style := stNone;
end;

procedure TSuperMarquee.RaisedClick(Sender: TObject);
begin
   Style := stRaised;
end;

procedure TSuperMarquee.RecessedClick(Sender: TObject);
begin
   Style := stRecessed;
end;

procedure TSuperMarquee.SetAutoSize(Value: Boolean);
begin
FAutoSize:= Value;
  if FAutoSize then begin
    if FBackGround.Empty = False then
    SetBounds(Left, Top, FBackGround.Width,FBackGround.Height) else
    SetBounds(Left, Top, Canvas.TextWidth(FOutText),Canvas.TextHeight(FOutText));
  end;
end;

procedure TSuperMarquee.WMWindowPosChanged(var Message: TWMWindowPosChanged);
begin
 R:=Rect(0,0,Width,Height);
end;

procedure TSuperMarquee.SetBitmap(Value: TBitmap);
begin
  FBitmap.Assign(Value);
  Paint;
end;

procedure TSuperMarquee.AdjustBounds;
begin
 SetBounds(Left,Top,Width,Height);
end;

procedure TSuperMarquee.CMTextChanged(var Message: TMessage);
begin
  ShowText(Caption);
end;

procedure TSuperMarquee.SetBackGround(Value: TBitmap);
begin
  FBackGround.Assign(Value);
  Paint;
end;

procedure TSuperMarquee.SetStretch(Value: Boolean);
begin
  FStretch:=Value;
  Paint;
end;

procedure TSuperMarquee.SetBlink(Value: Boolean);
begin
  FBlink:=Value;
end;

end.