DBR Delphi-Ecke

// Es wird auf schwarzem Hintergrund Text in Großbuchstaben Zeile für
// Zeile eingerollt. Der obere und/oder der untere Teil der Schrift kann
// überschattet werden. Es ist wichtig, dass die Schriftfarbe relativ
// hell ist, ansonsten sieht man im Schatten Abstufungen oder der
// Schatten ist gar nicht zu sehen. Der Hintergrund sollte stets schwarz sein.
// Falls sie ihn trotzdem ändern wollen, muss er dann natürlich ausreichend
// dunkel sein. Die Anzahl der Buchstaben pro Textzeile darf 50 nicht
// überschreiten.

// Variante 1:
// Der Text wird zeilenweise nacheinander und untereinander von oben her eingerollt.

	Hier nur einzeilig als Demo (oberer Teil überschattet)
	Drei Zeilen komplett eingerollt

// Getestet mit D4 unter XP

type 
  TForm1 = class(TForm) 
    Button1: TButton; 
    Timer1: TTimer; 
    procedure FormCreate(Sender: TObject); 
    procedure FormDestroy(Sender: TObject); 
    procedure Button1Click(Sender: TObject); 
    procedure Timer1Timer(Sender: TObject); 
  private 
    { Private-Deklarationen } 
  public 
    procedure build(bm: TBitmap; s: string; FontC: TColor); 
    procedure start(f: array of TColor; mito, mitu: boolean; 
      geschw: cardinal; loesch: boolean); 
  end; 
 
var 
  Form1: TForm1; 
function GradientFill(hdc: HDC; pVertex: PTriVertex; 
  dwNumVertex: DWORD; pMesh: Pointer; 
  dwNumMesh: DWORD; dwMode: DWORD): Boolean; stdcall; 
external 'gdi32.dll' name 'GdiGradientFill'; 
 
implementation 
 
{$R *.DFM} 
 
var 
  schrift: array[0..2] of string = ('Versuch', 'Delphi', 'Test'); 
  font1: array[0..2] of TColor = (clRed, clWhite, clFuchsia); 
  font2: array[0..2] of TColor = (clLime, clYellow, clAqua); 
  bmps: array of TBitmap; 
  welches, breit, hoch, step, diff: integer; 
  Rand: integer = 4; 
  Img: TImage; 
  schattenoben, schattenunten: TBitmap; 
  obenMit, untenMit: Boolean; 
  Hig: TColor = clBlack; 
 
procedure Verlauf(DC: HDC; x1, y1, x2, y2: integer; von, nach: TColor); 
type 
  TVertex = packed record 
    x, y: Integer; 
    rot, gruen, blau, Alpha: Word; 
  end; 
const 
  VertexCount = 2; 
var 
  Vertex: array[0..VertexCount - 1] of TVertex; 
  TVRect: TGradientRect; 
begin 
  von := ColorToRGB(von); 
  nach := ColorToRGB(nach); 
  Vertex[0].x := x1; 
  Vertex[0].y := y1; 
  Vertex[0].rot := getrvalue(von) shl 8; 
  Vertex[0].gruen := getgvalue(von) shl 8; 
  Vertex[0].blau := getbvalue(von) shl 8; 
  Vertex[0].Alpha := 0; 
  Vertex[1].x := x2; 
  Vertex[1].y := y2; 
  Vertex[1].rot := getrvalue(nach) shl 8; 
  Vertex[1].gruen := getgvalue(nach) shl 8; 
  Vertex[1].blau := getbvalue(nach) shl 8; 
  Vertex[1].Alpha := 0; 
  with TVREct do begin 
    UpperLeft := 0; 
    LowerRight := 1; 
  end; 
  GradientFill(DC, @Vertex[0], VertexCount, @TVREct, 1, GRADIENT_FILL_RECT_V); 
end; 
 
procedure TForm1.build(bm: TBitmap; s: string; FontC: TColor); 
var 
  r: TRect; 
begin 
  bm.width := breit; 
  bm.height := hoch - diff; 
  with bm.canvas do begin 
    Font.Color := FontC; 
    r := Cliprect; 
    brush.color := Hig; 
    fillrect(r); 
    drawtext(handle, pchar(s), -1, r, 
      dt_singleline or dt_center); 
  end; 
end; 
 
procedure TForm1.FormCreate(Sender: TObject); 
var 
  x, b: integer; 
  tm: tagTEXTMETRICA; 
begin 
  Timer1.enabled := false; 
  breit := -1; 
  img := TImage.create(self); 
  img.visible := false; 
  img.parent := self; 
  img.autosize := true; 
  setlength(bmps, length(schrift)); 
  for x := 0 to high(bmps) do begin 
    bmps[x] := TBitmap.create; 
    schrift[x] := copy(ansiuppercase(schrift[x]), 1, 50); 
    with bmps[x].canvas do begin 
      Font.Name := 'Arial'; // sollte TrueType sein 
      Font.size := 20; 
      Font.style := [fsBold]; 
      b := TextWidth(schrift[x]); 
      if b > breit then breit := b; 
    end; 
  end; 
  GetTextMetrics(bmps[0].canvas.handle, tm); 
  diff := tm.tmInternalLeading + tm.tmExternalLeading; 
  hoch := tm.tmHeight; 
  breit := breit + Rand * 2; 
  with img.picture.bitmap, canvas do begin 
    width := breit; 
    height := hoch * length(bmps) + Rand; 
  end; 
  schattenoben := TBitmap.create; 
  schattenoben.width := breit; 
  schattenunten := TBitmap.create; 
  schattenunten.width := breit; 
  schattenoben.height := round(hoch / 2.5); 
  schattenunten.height := schattenoben.height; 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
var 
  x: integer; 
begin 
  img.free; 
  for x := 0 to high(bmps) do bmps[x].free; 
  bmps := nil; 
  schattenoben.free; 
  schattenunten.free; 
end; 
 
procedure TForm1.Timer1Timer(Sender: TObject); 
begin 
  with img.canvas do begin 
    copyrect(rect(0, welches * (bmps[welches].height + diff), width, step + 
      welches * (bmps[welches].height + diff)), 
      bmps[welches].canvas, rect(0, bmps[welches].height - step, 
      width, bmps[welches].height)); 
    if obenMit then 
      bitblt(handle, 0, welches * (bmps[welches].height + diff), img.width, 
        schattenoben.height + diff, schattenoben.canvas.handle, 0, 0, SRCAND); 
    if untenMit then 
      bitblt(handle, 0, hoch + welches * (bmps[welches].height + diff) - 
        schattenunten.height, img.width, hoch + diff, 
        schattenunten.canvas.handle, 0, 0, SRCAND); 
  end; 
  inc(step); 
  if step > bmps[welches].height + rand div 2 
    then begin 
    step := 1; 
    inc(welches); 
    if welches > high(bmps) then 
      Timer1.enabled := false; 
  end; 
end; 
 
procedure TForm1.start(f: array of TColor; mito, mitu: boolean; 
  geschw: cardinal; loesch: boolean); 
var 
  x: integer; 
begin 
  obenMit := mito; 
  untenMit := mitu; 
  verlauf(schattenoben.canvas.handle, 0, 0, breit, schattenoben.height, 
    Hig, clWhite); 
  verlauf(schattenunten.canvas.handle, 0, 0, breit, schattenunten.height, 
    clWhite, Hig); 
  for x := 0 to high(bmps) do 
    build(bmps[x], schrift[x], f[x]); 
  welches := 0; 
  img.left := 200; 
  img.top := 50; 
  with img, picture.bitmap.canvas do begin 
    brush.color := Hig; 
    if loesch then fillrect(cliprect); 
    visible := true; 
  end; 
  step := 1; 
  Timer1.interval := geschw; 
  Timer1.enabled := true; 
end; 
 
 
// Beispielaufruf 
 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
  Button1.enabled := false; 
  start(font1, true, false, 50, true); 
  repeat 
    application.processmessages; 
  until not Timer1.enabled; 
  start(font2, true, false, 50, false); 
  repeat 
    application.processmessages; 
  until not Timer1.enabled; 
  Button1.enabled := true; 
end;

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

// Variante 2:
// Der Text wird nacheinander in eine einzige Zeile von unten her eingerollt.
// Die Variable Pause entscheidet, wie lange eine Textzeile stehen bleit,
// bevor sie weitergerollt wird. Bei negativen Werten muss manuell mittels
// Klick auf Button2 weitergerollt werden. Die Variable Loop läßt bei True
// den Text ständig wiederholen. Setzt man die Variable Rollen auf False,
// werden die Textzeilen schlagartig angezeigt. Dafür sollte Pause einen
// ausreichenden Wert besitzen, da sonst die Zeilen einfach "vorbeirauschen".
// Die Variable Geschw ist für den Intervall des Timers verantwortlich und
// sollte nicht über 100 ms liegen. Die Anzahl der Buchstaben pro Textzeile
// darf 50 nicht überschreiten.

Hier nur eine Zeile Text als Demo (mit Schatten)

type 
  TForm1 = class(TForm) 
    Button1: TButton; 
    Timer1: TTimer; 
    Button2: TButton; 
    Button3: TButton; 
    procedure FormCreate(Sender: TObject); 
    procedure FormDestroy(Sender: TObject); 
    procedure Timer1Timer(Sender: TObject); 
    procedure Button1Click(Sender: TObject); 
    procedure Button2Click(Sender: TObject); 
    procedure Button3Click(Sender: TObject); 
  private 
    { Private-Deklarationen } 
  public 
    procedure build; 
  end; 
 
var 
  Form1: TForm1; 
function GradientFill(hdc: HDC; pVertex: PTriVertex; 
  dwNumVertex: DWORD; pMesh: Pointer; 
  dwNumMesh: DWORD; dwMode: DWORD): Boolean; stdcall; 
external 'gdi32.dll' name 'GdiGradientFill'; 
 
implementation 
 
{$R *.DFM} 
 
var 
  geschw, welches, breit, hoch, step, rand, pause: integer; 
  schattenoben, schattenunten: TBitmap; 
  stopp, loop, rollen: boolean; 
  FontC: array of TColor; 
  durch: boolean = true; 
  mitSchatten: boolean; 
  schrift: Tstringlist; 
  HigC: TColor; 
  bmp: TBitmap; 
  Img: TImage; 
 
procedure Verlauf(DC: HDC; x1, y1, x2, y2: integer; von, nach: TColor); 
type 
  TVertex = packed record 
    x, y: Integer; 
    rot, gruen, blau, Alpha: Word; 
  end; 
const 
  VertexCount = 2; 
var 
  Vertex: array[0..VertexCount - 1] of TVertex; 
  TVRect: TGradientRect; 
begin 
  von := ColorToRGB(von); 
  nach := ColorToRGB(nach); 
  Vertex[0].x := x1; 
  Vertex[0].y := y1; 
  Vertex[0].rot := getrvalue(von) shl 8; 
  Vertex[0].gruen := getgvalue(von) shl 8; 
  Vertex[0].blau := getbvalue(von) shl 8; 
  Vertex[0].Alpha := 0; 
  Vertex[1].x := x2; 
  Vertex[1].y := y2; 
  Vertex[1].rot := getrvalue(nach) shl 8; 
  Vertex[1].gruen := getgvalue(nach) shl 8; 
  Vertex[1].blau := getbvalue(nach) shl 8; 
  Vertex[1].Alpha := 0; 
  with TVREct do begin 
    UpperLeft := 0; 
    LowerRight := 1; 
  end; 
  GradientFill(DC, @Vertex[0], VertexCount, @TVREct, 1, GRADIENT_FILL_RECT_V); 
end; 
 
procedure TForm1.build; 
var 
  tm: TTextMetric; 
  x, b: integer; 
  r: TRect; 
begin 
  with bmp.canvas do begin 
    Font.Name := 'Arial'; 
    Font.size := 20; 
    Font.style := [fsBold]; 
    brush.color := HigC; 
    GetTextMetrics(handle, tm); 
    hoch := tm.tmHeight; 
    breit := -1; 
    Rand := round(sqrt(Font.size) * 2); 
    for x := 0 to schrift.count - 1 do begin 
      schrift[x] := copy(ansiuppercase(schrift[x]), 1, 50); 
      b := TextWidth(schrift[x]); 
      if b > breit then breit := b; 
    end; 
    breit := breit + rand * 2; 
    bmp.width := breit; 
    bmp.height := hoch * (schrift.count + ord(loop)) + 1; 
    fillrect(cliprect); 
  end; 
  with img.picture.bitmap do begin 
    width := breit; 
    height := hoch + rand * 2 - 1; 
    with canvas do begin 
      brush.color := HigC; 
      fillrect(cliprect); 
    end; 
  end; 
  schattenoben.width := breit; 
  schattenunten.width := breit; 
  schattenoben.height := round(hoch / 3.33); 
  schattenunten.height := round(hoch / 1.75); 
  verlauf(schattenoben.canvas.handle, 0, 0, breit, schattenoben.height, 
    HigC, clWhite); 
  verlauf(schattenunten.canvas.handle, 0, 0, breit, schattenunten.height, 
    clWhite, HigC); 
  with bmp.canvas do begin 
    for x := 0 to schrift.count - 1 do begin 
      Font.color := FontC[x]; 
      r := rect(0, x * hoch, breit, x * hoch + hoch); 
      drawtext(handle, pchar(schrift[x]), -1, r, 
        dt_singleline or dt_center); 
    end; 
    if loop then begin 
      Font.color := FontC[0]; 
      r := rect(0, schrift.count * hoch, breit, 
        schrift.count * hoch + hoch); 
      drawtext(bmp.canvas.handle, pchar(schrift[0]), -1, r, 
        dt_singleline or dt_center); 
    end; 
  end; 
  welches := 0; 
  step := hoch * ord(not rollen); 
  Timer1.interval := 1 + geschw * ord(rollen); 
end; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  Timer1.enabled := false; 
  img := TImage.create(self); 
  img.visible := false; 
  img.parent := self; 
  img.autosize := true; 
  bmp := TBitmap.create; 
  schattenoben := TBitmap.create; 
  schattenunten := TBitmap.create; 
  schrift := TStringlist.create; 
  schrift.add('Versuch'); 
  schrift.add('Delphi'); 
  schrift.add('Test'); 
  setlength(FontC, 3); 
  FontC[0] := clYellow; 
  FontC[1] := clLime; 
  FontC[2] := clAqua; 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
begin 
  schrift.free; 
  img.free; 
  bmp.free; 
  schattenoben.free; 
  schattenunten.free; 
  FontC := nil; 
end; 
 
procedure TForm1.Timer1Timer(Sender: TObject); 
var 
  zeit: cardinal; 
begin 
  with img.canvas do begin 
    copyrect(rect(0, rand, width, hoch + rand), 
      bmp.canvas, rect(0, step - hoch + welches * hoch, 
      width, step + welches * hoch)); 
    if mitSchatten then begin 
      bitblt(handle, 0, rand, img.width, schattenoben.height + rand, 
        schattenoben.canvas.handle, 0, 0, SRCAND); 
      bitblt(handle, 0, hoch - schattenunten.height + rand, img.width, 
        hoch + rand, schattenunten.canvas.handle, 0, 0, SRCAND); 
    end; 
  end; 
  application.processmessages; 
  if stopp or application.terminated 
    then begin 
    Timer1.enabled := false; 
    exit; 
  end; 
  inc(step, 1 + ord(not rollen) * hoch); 
  if step >= hoch 
    then begin 
    Timer1.enabled := false; 
    step := 0; 
    inc(welches, 1 + ord((welches = 0) and not rollen)); 
    if loop and (welches > schrift.count) then welches := 1; 
    if pause < 0 then 
      stopp := true; 
    zeit := gettickcount + dword(pause); 
    repeat 
      application.processmessages; 
      if stopp or application.terminated 
        then begin 
        Timer1.enabled := false; 
        exit; 
      end; 
    until gettickcount >= zeit; 
    if welches <= schrift.count then 
      Timer1.enabled := true 
    else durch := true; 
  end; 
end; 
 
// Starten 
 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
  if schrift.count = 0 then schrift.add('-- Nix --'); 
  while length(FontC) < schrift.count do begin 
    setlength(FontC, length(FontC) + 1); 
    FontC[high(FontC)] := clwhite; 
  end; 
  HigC := clBlack; 
  pause := 1000; 
  img.left := 100; 
  img.top := 25; 
  mitSchatten := true; 
  stopp := false; 
  durch := false; 
  loop := false; 
  rollen := true; 
  geschw := 50; 
  build; 
  Timer1.enabled := true; 
  img.visible := true; 
end; 
 
// Anhalten / weiterlaufen lassen 
 
procedure TForm1.Button2Click(Sender: TObject); 
begin 
  if stopp and not durch then begin 
    stopp := false; 
    Timer1.enabled := true; 
  end else 
    stopp := true; 
end; 
 
// Grundstellung 
 
procedure TForm1.Button3Click(Sender: TObject); 
begin 
  Timer1.enabled := false; 
  stopp := true; 
  durch := true; 
  with img.canvas do fillrect(cliprect); 
  // und bei Bedarf: 
  // img.visible := false; 
end;