Schrift auf Bitmap glätten

galagher · Verfasst: Mo 23.08.04 18:42

Hallo!

Kann mir bitte jemand einen Tip geben, wie man Schrift auf einem Bitmap glättet? Sieht nicht so besonders aus, wenn man bei schrägen Linien "Stufen" sieht! Leider finde ich beim googeln nichts wirklich dazu. Danke!

_________________
gedunstig war's - und fahle wornen zerschellten karsig im gestrock. oh graus, es gloomt der jabberwock - und die graisligen gulpen nurmen!

sibbe · Beiträge: 50 WIN XP Prof D7 Prof

Hi!
Guck mal hier, vielleicht hilft dir das weiter.

sibbe

galagher · Verfasst: Fr 27.08.04 22:27

sibbe hat folgendes geschrieben:

Hi!
Guck mal hier, vielleicht hilft dir das weiter.

Danke, das ist schon mal was, macht aber leider das ganze Bild unscharf. Habe ein wenig experimentiert, aber nichts Brauchbares erreicht:
ZB. könnte man den Text zuerst auf die Canvas eines separaten Image's kopieren, dort Antialiasing durchführen und die Canvas dann auf die Canvas des ursprgl. Image's kopieren. Das hat aber den unerwünschten (wenn auch interessanten!) Effekt, dass um den Text herum ein weisser Rand entsteht, und zwar auch dann, wenn "Transparent" eingestellt ist. Also hab' ich's wieder verworfen.

Wie erreiche ich, dass nur die Schrift verbessert wird?

_________________
gedunstig war's - und fahle wornen zerschellten karsig im gestrock. oh graus, es gloomt der jabberwock - und die graisligen gulpen nurmen!

Keldorn · Verfasst: Fr 27.08.04 22:49

Du müßtest den code so anpassen, das er die benachbarten Pixel, die fürs Antialiasing herangezogen werden, von deinem Hintergrundbild genommen werden.

Aber andere Frage: welche Schriftart nimmst du?

Mfg Frank

_________________
Lükes Grundlage der Programmierung: Es wird nicht funktionieren.
(Murphy)

sibbe · Beiträge: 50 WIN XP Prof D7 Prof

so jungs (und mädels ?), das hier müsste eigentlich klappen:
(Code by Earl F. Glynn, Mike Lischke, Nacho Urenda und n bissl von mir

)

markieren

Delphi-Quelltext

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:

procedure CenterText(const Canvas: TCanvas; const Rect: TRect; const s: string);
var
  X,Y: integer;
begin
  X := (Rect.Left + Rect.Right - Canvas.TextWidth(s)) div 2;
  Y := (Rect.Top + Rect.Bottom - Canvas.TextHeight(s)) div 2;
  Canvas.TextRect(Rect,X,Y,s);
end;

procedure SampleBitmap(Ht,Wd: cardinal; FontName, ChrStr: string;  
                              FontColor, BGColor: TColor; var big_bmp: TBitmap);
var
  Rect: TRect;
begin
  with big_bmp do
    begin
      Width  := Wd*3;
      Height := Ht*3;
      PixelFormat := pf24Bit;

      with Canvas do
        begin
          Brush.Color := BGColor;
          FillRect(big_bmp.Canvas.ClipRect);
          Font.Name := FontName;
          Font.Height := big_bmp.Height;
          Font.Color := FontColor;
        end;

      Rect := Canvas.ClipRect;

ExtTextOutW(Canvas.Handle,0,0,ETO_CLIPPED, @Rect,pWideChar(ChrStr),Length(ChrStr), NIL);
    end;
  CenterText(big_bmp.Canvas, Rect, ChrStr);
end;


procedure AntiAliasPicture(orig_bmp, big_bmp: TBitmap; var out_bmp: TBitmap);
const
  MaxPixelCount   =  32768;
type
  pRGBArray  =  ^TRGBArray;
  TRGBArray  =  array[0..MaxPixelCount-1] of TRGBTriple;
var
  x, y, cx, cy : integer;
  totr, totg, totb : integer;
  Row1, Row2, Row3, DestRow: pRGBArray;
  i: integer;
begin
  // For each row
  for y := 0 to orig_bmp.Height - 1 do
  begin
    // We compute samples of 3 x 3 pixels
    cy := y*3;
    // Get pointers to actual, previous and next rows in supersampled bitmap
    Row1 := big_bmp.ScanLine[cy];
    Row2 := big_bmp.ScanLine[cy+1];
    Row3 := big_bmp.ScanLine[cy+2];

    // Get a pointer to destination row in output bitmap
    DestRow := out_bmp.ScanLine[y];

    // For each column...
    for x := 0 to orig_bmp.Width - 1 do
    begin
      // We compute samples of 3 x 3 pixels
      cx := 3*x;

      // Initialize result color
      totr := 0;
      totg := 0;
      totb := 0;

      // For each pixel in sample
      for i := 0 to 2 do
      begin
        // New red value
        totr := totr + Row1[cx + i].rgbtRed
             + Row2[cx + i].rgbtRed
             + Row3[cx + i].rgbtRed;
        // New green value
        totg := totg + Row1[cx + i].rgbtGreen
             + Row2[cx + i].rgbtGreen
             + Row3[cx + i].rgbtGreen;
        // New blue value
        totb := totb + Row1[cx + i].rgbtBlue
             + Row2[cx + i].rgbtBlue
             + Row3[cx + i].rgbtBlue;
      end;

      // Set output pixel colors
      DestRow[x].rgbtRed := totr div 9;
      DestRow[x].rgbtGreen := totg div 9;
      DestRow[x].rgbtBlue := totb div 9;
    end;
  end;

end;


function CharacterToGraphic(Ht, Wd: cardinal; FontName, ChrStr: string; FontColor,
         BGColor: TColor; ColDepth: TPixelFormat; AntiAlias: boolean): TBitmap;
var
  bmp: TBitmap;
  Rect: TRect;
  out_bmp,big_bmp: TBitmap;
begin
  //Draw the font character as a bitmap image...
  bmp := TBitmap.Create;
  Result := TBitmap.Create;
   try
     with bmp do
       begin
         Width  := Wd;
         Height := Ht;
         PixelFormat := ColDepth;

         with Canvas do
           begin
             Brush.Color := BGColor;
             FillRect(bmp.Canvas.ClipRect);
             Font.Name := FontName;
             Font.Height := bmp.Height;
             Font.Color := FontColor;
           end;

         Rect := Canvas.ClipRect;

         ExtTextOutW(Canvas.Handle,0,0,ETO_CLIPPED, @Rect,pWideChar(ChrStr),Length(ChrStr), NIL);
       end;
     CenterText(bmp.Canvas, Rect, ChrStr);

     if AntiAlias then
        begin
          // To get accurate, antialiased rendering of the image,
          // draw it scaled at an enlarged size...
          big_bmp := TBitmap.Create;
          try
            SampleBitmap(Ht,Wd,FontName,ChrStr,FontColor,BGColor,big_bmp);

            // ...now reduce it to the desired output size, recalculating the
            // output pixel color. The output color is obtained as an average
            // of the red, green and blue values of each of the 9 pixels in
            // the enlarged image that correspond to a single pixel in the
            //output image
            out_bmp := TBitmap.Create;
            try
              with out_bmp do
                begin
                  Width := bmp.Width;
                  Height := bmp.Height;
                  PixelFormat := pf24bit;
                end;
              AntiAliasPicture(bmp,big_bmp,out_bmp);

              Result.Assign(out_bmp);
            finally
              out_bmp.Free;
            end;

          finally
            big_bmp.Free;
          end;

        end
        else
        begin
          Result.Assign(bmp);
        end;

   finally
     bmp.Free
   end;
end;

nach dem Aufruf von CharacterToGraphic muss man lediglich den Inhalt der Bitmap transparent auf das gewünschte image zeichnen. beispiel:

markieren

Delphi-Quelltext

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:

procedure TForm1.Button1Click(Sender: TObject);
var test : TBitmap;
begin
 Test := TBitmap.Create;
 Test.Assign(CharacterToGraphic(50,800,'Times New Roman','just testing',clwhite,
              clblack,pf32bit,true));
 Test.Transparent := True;
 Test.TransparentColor := clblack;

 image1.Canvas.Draw(0,0,test);

 Test.Free;
end;

der trick (oder das verbesserungswürdige, wie mans nimmt :wink:

) bei der sache ist die transparente (=BGColor) Farbe, die im besten fall gleich dem Hintergrund des Images ist (einfach ausprobieren :mrgreen:

)

sibbe

galagher · Verfasst: Sa 28.08.04 12:53

sibbe hat folgendes geschrieben:

so jungs (und mädels ?), das hier müsste eigentlich klappen:
(Code by Earl F. Glynn, Mike Lischke, Nacho Urenda und n bissl von mir

)

Klappt prinzipiell schon, aber der Text wird nicht exakt an die Stelle kopiert, wie angegeben und sieht aus, als wäre er teilweise schwarz umrandet, ausserdem klappt's nicht so ganz, wenn man die Schriftgrösse ändert. Trotzdem aber danke!

_________________
gedunstig war's - und fahle wornen zerschellten karsig im gestrock. oh graus, es gloomt der jabberwock - und die graisligen gulpen nurmen!

sibbe · Beiträge: 50 WIN XP Prof D7 Prof

Zitat:

Klappt prinzipiell schon, aber der Text wird nicht exakt an die Stelle kopiert, wie angegeben und sieht aus, als wäre er teilweise schwarz umrandet, ausserdem klappt's nicht so ganz, wenn man die Schriftgrösse ändert.

Nicht so schnell aufgeben! :wink:

Also: die position und größe des textes ergibt sich aus den variablen Ht und Wd. Ht ist die größe des Textes in pixeln, über font.size oda sowas kann man also nix erreichen. Wd ist die Länge der Ausgabebitmap, auf dieser länge wird der text zentriert (mittig) dargestellt (procedure CenterText), deswegen muss man manchmal n bissl rumexperimentieren.
Der schwarze Rand kommt davon, dass du als hintergrund und transparente farbe clblack nimmst, du kannst aber auch jede andere farbe nehmen, die umrandung wirst du aber wahrscheinlich nie ganz los werden. deswegen würd ich empfehlen ne function zu schreiben, die die farbe des hintergrundes ermittelt, wo der text letztendlich hinkommt. diese farbe benutzt du dann einfach als hintergrund- und trasparenzfarbe, dann fällt der rand nicht so stark auf.

noch was zu dem zentrierten text: dürfte eigentlich nicht so schwer sein, das auch linksbündig hinzukriegen, einfach mal den code anschauen :wink:

hoffe geholfen zu haben

sibbe

MartinPb · Beiträge: 698

Hier eine Experimentelle Prozedur von mir. Ich hab sie vor etwa eine Jahr geschrieben. Der Sinn sollte sein eine Grafik in eine andere einzufügen und die Seiten ein wenig anzugleichen. Dabei hab ich etliche Units geschrieben, die jede für sich Vor- und Nachteile hatte. Allerdings habe ich keine Lust mich mit allen wieder zu beschäftigen, so das ich einfach nur eine von vielen ausgesucht habe. Sie ist weder optimiert, noch die beste Variante. Ich hab einfach nur mal experimentiert.

Diese Prozedur ist seh einfach gehalten und gleicht nur ein Pixel nach links und nach rechts an. Schriften werden dagegen nach oben und nach unten geglättet, nie zu Seite. Allerdings werden auch die Nachbarpixel beachtet. Somit ist meine Prozedur schon mal falsch. Außerdem wird drei bis vier Pixel tief geglättet.

Das bedeutet aber nicht, daß die Prozedur dennoch zu nichts zu gebrauchen ist. Sie zeigt wie man es machen kann und ein Umschreiben ist ein Klaks. Die Prozedur durchläuft alle Pixel und bewertet sie. Findet es eine Grenze, dann bekommt die Flip Variable den Wert 3. In diesem Fall sollte man etwas machen.

Prinzip ist dieses. Bitmap1 ist die Unterlage. Bitmap2 ist die Grafik zum einfügen. Zu der Grafik muß die TransparentFarbe angegeben werden. Bitmap3 ist das Ergebnis.

Wenn du willst, dann kanns du damit weiter experimentieren und an deine Bedürfnisse anpassen.

markieren

Delphi-Quelltext

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:

procedure GetRGBColor(AColor: TColor; var R, G, B: Byte); // diese Funktion braucht man
var
  L: Longint;
  //R, G, B: Byte;
begin
  L := ColorToRGB(AColor);
  R := Byte(L);
  G := Byte(L shr 8);
  B := Byte(L shr 16);
end;

// EXPERIMENTELLE PROZEDUR
procedure FeatheringSWglatt(B1, B2, B3: TBitmap; TransparentColor: TColor);
// nur mit 24Bit Farbtiefe
type
  PixArray = Array [1..3] of Byte;  //PByteArray;
var
  p1, p2, p3: ^PixArray;
  X, Y: Integer;
  R, G, B: Byte;
  RT, GT, BT: Byte;
  Flip: Byte;
begin
  B1.PixelFormat := pf24Bit;  // 24Bit muß sein
  B2.PixelFormat := pf24Bit;
  B3.PixelFormat := pf24Bit;

  B2.Width := B1.Width;
  B2.Height := B1.Height;

  B3.Width := B1.Width;
  B3.Height := B1.Height;

  Flip := 0;

  GetRGBColor(TransparentColor, R, G, B); // holt die Farben für Transparent

  for Y := B3.Height - 1 downto 0 do
  begin  // Feathering
    p1 := B1.ScanLine[Y];
    p2 := B2.ScanLine[Y];
    p3 := B3.ScanLine[Y];

    for X := 0 to B3.Width - 1 do begin

      Flip := 2; // 2 weil sonst nur noch sw bleibt //Flip := 0;

      // Prüft ob transparente Farbe
      if (p2^[1] = B) and (p2^[2] = G) and (p2^[3] = R) then Flip := 1
        else
      begin
        Dec(p2); // Prüft ob Nachbar links transparente Farbe
        if (p2^[1] = B) and (p2^[2] = G) and (p2^[3] = R) then Flip := 3;
        Inc(p2);

        Inc(p2); // Prüft ob Nachbar rechts transparente Farbe
        if (p2^[1] = B) and (p2^[2] = G) and (p2^[3] = R) then Flip := 3;
        Dec(p2);
      end;

      case Flip of
        1: begin
             p3^[1] := p1^[1];
             p3^[2] := p1^[2];
             p3^[3] := p1^[3];
           end;
        2: begin
             p3^[1] := p2^[1];
             p3^[2] := p2^[2];
             p3^[3] := p2^[3];
           end;
        3: begin
             p3^[1] := Byte((p1^[1] div 2) + (p2^[1] div 2));
             p3^[2] := Byte((p1^[2] div 2) + (p2^[2] div 2));
             p3^[3] := Byte((p1^[3] div 2) + (p2^[3] div 2));     {}
           end;
      end;

      Inc(p1);
      Inc(p2);
      Inc(p3);
    end;
  end;
end;

_________________
Gruß
Martin

galagher · Verfasst: Sa 28.08.04 15:25

Keldorn hat folgendes geschrieben:

Aber andere Frage: welche Schriftart nimmst du?

Egal, welche Schrift, das "pixelige" Schriftbild ist immer. Aber mit Antaliasing kann man sich zumindest helfen!

_________________
gedunstig war's - und fahle wornen zerschellten karsig im gestrock. oh graus, es gloomt der jabberwock - und die graisligen gulpen nurmen!

galagher · Verfasst: Sa 28.08.04 16:01

MartinPb hat folgendes geschrieben:

Schriften werden dagegen nach oben und nach unten geglättet, nie zu Seite.

Ehrlich gesagt, verstehe ich deinen Code überhaupt nicht... Aber es funktioniert, danke! Das könnte genau das sein, was ich suche! Kannst du mir einen Tipp geben, wie man auch zur Seite glätten kann?

_________________
gedunstig war's - und fahle wornen zerschellten karsig im gestrock. oh graus, es gloomt der jabberwock - und die graisligen gulpen nurmen!

krzyk_91 · Hält's aus hier Beiträge: 8

MartinPb hat folgendes geschrieben :

Hier eine Experimentelle Prozedur von mir. Ich hab sie vor etwa eine Jahr geschrieben. Der Sinn sollte sein eine Grafik in eine andere einzufügen und die Seiten ein wenig anzugleichen. Dabei hab ich etliche Units geschrieben, die jede für sich Vor- und Nachteile hatte. Allerdings habe ich keine Lust mich mit allen wieder zu beschäftigen, so das ich einfach nur eine von vielen ausgesucht habe. Sie ist weder optimiert, noch die beste Variante. Ich hab einfach nur mal experimentiert.

Diese Prozedur ist seh einfach gehalten und gleicht nur ein Pixel nach links und nach rechts an. Schriften werden dagegen nach oben und nach unten geglättet, nie zu Seite. Allerdings werden auch die Nachbarpixel beachtet. Somit ist meine Prozedur schon mal falsch. Außerdem wird drei bis vier Pixel tief geglättet.

Das bedeutet aber nicht, daß die Prozedur dennoch zu nichts zu gebrauchen ist. Sie zeigt wie man es machen kann und ein Umschreiben ist ein Klaks. Die Prozedur durchläuft alle Pixel und bewertet sie. Findet es eine Grenze, dann bekommt die Flip Variable den Wert 3. In diesem Fall sollte man etwas machen.

Prinzip ist dieses. Bitmap1 ist die Unterlage. Bitmap2 ist die Grafik zum einfügen. Zu der Grafik muß die TransparentFarbe angegeben werden. Bitmap3 ist das Ergebnis.

Wenn du willst, dann kanns du damit weiter experimentieren und an deine Bedürfnisse anpassen.

markieren

Delphi-Quelltext

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:

procedure GetRGBColor(AColor: TColor; var R, G, B: Byte); // diese Funktion braucht man
var
  L: Longint;
  //R, G, B: Byte;
begin
  L := ColorToRGB(AColor);
  R := Byte(L);
  G := Byte(L shr 8);
  B := Byte(L shr 16);
end;

// EXPERIMENTELLE PROZEDUR
procedure FeatheringSWglatt(B1, B2, B3: TBitmap; TransparentColor: TColor);
// nur mit 24Bit Farbtiefe
type
  PixArray = Array [1..3] of Byte;  //PByteArray;
var
  p1, p2, p3: ^PixArray;
  X, Y: Integer;
  R, G, B: Byte;
  RT, GT, BT: Byte;
  Flip: Byte;
begin
  B1.PixelFormat := pf24Bit;  // 24Bit muß sein
  B2.PixelFormat := pf24Bit;
  B3.PixelFormat := pf24Bit;

  B2.Width := B1.Width;
  B2.Height := B1.Height;

  B3.Width := B1.Width;
  B3.Height := B1.Height;

  Flip := 0;

  GetRGBColor(TransparentColor, R, G, B); // holt die Farben für Transparent

  for Y := B3.Height - 1 downto 0 do
  begin  // Feathering
    p1 := B1.ScanLine[Y];
    p2 := B2.ScanLine[Y];
    p3 := B3.ScanLine[Y];

    for X := 0 to B3.Width - 1 do begin

      Flip := 2; // 2 weil sonst nur noch sw bleibt //Flip := 0;

      // Prüft ob transparente Farbe
      if (p2^[1] = B) and (p2^[2] = G) and (p2^[3] = R) then Flip := 1
        else
      begin
        Dec(p2); // Prüft ob Nachbar links transparente Farbe
        if (p2^[1] = B) and (p2^[2] = G) and (p2^[3] = R) then Flip := 3;
        Inc(p2);

        Inc(p2); // Prüft ob Nachbar rechts transparente Farbe
        if (p2^[1] = B) and (p2^[2] = G) and (p2^[3] = R) then Flip := 3;
        Dec(p2);
      end;

      case Flip of
        1: begin
             p3^[1] := p1^[1];
             p3^[2] := p1^[2];
             p3^[3] := p1^[3];
           end;
        2: begin
             p3^[1] := p2^[1];
             p3^[2] := p2^[2];
             p3^[3] := p2^[3];
           end;
        3: begin
             p3^[1] := Byte((p1^[1] div 2) + (p2^[1] div 2));
             p3^[2] := Byte((p1^[2] div 2) + (p2^[2] div 2));
             p3^[3] := Byte((p1^[3] div 2) + (p2^[3] div 2));     {}
           end;
      end;

      Inc(p1);
      Inc(p2);
      Inc(p3);
    end;
  end;
end;

Hallo zusmammen. ich möchte ein Programm schreiben, das Watermarks zu meinen Bildern mit Antianalising zugibt. Ich suche auch Hilfe dabei auf einem anderen Forum www.delphipraxis.net...nsparantem+text.html und jetzt habe ich dieses Thema gefunden. Ich möchte die Antianalising machen und dabei die Funktionen von sibbe benutzen. Könnte mir jemand helfen, wie ich mein Ziel erreichen kann. Ich wäre sehr dankbar für die Hilfe.

	Mitgliederliste
	Gruppen
	Das Team
	Richtlinien
	Synonyme