DBR Delphi-Ecke

// Mit dem folgenden Code kann man Bitmaps verbiegen. Soll heißen, man kann
// Bitmaps an eine bestimmte Schablonenform anpassen. Als Schablone dient
// eine schwarz/weiß Vektorgrafik in einem Metafile (*.wmf oder *.emf), damit
// scharfe Konturen bei den verschiedensten Größen gewährleistet sind. Die
// Schablone sollte möglichst fließende Umrisse besitzen und keine spitzen
// Ecken, Durchbrüche oder senkrechte Einbrüche haben, um abgehackte
// Übergänge oder Dopplungen zu vermeiden.

richtig	falsch

(siehe aber weiter unten "Erweiterung")

// Die Schablone wird zunächst mittels "PlayEnhMetaFile" an die Bitmapgröße
// angepasst, kann aber über Regler (TTrackbar) verändert werden.


Source (bmp)	Schablone (wmf)	Dest (bmp)
(Originalgrößen)

// Getestet mit D4 unter XP

unit Unit2; 
 
interface 
 
uses 
  Windows, SysUtils, Classes, Graphics, Controls, Forms, 
  StdCtrls, Buttons, ComCtrls; 
 
type 
  TForm1 = class(TForm) 
    Button1: TButton; 
    Trackbar1: TTrackbar; 
    Trackbar2: TTrackbar; 
    Trackbar3: TTrackbar; 
    procedure FormPaint(Sender: TObject); 
    procedure FormCreate(Sender: TObject); 
    procedure FormDestroy(Sender: TObject); 
    procedure Button1Click(Sender: TObject); 
    procedure TrackBar1Change(Sender: TObject); 
  private 
    w, h, lks, o, b3: integer; 
    Dest, Source: TBitmap; 
    ps, pd: PBytearray; 
    sperre: boolean; 
    wmf: TMetafile; 
    Farbe: TColor; 
    r, g, b: byte; 
    f: single; 
  public 
    procedure go; 
    procedure Grundstellung; 
    procedure wmfladen(s: string); 
    procedure doit(bm: TBitmap; mf: TMetafile; waag, senk, ob: integer); 
  end; 
 
var 
  Form1: TForm1; 
 
implementation 
 
{$R *.DFM} 
 
procedure TForm1.doit(bm: TBitmap; mf: TMetafile; waag, senk, ob: integer); 
var 
  hlp: TBitmap; 
  x, y, links, breit, br, ho, lin, obn: integer; 
begin 
  SetStretchBltMode(bm.canvas.handle, STRETCH_HALFTONE); 
  hlp := TBitmap.create; 
  hlp.pixelformat := pf24bit; 
  hlp.width := bm.width; 
  hlp.height := bm.height; 
  lin := lks + waag; 
  obn := o + senk + ob; 
  br := w - waag; 
  ho := h - senk + ob; 
  PlayEnhMetaFile(hlp.canvas.handle, mf.handle, 
    rect(lin, obn, lks + br, o + ho)); 
  for y := 0 to bm.height - 1 do begin 
    x := 0; 
    pd := bm.scanline[y]; 
    ps := hlp.scanline[y]; 
    while x < b3 do begin 
      if ps[x] = 255 then begin 
        pd[x] := b; 
        pd[x + 1] := g; 
        pd[x + 2] := r; 
      end else begin 
        links := x div 3; 
        while (ps[x] <> 255) and (x < b3) do inc(x, 3); 
        breit := x div 3; 
        bm.canvas.copyrect(rect(links, y, breit, y + 1), 
          source.canvas, rect(0, y, bm.width, y + 1)); 
        continue; 
      end; 
      inc(x, 3); 
    end; 
  end; 
  hlp.free; 
end; 
 
procedure TForm1.go; 
begin 
  if not sperre then begin 
    doit(Dest, wmf, Trackbar1.position, 
      Trackbar2.position, Trackbar3.position); 
    canvas.draw(10, 10, Dest); 
  end; 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
begin 
  source.free; 
  Dest.free; 
  wmf.free; 
end; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  sperre := true; 
  farbe := colortorgb(clbtnface); 
  r := getrvalue(farbe); 
  g := getgvalue(farbe); 
  b := getbvalue(farbe); 
  wmf := TMetafile.Create; 
  source := TBitmap.create; 
  source.loadfromfile('c:\villa.bmp'); 
  wmfladen('c:\schablone.wmf'); 
  Dest := TBitmap.create; 
  Dest.pixelformat := pf24bit; 
  Dest.width := source.width; 
  Dest.height := source.height; 
  b3 := Dest.width * 3; 
  Trackbar2.OnChange := TrackBar1Change; 
  Trackbar3.OnChange := TrackBar1Change; 
  Grundstellung; 
end; 
 
procedure TForm1.wmfladen(s: string); 
begin 
  wmf.loadfromfile(s); 
  f := wmf.height / wmf.width; 
  if f > source.height / source.width then begin 
    h := source.height; 
    w := trunc(h / f); 
  end else begin 
    w := source.width; 
    h := trunc(w * f); 
  end; 
  lks := (source.width - w) div 2; 
  o := (source.height - h) div 2; 
  Trackbar1.min := -lks; 
  Trackbar1.max := w div 2 - 3; 
  Trackbar2.min := -o; 
  Trackbar2.max := h div 2 - 3; 
  Trackbar3.max := source.height div 2; 
  Trackbar3.min := -Trackbar3.max; 
  Trackbar1.frequency := (abs(Trackbar1.min) + Trackbar1.max) div 25; 
  Trackbar2.frequency := (abs(Trackbar2.min) + Trackbar2.max) div 25; 
  Trackbar3.frequency := (abs(Trackbar3.min) + Trackbar3.max) div 25; 
end; 
 
procedure TForm1.Grundstellung; 
begin 
  Trackbar1.position := 0; 
  Trackbar2.position := 0; 
  Trackbar3.position := 0; 
  sperre := false; 
end; 
 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
  sperre := true; 
  Grundstellung; 
  go; 
end; 
 
procedure TForm1.TrackBar1Change(Sender: TObject); 
begin 
  go; 
end; 
 
procedure TForm1.FormPaint(Sender: TObject); 
begin 
  go; 
end; 
 
end.

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

// Erweiterung:

// Falls man nach obigem Code doch spitzwinklige Schablonen einsetzt, kommt
// es zu abgehackten Übergängen wie hier im Bild mittels Pfeilen
// gekennzeichnet ist:

// In so einem Fall sollte man mit einer zweiten Schablone arbeiten, welche
// die erste Schablone fließend umfasst:


baum (wmf)	baumhlp (wmf)	Silhouetten- vergleich
(Originalgrößen)			Dest(bmp)

// Und hier der etwas geänderte Code dafür:

type 
  TForm1 = class(TForm) 
    Button1: TButton; 
    Trackbar1: TTrackbar; 
    Trackbar2: TTrackbar; 
    Trackbar3: TTrackbar; 
    procedure FormPaint(Sender: TObject); 
    procedure FormCreate(Sender: TObject); 
    procedure FormDestroy(Sender: TObject); 
    procedure Button1Click(Sender: TObject); 
    procedure TrackBar1Change(Sender: TObject); 
  private 
    w, h, lks, o, b3, rand: integer; 
    Dest, Source: TBitmap; 
    wmf, hwmf: TMetafile; 
    ps, pd: PBytearray; 
    sperre: boolean; 
    Farbe: TColor; 
    r, g, b: byte; 
    f: single; 
  public 
    procedure go; 
    procedure Grundstellung; 
    procedure wmfladen(s: string); 
    procedure doit(bm: TBitmap; mf, hmf: TMetafile; waag, senk, ob: integer); 
  end; 
 
var 
  Form1: TForm1; 
 
implementation 
 
{$R *.DFM} 
 
procedure TForm1.doit(bm: TBitmap; mf, hmf: TMetafile; waag, senk, ob: 
  integer); 
var 
  hlp, hhlp: TBitmap; 
  x, y, links, rechts, br, ho, lin, obn: integer; 
begin 
  SetStretchBltMode(bm.canvas.handle, STRETCH_HALFTONE); 
  hlp := TBitmap.create; 
  hlp.pixelformat := pf24bit; 
  hlp.width := bm.width; 
  hlp.height := bm.height; 
  hhlp := TBitmap.create; 
  hhlp.pixelformat := pf24bit; 
  hhlp.width := bm.width; 
  hhlp.height := bm.height; 
  lin := lks + waag; 
  obn := o + senk + ob; 
  br := w - waag; 
  ho := h - senk + ob; 
  PlayEnhMetaFile(hlp.canvas.handle, mf.handle, 
    rect(lin + rand, obn + rand, lks + br - rand, o + ho - rand)); 
  PlayEnhMetaFile(hhlp.canvas.handle, hmf.handle, 
    rect(lin, obn, lks + br, o + ho)); 
  for y := 0 to bm.height - 1 do begin 
    x := 0; 
    pd := bm.scanline[y]; 
    ps := hhlp.scanline[y]; 
    while (x < b3) and (ps[x] = 255) do inc(x, 3); 
    links := x div 3; 
    while (ps[x] <> 255) and (x < b3) do inc(x, 3); 
    rechts := x div 3; 
    if rechts > links then 
      bm.canvas.copyrect(rect(links, y, rechts, y + 1), 
        source.canvas, rect(0, y, bm.width, y + 1)); 
    ps := hlp.scanline[y]; 
    x := 0; 
    while x < b3 do begin 
      if ps[x] = 255 then begin 
        pd[x] := b; 
        pd[x + 1] := g; 
        pd[x + 2] := r; 
      end; 
      inc(x, 3); 
    end; 
  end; 
  hlp.free; 
  hhlp.free; 
end; 
 
procedure TForm1.go; 
begin 
  if not sperre then begin 
    doit(Dest, wmf, hwmf, Trackbar1.position, 
      Trackbar2.position, Trackbar3.position); 
    canvas.draw(10, 10, Dest); 
  end; 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
begin 
  source.free; 
  Dest.free; 
  wmf.free; 
  hwmf.free; 
end; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  sperre := true; 
  rand := 5; 
  farbe := colortorgb(clbtnface); 
  r := getrvalue(farbe); 
  g := getgvalue(farbe); 
  b := getbvalue(farbe); 
  wmf := TMetafile.Create; 
  hwmf := TMetafile.Create; 
  source := TBitmap.create; 
  source.loadfromfile('c:\villa.bmp'); 
  wmfladen('c:\baum.wmf'); 
  hwmf.loadfromfile('c:\baumhlp.wmf'); 
  Dest := TBitmap.create; 
  Dest.pixelformat := pf24bit; 
  Dest.width := source.width; 
  Dest.height := source.height; 
  b3 := Dest.width * 3; 
  Trackbar2.OnChange := TrackBar1Change; 
  Trackbar3.OnChange := TrackBar1Change; 
  Grundstellung; 
end; 
 
procedure TForm1.wmfladen(s: string); 
begin 
  wmf.loadfromfile(s); 
  f := wmf.height / wmf.width; 
  if f > source.height / source.width then begin 
    h := source.height; 
    w := trunc(h / f); 
  end else begin 
    w := source.width; 
    h := trunc(w * f); 
  end; 
  lks := (source.width - w) div 2; 
  o := (source.height - h) div 2; 
  Trackbar1.min := -lks; 
  Trackbar1.max := w div 2 - 3 - rand; 
  Trackbar2.min := -o; 
  Trackbar2.max := h div 2 - 3 - rand; 
  Trackbar3.max := source.height div 2; 
  Trackbar3.min := -Trackbar3.max; 
  Trackbar1.frequency := (abs(Trackbar1.min) + Trackbar1.max) div 25; 
  Trackbar2.frequency := (abs(Trackbar2.min) + Trackbar2.max) div 25; 
  Trackbar3.frequency := (abs(Trackbar3.min) + Trackbar3.max) div 25; 
end; 
 
procedure TForm1.Grundstellung; 
begin 
  Trackbar1.position := 0; 
  Trackbar2.position := 0; 
  Trackbar3.position := 0; 
  sperre := false; 
end; 
 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
  sperre := true; 
  Grundstellung; 
  go; 
end; 
 
procedure TForm1.TrackBar1Change(Sender: TObject); 
begin 
  go; 
end; 
 
procedure TForm1.FormPaint(Sender: TObject); 
begin 
  go; 
end;

// Ein weiteres Beispiel für diesen Code:

// Eine Schablone mit mehreren Durchbrüchen (z.B. Schrift) macht keinen
// Sinn, da dann kaum noch etwas von der Verkrümmung zu sehen ist.
// Sie aber: Text mit Bitmap-Füllung ausgeben