DBR Delphi-Ecke

// Mit diesem Code wird eine sich füllende Outline-Schrift erzeugt.
// Beim ersten Klick auf den Button wird gefüllt, mit dem zweiten Klick
// wird geleert.

// Getestet mit D2010 unter Win7

// Variante 1 (simpel)

type 
  TForm1 = class(TForm) 
    Button1: TButton; 
    procedure FormCreate(Sender: TObject); 
    procedure FormDestroy(Sender: TObject); 
    procedure FormPaint(Sender: TObject); 
    procedure Button1Click(Sender: TObject); 
  private 
    { Private-Deklarationen } 
  public 
    { Public-Deklarationen } 
    procedure Full; 
    procedure Empty; 
    procedure OutLineText(cnv: TCanvas; XX, YY, Fontsize: Integer; 
      Txt, Fontname: String; Pen, Brush: TColor); 
  end; 
 
var 
  Form1: TForm1; 
 
implementation 
 
{$R *.dfm} 
 
const 
  Txt = 'Das ist ein Test'; 
  Rest = 90; 
 
var 
  Blanc: Boolean = True; 
  B1, B2, Hlp: TBitmap; 
  X, Y: Integer; 
  Tm: Cardinal; 
  Rct: TRect; 
 
procedure TForm1.OutLineText(cnv: TCanvas; XX, YY, Fontsize: Integer; 
  Txt, Fontname: string; Pen, Brush: TColor); 
var 
  F, H: Integer; 
begin 
  cnv.Pen.color := Pen; 
  cnv.Brush.color := Brush; 
  H := cnv.Handle; 
  F := CreateFont(-muldiv(Fontsize, getdevicecaps(H, logpixelsy), 72), 0, 0, 0, 
    FW_HEAVY, 0, 0, 0, DEFAULT_CHARSET, OUT_TT_PRECIS, $10, DEFAULT_QUALITY, 
    DEFAULT_PITCH, Pchar(Fontname)); 
  setBkMode(H, Transparent); 
  selectobject(H, F); 
  BeginPath(H); 
  Textout(H, XX, YY, Pchar(Txt), length(Txt)); 
  EndPath(H); 
  StrokeandfillPath(H); 
  Deleteobject(F); 
end; 
 
procedure TForm1.FormCreate(Sender: TObject); 
var 
  Sz: TSize; 
  Back, Pen, Brush1, Brush2: TColor; 
begin 
  Pen := clBlack; 
  Brush1 := clWhite; 
  Brush2 := RGB(0, 204, 255); 
  Back := clYellow; // muss sich von Pen, Brush1 und Brush2 unterscheiden 
  B1 := TBitmap.Create; 
  B2 := TBitmap.Create; 
  Hlp := TBitmap.Create; 
  with B1 do 
  begin 
    Canvas.Brush.color := Back; 
    Canvas.Font.Name := 'Arial'; 
    Canvas.Font.Size := 26; 
    Canvas.Font.Style := [fsBold]; 
    Sz := Canvas.Textextent(Txt); 
    Width := Sz.cx + 2; 
    Height := Sz.cy + 2; 
    OutLineText(Canvas, 0, 0, Canvas.Font.Size, Txt, Canvas.Font.Name, Pen, 
      Brush1); 
    Transparent := True; 
  end; 
  with B2 do 
  begin 
    Canvas.Brush.color := Back; 
    Width := B1.Width; 
    Height := B1.Height; 
    OutLineText(Canvas, 0, 0, B1.Canvas.Font.Size, Txt, B1.Canvas.Font.Name, 
      Pen, Brush2); 
    Transparent := True; 
  end; 
  Hlp.Assign(B1); 
  X := 10; 
  Y := 20; 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
begin 
  Hlp.Free; 
  B2.Free; 
  B1.Free; 
end; 
 
procedure TForm1.FormPaint(Sender: TObject); 
begin 
  Canvas.Draw(X, Y, Hlp); 
end; 
 
procedure TForm1.Full; 
var 
  I: Integer; 
begin 
  for I := Hlp.Height - 3 downto 0 do 
  begin 
    Rct := Rect(0, I, B1.Width, I - 1); 
    Hlp.Canvas.CopyRect(Rct, B2.Canvas, Rct); 
    Canvas.Draw(X, Y, Hlp); 
    Tm := GetTickCount + Rest; 
    repeat 
      Application.ProcessMessages; 
    until (GetTickCount > Tm) or Application.Terminated;  
  end; 
  Blanc := False; 
end; 
 
procedure TForm1.Empty; 
var 
  I: Integer; 
begin 
  for I := 0 to Hlp.Height - 3 do 
  begin 
    Rct := Rect(0, I, B1.Width, I + 1); 
    Hlp.Canvas.CopyRect(Rct, B1.Canvas, Rct); 
    Canvas.Draw(X, Y, Hlp); 
    Tm := GetTickCount + Rest; 
    repeat 
      Application.ProcessMessages; 
    until (GetTickCount > Tm) or Application.Terminated; 
  end; 
  Blanc := True; 
end; 
 
 
// Beispiel 
 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
  Button1.Enabled := False; 
  if Blanc then 
    Full 
  else 
    Empty; 
  Button1.Enabled := True; 
end;

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

// Variante 2

// Wer bereit ist für diesen kleinen Effekt einen größeren Aufwand zu
// betreiben, der kann mit dem folgenden Code die Schrift vertikal und
// horizontal füllen bzw. leeren lassen, wobei sich auch die Richtung
// bestimmen lässt(oben nach unten, unten nach oben, rechts nach links,
// links nach rechts). Außerdem kann auch die Umrissfarbe verändert
// werden.

type 
  TForm1 = class(TForm) 
    Button1: TButton; 
    Button2: TButton; 
    procedure FormCreate(Sender: TObject); 
    procedure FormDestroy(Sender: TObject); 
    procedure FormPaint(Sender: TObject); 
    procedure Button1Click(Sender: TObject); 
    procedure Button2Click(Sender: TObject); 
  private 
    { Private-Deklarationen } 
  public 
    { Public-Deklarationen } 
    procedure Full(Horz, Direction: Boolean); 
    procedure Empty(Horz, Direction: Boolean); 
    procedure Test; 
    function pause(T: Integer): cardinal; 
    function Present(I: Integer): Boolean; 
    procedure FromLeft(B: TBitmap; H: Integer); 
    procedure FromRight(B: TBitmap; H: Integer); 
    procedure FromBottom(B: TBitmap; H: Integer); 
    procedure FromTop(B: TBitmap; H: Integer); 
    procedure OutLineText(cnv: TCanvas; XX, YY, Fontsize: Integer; 
      Txt, Fontname: String; Pen, Brush: TColor); 
  end; 
 
var 
  Form1: TForm1; 
 
implementation 
 
{$R *.dfm} 
 
const 
  Txt = 'Versuch'; 
  BottomToTop = True; 
  TopToBottom = False; 
  LeftToRight = True; 
  RightToLeft = False; 
  Vertical = True; 
  Horizontal = False; 
 
var 
  Back, Pen1, Pen2, Brush1, Brush2: TColor; 
  X, Y, SpaceT, SpaceB: Integer; 
  r, g, B, rf, gf, bf: Byte; 
  Blanc: Boolean = True; 
  B1, B2, Hlp: TBitmap; 
  Tm, Rest: cardinal; 
  Rct: TRect; 
  Sz: TSize; 
 
procedure TForm1.OutLineText(cnv: TCanvas; XX, YY, Fontsize: Integer; 
  Txt, Fontname: string; Pen, Brush: TColor); 
var 
  F, H: Integer; 
begin 
  cnv.Pen.color := Pen; 
  cnv.Brush.color := Brush; 
  H := cnv.Handle; 
  F := CreateFont(-muldiv(Fontsize, getdevicecaps(H, logpixelsy), 72), 0, 0, 0, 
    FW_HEAVY, 0, 0, 0, DEFAULT_CHARSET, OUT_TT_PRECIS, $10, DEFAULT_QUALITY, 
    DEFAULT_PITCH, Pchar(Fontname)); 
  setBkMode(H, Transparent); 
  selectobject(H, F); 
  BeginPath(H); 
  textout(H, XX, YY, Pchar(Txt), length(Txt)); 
  EndPath(H); 
  strokeandfillPath(H); 
  deleteobject(F); 
end; 
 
procedure TForm1.Test; 
var 
  I, J, B3: Integer; 
  P: PByteArray; 
  F: Boolean; 
begin 
  B3 := B1.Width * 3; 
  F := False; 
  for J := 0 to B1.Height - 1 do 
  begin 
    I := 0; 
    P := B1.ScanLine[J]; 
    while I < B3 do 
    begin 
      F := (P[I] <> B) or (P[I + 1] <> g) or (P[I + 2] <> r); 
      if F then 
      begin 
        SpaceT := J; 
        break; 
      end; 
      inc(I, 3); 
    end; 
    if F then 
      break; 
  end; 
  F := False; 
  for J := B1.Height - 1 downto 0 do 
  begin 
    I := 0; 
    P := B1.ScanLine[J]; 
    while I < B3 do 
    begin 
      F := (P[I] <> B) or (P[I + 1] <> g) or (P[I + 2] <> r); 
      if F then 
      begin 
        SpaceB := B1.Height - J - 2; 
        break; 
      end; 
      inc(I, 3); 
    end; 
    if F then 
      break; 
  end; 
end; 
 
function TForm1.pause(T: Integer): cardinal; 
var 
  I: Integer; 
begin 
  I := 666 div B1.Canvas.Font.Size; // z.B. 
  if I < 1 then 
    I := 1; 
  Result := I div T; 
end; 
 
function TForm1.Present(I: Integer): Boolean; 
var 
  J: Integer; 
  P: PByteArray; 
begin 
  Result := False; 
  for J := SpaceT to B1.Height - SpaceB do 
  begin 
    P := B1.ScanLine[J]; 
    Result := (P[I] = bf) and (P[I + 1] = gf) and (P[I + 2] = rf); 
    if Result then 
      break; 
  end; 
end; 
 
procedure TForm1.FormCreate(Sender: TObject); 
var 
  I, Lg: Integer; 
begin 
  Pen1 := clBlack; 
  Pen2 := clRed; 
  Brush1 := clWhite; 
  Brush2 := $99DDFF; 
  Back := clYellow; // muss sich von Pens und Brushes unterscheiden 
  r := GetRValue(Back); 
  g := GetGValue(Back); 
  B := GetBValue(Back); 
  rf := GetRValue(Pen1); 
  gf := GetGValue(Pen1); 
  bf := GetBValue(Pen1); 
  Lg := length(Txt); 
  SpaceT := 0; 
  SpaceB := 0; 
  B1 := TBitmap.Create; 
  B1.PixelFormat := pf24bit; 
  B2 := TBitmap.Create; 
  Hlp := TBitmap.Create; 
  with B1 do 
  begin 
    Canvas.Brush.color := Back; 
    Canvas.Font.Name := 'Arial'; 
    Canvas.Font.Size := 28; 
    Canvas.Font.Style := [fsBold]; 
    Sz := Canvas.Textextent(Txt); 
    Width := Sz.cx + 3; 
    Height := Sz.cy + 2; 
    OutLineText(Canvas, 0, 0, Canvas.Font.Size, Txt, Canvas.Font.Name, Pen1, 
      Brush1); 
    Transparent := True; 
    for I := 1 to Lg do 
    end; 
    Test; 
    with B2 do 
    begin 
      Canvas.Brush.color := Back; 
      Width := B1.Width; 
      Height := B1.Height; 
      OutLineText(Canvas, 0, 0, B1.Canvas.Font.Size, Txt, B1.Canvas.Font.Name, 
        Pen2, Brush2); 
      Transparent := True; 
    end; 
    Hlp.Assign(B1); 
    X := 10; 
    Y := 20; 
  end; 
 
  procedure TForm1.FormDestroy(Sender: TObject); 
  begin 
    Hlp.Free; 
    B2.Free; 
    B1.Free; 
  end; 
 
  procedure TForm1.FormPaint(Sender: TObject); 
  begin 
    Canvas.Draw(X, Y, Hlp); 
  end; 
 
  procedure TForm1.FromRight(B: TBitmap; H: Integer); 
  var 
    I: Integer; 
    F: Boolean; 
  begin 
    F := False; 
    Rest := pause(20); 
    for I := B1.Width - 1 downto 1 do 
    begin 
      if F then 
        break; 
      if not Present((I - 1) * 3) then 
        Continue; 
      Rct := Rect(I, SpaceT, I - 1, H); 
      Hlp.Canvas.CopyRect(Rct, B.Canvas, Rct); 
      Canvas.Draw(X, Y, Hlp); 
      Tm := GetTickCount + Rest; 
      repeat 
        F := Application.Terminated; 
        Application.ProcessMessages; 
      until (GetTickCount > Tm) or F; 
    end; 
  end; 
 
  procedure TForm1.FromLeft(B: TBitmap; H: Integer); 
  var 
    I: Integer; 
    F: Boolean; 
  begin 
    F := False; 
    Rest := pause(20); 
    for I := 1 to B1.Width - 1 do 
    begin 
      if F then 
        break; 
      if not Present(I * 3) then 
        Continue; 
      Rct := Rect(I, SpaceT, I + 1, H); 
      Hlp.Canvas.CopyRect(Rct, B.Canvas, Rct); 
      Canvas.Draw(X, Y, Hlp); 
      Tm := GetTickCount + Rest; 
      repeat 
        F := Application.Terminated; 
        Application.ProcessMessages; 
      until (GetTickCount > Tm) or F; 
    end; 
  end; 
 
  procedure TForm1.FromBottom(B: TBitmap; H: Integer); 
  var 
    I: Integer; 
    F: Boolean; 
  begin 
    F := False; 
    Rest := pause(1) + 20; 
    for I := H downto SpaceT do 
    begin 
      if F then 
        break; 
      Rct := Rect(0, I, B1.Width, I - 1); 
      Hlp.Canvas.CopyRect(Rct, B.Canvas, Rct); 
      Canvas.Draw(X, Y, Hlp); 
      Tm := GetTickCount + Rest; 
      repeat 
        F := Application.Terminated or (I = SpaceT); 
        Application.ProcessMessages; 
      until (GetTickCount > Tm) or F; 
    end; 
  end; 
 
  procedure TForm1.FromTop(B: TBitmap; H: Integer); 
  var 
    I: Integer; 
    F: Boolean; 
  begin 
    F := False; 
    Rest := pause(1) + 20; 
    for I := SpaceT to H do 
    begin 
      if F then 
        break; 
      Rct := Rect(0, I, B1.Width, I + 1); 
      Hlp.Canvas.CopyRect(Rct, B.Canvas, Rct); 
      Canvas.Draw(X, Y, Hlp); 
      Tm := GetTickCount + Rest; 
      repeat 
        F := Application.Terminated or (I = H); 
        Application.ProcessMessages; 
      until (GetTickCount > Tm) or F; 
    end; 
  end; 
 
  procedure TForm1.Full(Horz, Direction: Boolean); 
  var 
    H: Integer; 
  begin 
    H := B1.Height - SpaceB; 
    if not Horz then 
    begin 
      if Direction then 
        FromBottom(B2, H) 
      else 
        FromTop(B2, H); 
    end 
    else 
    begin 
      if Direction then 
        FromLeft(B2, H) 
      else 
        FromRight(B2, H); 
    end; 
    Blanc := False; 
  end; 
 
  procedure TForm1.Empty(Horz, Direction: Boolean); 
  var 
    H: Integer; 
  begin 
    H := B1.Height - SpaceB; 
    if not Horz then 
    begin 
      if Direction then 
        FromBottom(B1, H) 
      else 
        FromTop(B1, H); 
    end 
    else 
    begin 
      if Direction then 
        FromLeft(B1, H) 
      else 
        FromRight(B1, H) 
    end; 
    Blanc := True; 
  end; 
 
 
  // Beispiele 
  procedure TForm1.Button1Click(Sender: TObject); 
  begin 
    Button1.Enabled := False; 
    Button2.Enabled := False; 
    if Blanc then 
      Full(Horizontal, BottomToTop) 
    else 
      Empty(Horizontal, TopToBottom); 
    Button1.Enabled := True; 
    Button2.Enabled := True; 
  end; 
 
  procedure TForm1.Button2Click(Sender: TObject); 
  begin 
    Button1.Enabled := False; 
    Button2.Enabled := False; 
    if Blanc then 
      Full(Vertical, LeftToRight) 
    else 
      Empty(Vertical, LeftToRight); 
    Button1.Enabled := True; 
    Button2.Enabled := True; 
  end;