// Komponente für eine sogenannte Punktschrift. Das Ganze wird erreicht
// durch Überblenden der Systemschrift "Fixedsys" mit einem Gitter bei
// bestimmten Schriftgrößen.
// Siehe auch
eine simple Punktschrift erstellen


// Getestet mit D4 unter XP

//
1. Einfache Variante

// Punktschrift in drei Größen mit zwei
// Zusatz-Effekten
(Blinken, Laufschrift).

unit Punkt; 
 
interface 
 
uses 
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Extctrls, 
  StdCtrls; 
 
type 
  TBg = (efNormal, efBig, efBigger); 
  TEffect = (efNone, efRoll, efBlink); 
  TWhat = (efText, efEffect, efNumber, efSize, efColor, efPoints); 
 
  TChange = procedure(Sender: TObject; Value: TWhat) of object; 
  TClock = procedure(Sender: TObject; Value: TEffect) of object; 
 
  TPunkt = class(TCustomLabel) 
  private 
    FVorn: TNotifyevent; 
    FChange: TChange; 
    FClock: TClock; 
    gr, strt, lgt: integer; 
    txt, dppl: string; 
    blk, lin: boolean; 
    frb, hig: TColor; 
    wieviel: word; 
    Timer: TTimer; 
    ef: TEffect; 
    t: cardinal; 
    fsz: TBg; 
  protected 
    procedure settxt(s: string); 
    procedure setviel(w: word); 
    procedure festlegen(b: boolean); 
    procedure seteffekt(b: TEffect); 
    procedure TimerRoll(Sender: TObject); 
    procedure TimerBlink(Sender: TObject); 
    procedure setfarbe(f: TColor); 
    procedure setfsz(i: TBg); 
    procedure sethig(c: TColor); 
    procedure setlin(b: boolean); 
  public 
    constructor Create(Owner: TComponent); override; 
    procedure paint; override; 
    procedure resize; override; 
    destructor Destroy; override; 
  published 
    property OnDblClick; 
    property OnClick; 
    property OnMouseMove; 
    property OnMouseDown; 
    property OnMouseUp; 
    property OnKomplett: TNotifyEvent read FVorn write FVorn; 
    property OnChange: TChange read FChange write FChange; 
    property OnClock: TClock read FClock write FClock; 
    property Buchstaben: word read wieviel write setviel; 
    property Effekt: TEffect read ef write seteffekt; 
    property Punkte: TColor read frb write setfarbe; 
    property Schrift: string read txt write settxt; 
    property Farbe: TColor read hig write sethig; 
    property Groesse: TBg read fsz write setfsz; 
    property Gitter: boolean read lin write setlin; 
  end; 
 
procedure Register; 
 
implementation 
 
constructor TPunkt.Create(Owner: TComponent); 
begin 
  inherited Create(Owner); 
  strt := 1; 
  lin := true; 
  Font.Name := 'Fixedsys'; 
  Font.size := 20; 
  Font.Color := clAqua; 
  frb := Font.color; 
  Color := clBlack; 
  hig := Color; 
  txt := 'Punkte * ';  
  lgt := length(txt); 
  wieviel := lgt; 
  dppl := txt + txt; 
  Caption := txt; 
  gr := 2; 
  Timer := TTimer.create(self); 
  Timer.Interval := 0; 
end; 
 
destructor TPunkt.Destroy; 
begin 
  Timer.free; 
  inherited Destroy; 
end; 
 
procedure TPunkt.resize; 
begin 
  autosize := false; 
  autosize := true; 
end; 
 
procedure TPunkt.festlegen(b: boolean); 
begin 
  if b then 
    if wieviel > lgt then wieviel := lgt; 
  caption := copy(txt, 1, wieviel); 
  repaint; 
end; 
 
procedure TPunkt.settxt(s: string); 
begin 
  if txt = s then exit; 
  t := Timer.interval; 
  Timer.interval := 0; 
  strt := 1; 
  txt := s; 
  lgt := length(txt); 
  dppl := txt + txt; 
  if lgt < wieviel then 
    wieviel := lgt; 
  festlegen(true); 
  Timer.interval := t; 
  if not (csLoading in componentstate) then 
    if assigned(FChange) then FChange(self, efText); 
end; 
 
procedure TPunkt.setviel(w: word); 
begin 
  if w = wieviel then exit; 
  t := Timer.interval; 
  Timer.interval := 0; 
  strt := 1; 
  wieviel := w; 
  festlegen(not (csLoading in componentstate)); 
  Timer.interval := t; 
  if not (csLoading in componentstate) then 
    if assigned(FChange) then FChange(self, efNumber); 
end; 
 
procedure TPunkt.paint; 
var i: integer; 
begin 
  inherited; 
  if lin then 
    with canvas do begin 
      pen.color := self.color; 
      for i := 0 to height div gr do begin 
        moveto(0, i * gr); 
        lineto(width, i * gr); 
      end; 
      for i := 0 to width div gr do begin 
        moveto(i * gr, 0); 
        lineto(i * gr, height); 
      end; 
    end; 
end; 
 
procedure TPunkt.TimerRoll(Sender: TObject); 
begin 
  inc(strt); 
  if strt > lgt then strt := 1; 
  caption := copy(dppl, strt, wieviel); 
  if not (csLoading in componentstate) then begin 
    if assigned(FClock) then FClock(self, efRoll); 
    if (strt = 1) then 
      if assigned(FVorn) then FVorn(self); 
  end; 
end; 
 
procedure TPunkt.TimerBlink(Sender: TObject); 
begin 
  if blk then Font.color := frb 
  else Font.color := color; 
  blk := not blk; 
  if not blk and not (csLoading in componentstate) then 
    if assigned(FClock) then FClock(self, efBlink); 
end; 
 
procedure TPunkt.seteffekt(b: TEffect); 
begin 
  if b = ef then exit; 
  ef := b; 
  strt := 1; 
  case ef of 
    efRoll: begin 
        Font.color := frb; 
        Timer.OnTimer := TimerRoll; 
        Timer.interval := 333; 
      end; 
    efBlink: begin 
        Timer.OnTimer := TimerBlink; 
        Timer.interval := 200; 
        blk := false; 
      end; 
  else begin 
      Timer.interval := 0; 
      Font.color := frb; 
    end; 
  end; 
  festlegen(false); 
  if not (csLoading in componentstate) then 
    if assigned(FChange) then FChange(self, efEffect); 
end; 
 
procedure TPunkt.setfarbe(f: TColor); 
begin 
  if frb = f then exit; 
  frb := f; 
  Font.color := f; 
  if not (csLoading in componentstate) then 
    if assigned(FChange) then FChange(self, efPoints); 
end; 
 
procedure TPunkt.setfsz(i: TBg); 
begin 
  if i = fsz then exit; 
  fsz := i; 
  case fsz of 
    efNormal: begin 
        gr := 2; 
        Font.size := 20; 
      end; 
    efBig: begin 
        gr := 3; 
        Font.size := 25; 
      end; 
  else begin 
      gr := 4; 
      Font.size := 35; 
    end; 
  end; 
  if not (csLoading in componentstate) then 
    if assigned(FChange) then FChange(self, efSize); 
end; 
 
procedure TPunkt.sethig(c: TColor); 
begin 
  if c = hig then exit; 
  hig := c; 
  color := c; 
  if not (csLoading in componentstate) then 
    if assigned(FChange) then FChange(self, efColor); 
end; 
 
procedure TPunkt.setlin(b: boolean); 
begin 
  if b = lin then exit; 
  lin := b; 
  repaint; 
end; 
 
procedure Register; 
begin 
  RegisterComponents('DBR', [TPunkt]); 
end; 
 
end. 
 
//------------------------ Beispielaufrufe ------------------------- 
 
 
// Fünf mal blinken lassen 
 
var z: integer; 
 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
  z := 0; 
  Punkt1.effekt := efBlink; 
end; 
 
procedure TForm1.Punkt1Clock(Sender: TObject; Value: TEffect); 
begin 
  if Value = efBlink then begin 
    inc(z); 
    if z = 5 then Punkt1.Effekt := efNone; 
  end; 
end; 
 
// längeren Text zuweisen und komplett anzeigen 
 
procedure TForm1.Button2Click(Sender: TObject); 
begin 
  Punkt1.schrift := 'Das ist ein Test!'; 
  Punkt1.Buchstaben := length(Punkt1.schrift); 
end; 
 
// kürzeren Text zuweisen 
 
procedure TForm1.Button3Click(Sender: TObject); 
begin 
  Punkt1.schrift := 'A'; 
end; 
 
// Textdatei mittels Laufschrift anzeigen 
 
procedure TForm1.Button4Click(Sender: TObject); 
var sl: TStringlist; 
begin 
  sl := TStringlist.create; 
  sl.loadfromfile('c:\test.txt'); 
  sl.text := stringreplace(sl.text, #13#10, #32, [rfreplaceall]); 
  sl.text := stringreplace(sl.text, #9, #32, [rfreplaceall]); 
  Punkt1.schrift := sl.text; 
  Punkt1.Buchstaben := 25; // z.B. 
  sl.free; 
  Punkt1.Effekt := efRoll; 
end; 
 
// Text zweimal komplett durchlaufen lassen 
 
var i: integer; 
 
procedure TForm1.Button5Click(Sender: TObject); 
begin 
  i := 0; 
  Punkt1.schrift := 'Laufschrift - Test - '; 
  Punkt1.Buchstaben := maxword; 
  Punkt1.effekt := efRoll; 
end; 
 
procedure TForm1.Punkt1Komplett(Sender: TObject); 
begin 
  inc(i); 
  if i = 2 then Punkt1.Effekt := efNone; 
end; 
 
// Blinken bzw. Laufen beenden 
 
procedure TForm1.Button6Click(Sender: TObject); 
begin 
  Punkt1.Effekt := efNone; 
end;


//------------------- Erläuterung der Eigenschaften ----------------

OnKomplett (Event, nur zur Laufzeit)
 
Wird jedesmal ausgelöst, wenn eine Laufschrift komplett durchgelaufen ist
  und der erste Buchstabe wieder links steht.

OnChange (Event, nur zur Laufzeit)
 
Wird jedesmal ausgelöst, wenn sich bei der Komponente irgend etwas ändert.
  Value =
 
efText:   Der Text wurde verändert.
 
efEffect:
Der Effekt (Blinken, Laufschrift ein/aus) wurde geändert.
 
efNumber:
Anzahl der zu sehenden Buchstaben wurde geändert.
  efSize:  
Die Anzeigegröße wurde geändert.
  efColor: 
Die Hintergrundfarbe wurde geändert.
 
efPoints:
Die Farbe der Schrift wurde verändert.

OnClock (Event, nur zur Laufzeit)
 
Wird jedesmal ausgelöst, wenn die Schrift einmal geblinkt hat oder
  wenn ein Buchstabe der Laufschrift nach links gewandert ist.
  Value =
  efRoll:
   Es läuft gerade die Laufschrift.
 
efBlink:  Die Schrift blinkt gerade;

Buchstaben (Word)
  Legt die Anzahl der gleichzeitig zu sehenden Zeichen fest. Ist diese
  Eigenschaft kleiner als die Länge des Textes, wird nur ein Teiltext angezeigt,
  ist sie größer, wird sie automatisch angepasst.

Effekt (TEffekt)
 
efNone Kein Effekt (Effekte ausschalten)
 
efRoll Laufschrift
  efBlink:
Blinken

Punkte (TColor)
 
Legt die Schriftfarbe fest.

Schrift (String)
 
Anzuzeigender [Teil]Text

Farbe (TColor)
  Legt die Hintergrundfarbe fest.

Groesse (TBg)
 
Setzt die Anzeigegröße.
 
efNormal: Normalgröße
 
efBig:
    Groß
  efBigger:
Größer

Gitter (Boolean)
  Legt fest ob Punkt- oder normale Schrift angezeigt wird.


//-------------------------------------------------------------

// 2. Erweiterte Variante

// Punktschrift in vier Größen mit sieben Effekten.
//
Hinweis:
// Wenn Sie das Package, welche die Komponente enthält, neu übersetzen,
// dann sollte kein Projekt geöffnet sein, das diese Komponente benutzt.

unit PunktX; 
 
interface 
 
uses 
  Windows, SysUtils, Classes, Graphics, Controls, Forms, Extctrls; 
 
type 
  TGrs = (xSmall, xBig, xBigger, xBiggest); 
  TEff = (xNone, xRollLetter, xRollColor, xBlink, 
    xRollDown, xRollUp, xRollPoint, xFalling); 
  TWht = (xText, xEffect, xLetters, xSize, xColor, xPoints, xGrid); 
 
  TChange = procedure(Sender: TObject; Value: TWht) of object; 
  TClock = procedure(Sender: TObject; Value: TEff) of object; 
  TNeu = procedure(Sender: TObject; Value: TEff; Inside: Boolean) of object; 
 
  TPunktX = class(TCustomPanel) // kein Flackern
  private 
    FVorn: TNotifyEvent; 
    FChange: TChange; 
    FClock: TClock; 
    FNeu: TNeu; 
    fllarr: array of integer; 
    lgt, gr, strt, rd, rll, stl, lauf: integer; 
    lin, blk, se, auch: boolean; 
    arr: array of TColor; 
    bm, gsmt: TBitmap; 
    hig, neg: TColor; 
    sl: TStringlist; 
    txt, pf: string; 
    wieviel: word; 
    Timer: TTimer; 
    r, g, b: byte; 
    ps: cardinal; 
    sz: TSize; 
    fsz: TGrs; 
    ef: TEff; 
  protected 
    procedure TimerGo(Sender: TObject); 
    procedure setlin(b: boolean); 
    procedure seteffekt(b: TEff); 
    procedure settxt(s: string); 
    procedure sethig(c: TColor); 
    procedure setviel(w: word); 
    procedure setpf(c: string); 
    procedure raus(b: boolean); 
    procedure setfsz(i: TGrs); 
    procedure getgrsse; 
    procedure setfarr; 
    procedure warten; 
  public 
    constructor Create(Owner: TComponent); override; 
    destructor Destroy; override; 
    procedure Resize; override; 
    procedure Paint; override; 
  published 
    property Pause: Cardinal read ps write ps; 
    property Farben: string read pf write setpf; 
    property Groesse: TGrs read fsz write setfsz; 
    property Effekt: TEff read ef write seteffekt; 
    property Schrift: string read txt write settxt; 
    property Gitter: boolean read lin write setlin; 
    property Hintergrund: TColor read hig write sethig; 
    property Zeichenzahl: word read wieviel write setviel; 
    property PauseOhneSchrift: boolean read auch write auch; 
    property OnKomplett: TNotifyEvent read FVorn write FVorn; 
    property OnChange: TChange read FChange write FChange; 
    property OnClock: TClock read FClock write FClock; 
    property OnReinRaus: TNeu read FNeu write FNeu; 
    property Visible; 
    property OnClick; 
    property OnDblClick; 
    property OnMouseUp; 
    property OnMouseMove; 
    property OnMouseDown; 
  end; 
 
procedure Register; 
 
implementation 
 
constructor TPunktX.Create(Owner: TComponent); 
begin 
  inherited Create(Owner); 
  lin := true; 
  auch := false; 
  se := false; 
  pf := '$EE $FF4000 $9900'; 
  bm := TBitmap.create; 
  gsmt := TBitmap.create; 
  gsmt.canvas.brush.style := bsClear; 
  sethig(clWhite); 
  bm.canvas.Font.name := 'Fixedsys'; 
  bm.canvas.Font.size := 25; 
  fsz := xBig; 
  gr := 3; 
  sl := TStringlist.create; 
  getgrsse; 
  Timer := TTimer.Create(self); 
  Timer.interval := 0; 
  strt := 0; 
  rll := 0; 
  rd := 0; 
  blk := false; 
  Timer.OnTimer := TimerGo; 
  wieviel := 6; 
  setfarr; 
  settxt('PunktX '); 
end; 
 
destructor TPunktX.Destroy; 
begin 
  Timer.free; 
  sl.free; 
  bm.free; 
  gsmt.free; 
  arr := nil; 
  fllarr := nil; 
  inherited Destroy; 
end; 
 
procedure TPunktX.getgrsse; 
begin 
  sz := bm.canvas.textextent('W'); 
  bm.width := sz.cx; 
  bm.height := sz.cy; 
end; 
 
procedure TPunktX.raus(b: boolean); 
begin 
  if not (csLoading in componentstate) then begin 
    if assigned(FNeu) then FNeu(self, ef, b); 
    if b or auch then warten; 
  end; 
end; 
 
procedure TPunktX.Resize; 
begin 
  width := wieviel * sz.cx + 2; 
  height := sz.cy + 2; 
  gsmt.width := width; 
  gsmt.height := height; 
end; 
 
procedure TPunktX.settxt(s: string); 
begin 
  if (s = txt) or (s = '') then exit; 
  txt := s; 
  lgt := length(txt); 
  if wieviel > lgt then wieviel := lgt; 
  strt := 0; 
  rll := 0; 
  resize; 
  setpf(#1 + pf); 
  if not (csLoading in componentstate) then 
    if assigned(FChange) then FChange(self, xText); 
end; 
 
procedure TPunktX.setpf(c: string); 
var x: integer; 
  ev: boolean; 
begin 
  if (c = pf) then exit; 
  ev := copy(c, 1, 1) = #1; 
  pf := trim(c); 
  if pf = '' then pf := ColorToString(neg); 
  sl.commatext := pf; 
  while sl.count < lgt do 
    sl.text := sl.text + sl.text; 
  setlength(arr, lgt); 
  for x := 0 to high(arr) do 
  try 
    arr[x] := StringToColor(sl[x]); 
  except 
    arr[x] := neg; 
  end; 
  sl.clear; 
  repaint; 
  if not (csLoading in componentstate) and not ev then 
    if assigned(FChange) then FChange(self, xPoints); 
end; 
 
procedure TPunktX.setfsz(i: TGrs); 
var m: cardinal; 
begin 
  if i = fsz then exit; 
  m := Timer.interval; 
  Timer.interval := 0; 
  fsz := i; 
  with bm.canvas do 
    case fsz of 
      xSmall: begin 
          gr := 2; 
          Font.size := 20; 
        end; 
      xBig: begin 
          gr := 3; 
          Font.size := 25; 
        end; 
      xBigger: begin 
          gr := 4; 
          Font.size := 35; 
        end; 
    else begin 
        gr := 5; 
        Font.size := 50; 
      end; 
    end; 
  rd := 0; 
  getgrsse; 
  setfarr; 
  Resize; 
  repaint; 
  Timer.interval := m; 
  if not (csLoading in componentstate) then 
    if assigned(FChange) then FChange(self, xSize); 
end; 
 
procedure TPunktX.setlin(b: boolean); 
begin 
  if b = lin then exit; 
  lin := b; 
  repaint; 
  if not (csLoading in componentstate) then 
    if assigned(FChange) then FChange(self, xGrid); 
end; 
 
procedure TPunktX.setviel(w: word); 
begin 
  if w > lgt then w := lgt; 
  if (w = wieviel) or (w = 0) then exit; 
  wieviel := w; 
  strt := 0; 
  rll := 0; 
  setfarr; 
  resize; 
  if not (csLoading in componentstate) then 
    if assigned(FChange) then FChange(self, xLetters); 
end; 
 
procedure TPunktX.warten; 
var zeit, m: cardinal; 
begin 
  if ps = 0 then exit; 
  m := Timer.interval; 
  Timer.interval := 0; 
  zeit := gettickcount + ps; 
  repeat 
    application.processmessages; 
    if application.terminated then exit; 
  until (gettickcount >= zeit); 
  Timer.interval := m; 
end; 
 
procedure TPunktX.setfarr; 
var x: integer; 
begin 
  setlength(fllarr, wieviel); 
  for x := 0 to wieviel - 1 do 
    fllarr[x] := 0; 
  stl := 0; 
  lauf := 0; 
end; 
 
procedure TPunktX.sethig(c: TColor); 
begin 
  if (c = hig) then exit; 
  hig := ColorToRGB(c); 
  bm.canvas.brush.color := hig; 
  gsmt.canvas.pen.color := hig; 
  r := getrvalue(hig); 
  g := getgvalue(hig); 
  b := getbvalue(hig); 
  neg := rgb(255 - r, 255 - g, 255 - b); 
  repaint; 
  if not (csLoading in componentstate) then 
    if assigned(FChange) then FChange(self, xColor); 
end; 
 
procedure TPunktX.seteffekt(b: TEff); 
begin 
  if (b = ef) then exit; 
  Timer.interval := 0; 
  se := true; 
  ef := b; 
  if not (ef in [xRollDown, xRollUp]) then rd := 0; 
  setfarr; 
  strt := 0; 
  rll := 0; 
  blk := false; 
  repaint; 
  case ef of 
    xBlink: Timer.interval := 220; 
    xRollPoint, xFalling: Timer.interval := 110; 
    xRollLetter, xRollColor: Timer.interval := 330; 
    xRollDown, xRollUp: begin 
        rd := -rd; 
        Timer.interval := 120; 
      end; 
  else repaint; 
  end; 
  if not (csLoading in componentstate) then 
    if assigned(FChange) then FChange(self, xEffect); 
end; 
 
procedure TPunktX.TimerGo(Sender: TObject); 
begin 
  case ef of 
    xRollPoint: begin 
        inc(rll); 
        if rll * gr >= sz.cx then begin 
          rll := 0; 
          inc(strt); 
          if strt >= lgt then strt := 0; 
        end; 
      end; 
    xRollColor: begin 
        dec(strt); 
        if strt < 0 then strt := lgt - 1; 
      end; 
    xRollLetter: begin 
        inc(strt); 
        if strt >= lgt then strt := 0; 
      end; 
    xBlink: blk := not blk; 
    xRollDown: begin 
        inc(rd, gr); 
        if rd > sz.cy then begin 
          rd := -sz.cy; 
          raus(false); 
        end; 
      end; 
    xRollUp: begin 
        dec(rd, gr); 
        if rd < -sz.cy then begin 
          rd := sz.cy; 
          raus(false); 
        end; 
      end; 
    xFalling: begin 
        inc(fllarr[stl], gr * 3); 
        if fllarr[stl] > sz.cy + gr * 2 then fllarr[stl] := 0; 
        inc(stl); 
      end; 
  end; 
  repaint; 
  if not (csLoading in componentstate) and not blk then 
    if assigned(FClock) then FClock(self, ef); 
  if not se then begin 
    if (stl = wieviel) then 
      inc(lauf); 
    if lauf in [5, 12] then begin 
      lauf := 6; 
      raus(false); 
    end; 
    if (strt = 0) then 
      if (ef = xRollLetter) or (ef = xRollColor) 
        or (ef = xRollPoint) and (rll = 0) 
        or (ef = xFalling) and (stl = wieviel) and (fllarr[wieviel - 1] = 0) 
        then begin 
        if not (csLoading in componentstate) then 
          if assigned(FVorn) then FVorn(self); 
        warten; 
      end; 
    if (ef in [xRollUp, xRollDown]) and (rd = 0) 
      then raus(true); 
  end; 
  se := false; 
  if stl = wieviel then stl := 0; 
end; 
 
procedure TPunktX.paint; 
var x, y, z, k: integer; 
begin 
  x := 1; 
  while x <= wieviel do begin 
    case ef of 
      xRollPoint, xRollLetter: begin 
          y := x + strt; 
          if y > lgt then y := y - lgt; 
          z := y - 1; 
        end; 
      xRollColor: begin 
          z := x + strt - 1; 
          if z >= lgt then z := z - lgt; 
          y := x; 
        end; 
    else begin 
        y := x; 
        z := x - 1; 
      end; 
    end; 
    with bm.canvas do begin 
      fillrect(cliprect); 
      if blk then 
        Font.color := hig else 
        Font.color := arr[z]; 
      textout(0, rd, txt[y]); 
    end; 
    gsmt.canvas.draw(1 + (x - 1) * sz.cx - gr * rll, 1 + fllarr[x - 1], bm); 
    if (ef = xRollPoint) and (x = wieviel) then begin 
      with bm.canvas do begin 
        fillrect(cliprect); 
        y := strt + wieviel + 1; 
        if y > lgt then y := y - lgt; 
        Font.color := arr[y - 1]; 
        textout(0, rd, txt[y]); 
      end; 
      gsmt.canvas.draw(1 + x * sz.cx - gr * rll, 1, bm); 
    end 
    else if ef = xFalling then begin 
      if fllarr[x - 1] < 0 then k := sz.cy else k := -sz.cy; 
      with bm.canvas do fillrect(cliprect); 
      gsmt.canvas.draw(1 + (x - 1) * sz.cx - gr * rll, 1 + 
        fllarr[x - 1] + k, bm); 
    end; 
    inc(x); 
  end; 
  if lin then 
    with gsmt.canvas do begin 
      for x := 0 to height div gr do begin 
        moveto(0, x * gr); 
        lineto(width - 1, x * gr); 
      end; 
      for x := 0 to width div gr do begin 
        moveto(x * gr, 0); 
        lineto(x * gr, height - 1); 
      end; 
    end; 
  gsmt.canvas.rectangle(0, 0, width, height); 
  canvas.draw(0, 0, gsmt); 
end; 
 
procedure Register; 
begin 
  RegisterComponents('DBR', [TPunktX]); 
end; 
 
end.

//---------------------------------------------------------

Erläuterung der zusätzlichen Eigenschaften:

Pause (Cardinal)
  Wenn ein kompletter Durchlauf der Schrift erfolgt ist, wartet die
  Komponente entsprechend der hier angegebenen Millisekunden. Diese
  Eigenschaft hat keinen Einfluss auf den Effekt xBlink.
  Bei den Effekten xRollUp und xRollDown wirkt die Pause nur, wenn die
  Schrift komplett eingefahren ist oder "PauseOhneSchrift" auf "True" steht.


PauseOhneSchrift (Boolean)
  Bei "True" wird die Pause auch dann eingehalten, wenn die Schrift aus
  der Anzeige komplett herausgefahren ist.

Farben (String)
  Hier kann man Farbfolgen (getrennt durch Leerzeichen) hinterlegen. Wenn
  man beispielsweise
'clRed clBlack clBlue' angibt, wird der erste Buchstabe
  Rot, der zweite Schwarz, der dritte Blau, der vierte wieder Rot, der
  fünfte wieder Schwarz usw.

OnReinRaus
(Event, nur zur Laufzeit)
  Dieses Event wird ausgelöst, wenn bei den Effekten xRollDown oder
  xRollUp die Schrift komplett heraus bzw. herein gefahren ist, oder
  bei xFalling, wenn die Schrift komplett heraus gefallen ist, wobei
  die Variable "Inside" angibt, ob die Schrift zu sehen ist oder nicht.

OnKomplett
(Event, nur zur Laufzeit)
  Zusätzlich zur Variante 1 wird dieses Event auch ausgelöst, wenn beim
  Effekt xFalling die Schrift wieder komplett dargestellt wird.

//--------------------  Beispielaufruf 1  ------------------- 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  doublebuffered := true; 
  PunktX1.Schrift := 'DEMO '; 
  PunktX1.Zeichenzahl := 4; 
  PunktX1.Groesse := xBig; 
  PunktX1.Pause := 300; 
  PunktX1.Hintergrund := $99FFFF; 
  PunktX1.farben := 'clNavy'; 
  PunktX1.Effekt := xRollDown; 
end; 
 
procedure TForm1.PunktX1ReinRaus(Sender: TObject; Value: TEff; 
  Inside: Boolean); 
begin 
  if inside then PunktX1.Effekt := xRollPoint 
  else begin 
    if PunktX1.Schrift = 'DEMO ' then 
      PunktX1.Schrift := 'TEST ' else 
      PunktX1.Schrift := 'DEMO '; 
  end; 
end; 
 
procedure TForm1.PunktX1Komplett(Sender: TObject); 
begin 
  PunktX1.Effekt := xRollDown; 
end; 
 
//--------------------  Beispielaufruf 2  ------------------- 
 
var 
  z: integer = 0; 
  frb: array[0..5] of string = 
  ('clBlack', 'clRed', 'clGreen', 'clMaroon', 'clBlue', 'clPurple'); 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  doublebuffered := true; 
  PunktX1.Schrift := 'Borland'; 
  PunktX1.Zeichenzahl := 7; 
  PunktX1.Groesse := xBigger; 
  PunktX1.Pause := 1000; 
  PunktX1.Hintergrund := Color; 
  PunktX1.farben := frb[z]; 
  PunktX1.Effekt := xRollDown; 
end; 
 
procedure TForm1.PunktX1ReinRaus(Sender: TObject; Value: TEff; 
  Inside: Boolean); 
begin 
  if Value in [xRollup, xRollDown] then begin 
    if not inside then begin 
      inc(z); 
      if z > 5 then z := 0; 
      PunktX1.farben := frb[z]; 
      if PunktX1.Schrift = 'Inprise' 
        then PunktX1.Schrift := 'Borland' 
      else PunktX1.Schrift := 'Inprise'; 
    end; 
    if Value = xRollUp then 
      PunktX1.Effekt := xRollDown else 
      PunktX1.Effekt := xRollUp; 
  end; 
end; 
 
//--------------------  Beispielaufruf 3  ------------------- 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  with PunktX1 do begin 
    Schrift := 'EINS'; 
    Zeichenzahl := 4; 
    Groesse := xBig; 
    Pause := 2000; 
    PauseOhneSchrift := false; 
    Hintergrund := clBlack; 
    farben := 'clLime clyellow'; 
    Effekt := xFalling; 
  end; 
end; 
 
procedure TForm1.PunktX1ReinRaus(Sender: TObject; Value: TEff; 
  Inside: Boolean); 
begin 
  if punktx1.schrift = 'EINS' then begin 
    punktx1.schrift := 'ZWEI'; 
    punktx1.farben := 'clsilver clfuchsia'; 
  end else begin 
    punktx1.schrift := 'EINS'; 
    punktx1.farben := 'clLime clyellow'; 
  end; 
end;

 


 

Zugriffe seit 6.9.2001 auf Delphi-Ecke