// Komponente für
eine sogenannte Punktschrift.
Das Ganze wird erreicht
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;
OnKomplett
(Event,
nur zur Laufzeit) Groesse
(TBg) //
2.
Erweiterte Variante 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.
//--------------------------------------------------------- //-------------------- 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