Bitmapgröße an Textgröße anpassen?

[Karstadt]

Delphi-Quellcode:

var
  Bild: TBitmap;
  i,i2: Integer;
  breite: Integer;
begin

  breite := 0;

  for i:= 0 to edt_text.Lines.Count-1 do
  begin
    If Length(edt_text.Lines.Strings[i]) > breite Then
    begin
      i2 := i;
      breite := Length(edt_text.Lines.Strings[i]);
    end;
  end;

  Bild := TBitmap.create;

  with Bild do
  begin
    Canvas.Font := edt_text.Font;
    Bild.Height := Canvas.TextHeight(edt_text.Text)*edt_text.Lines.Count;
    Bild.Width := Canvas.TextWidth(edt_text.Lines.Strings[i2]);
    transparentcolor := clWhite;
    transparent := true;
    for i:= 0 to edt_text.Lines.Count-1 do
    begin
     canvas.TextOut(0,Canvas.TextHeight(edt_text.Text)*i,edt_text.Lines.Strings[i]);
    end;
  end;

  Bild_img.Picture.Bitmap := Bild;

  Bild.Free;

Nun habe ich das

[Neutral General]

Ja die Funktion mit der du die Breite ausrechnest ist zwar nötig aber nicht gut genug eigentlich.. Weil z.B was passiert wenn im Memo z.B vier Punkte in der ersten Reihe sind und drei 'W's in der zweiten?

Du musst da auch mit Canvas.TextWidth arbeiten.. Ich habs so probiert:

Delphi-Quellcode:

function GetLongesLineLength(AMemo: TMemo): Integer;
var i,temp: Integer;
    tempBmp: TBitmap;
begin
  temp := 0;

  tempBmp := TBitmap.Create;
  tempBmp.Canvas.Font := AMemo.Font;

  for i:= 0 to AMemo.Lines.Count-1 do begin
   if tempBmp.Canvas.TextWidth(AMemo.Lines[i]) > temp then
    Temp := tempBmp.Canvas.TextWidth(AMemo.Lines[i]);
  end;
  TempBmp.Free;
  Result := Temp;
end;

So müsste es besser gehn

Das ganze sieht dann bei mir so aus:

Delphi-Quellcode:

procedure TForm1.Button1Click(Sender: TObject);
var B: TBitmap;
    i: Integer;
begin
  B := TBitmap.Create;
  with B do begin
   Canvas.Font := Memo1.Font;
   Height := Canvas.TextHeight(Memo1.Lines[0]) * Memo1.Lines.Count;
   Width := GetLongesLineLength(Memo1);
   for i:= 0 to Memo1.Lines.Count-1 do begin
    Canvas.TextOut(0,i*Canvas.TextHeight(Memo1.Lines[0]),Memo1.Lines[i]);
   end;
  end;
  Canvas.Draw(0,0,B);
  B.Free;
end;

Gruß
Neutral General

[Karstadt]

Zitat:

Ja die Funktion mit der du die Breite ausrechnest ist zwar nötig aber nicht gut genug eigentlich.. Weil z.B was passiert wenn im Memo z.B vier Punkte in der ersten Reihe sind und drei 'W's in der zweiten?

das kommt mit 99,99% wahrscheinlichkeit nicht vor...

[Karstadt]

ich nehme deine lösung.. dankeschön

[Karstadt]

würde das aucht mit RTF funktioineren?
Mit Tab Taste ....aber, das kommt später.

[Neutral General]

1. Ja aber mit der Textfarbe und so würde es dann halt komplizierter werden
2. Guck ma da oben rechts an deinem Beitrag ist ein Edit Button

[Hawkeye219]

Hallo Karstadt,

hier ist eine andere Lösung:

Delphi-Quellcode:

procedure GetTextImage (aText: string;  var aBitmap: TBitmap);
var
  R : TRect;
begin
  with aBitmap.Canvas do
    begin
      SetRect(R, 0, 0, MaxInt, MaxInt);
      DrawText(Handle, PChar(aText), Length(aText), R, DT_CALCRECT);
      aBitmap.Width := R.Right - R.Left;
      aBitmap.Height := R.Bottom - R.Top;
      OffsetRect(R, -R.Left, -R.Top);
      DrawText(Handle, PChar(aText), Length(aText), R, 0);
    end;
end;

Die Routine kannst du folgendermaßen nutzen:

Delphi-Quellcode:

procedure Form1.Button1Click (Sender: TObject);
var
  BMP : TBitmap;
begin
  BMP := TBitmap.Create;
  try
    BMP.Canvas.Font.Assign (RichEdit1.Font);
    GetTextImage (RichEdit1.Text, BMP);
    Self.Canvas.Draw (0, 0, BMP);
  finally
    BMP.Free;
  end;
end;

Gruß Hawkeye

[Karstadt]

Zitat von Hawkeye219:

Hallo Karstadt,

hier ist eine andere Lösung:

Delphi-Quellcode:

procedure GetTextImage (aText: string;  var aBitmap: TBitmap);
var
  R : TRect;
begin
  with aBitmap.Canvas do
    begin
      SetRect(R, 0, 0, MaxInt, MaxInt);
      DrawText(Handle, PChar(aText), Length(aText), R, DT_CALCRECT);
      aBitmap.Width := R.Right - R.Left;
      aBitmap.Height := R.Bottom - R.Top;
      OffsetRect(R, -R.Left, -R.Top);
      DrawText(Handle, PChar(aText), Length(aText), R, 0);
    end;
end;

Die Routine kannst du folgendermaßen nutzen:

Delphi-Quellcode:

procedure Form1.Button1Click (Sender: TObject);
var
  BMP : TBitmap;
begin
  BMP := TBitmap.Create;
  try
    BMP.Canvas.Font.Assign (RichEdit1.Font);
    GetTextImage (RichEdit1.Text, BMP);
    Self.Canvas.Draw (0, 0, BMP);
  finally
    BMP.Free;
  end;
end;

Gruß Hawkeye

irgendwie funktioniert das bei mir nicht. (RTF Formatierung wird nicht angezeigt)

[Hawkeye219]

Hallo Karstadt,

Zitat von Karstadt:

irgendwie funktioniert das bei mir nicht. (RTF Formatierung wird nicht angezeigt)

Falls du mit "RTF Formatierung" verschiedene Farben und Zeichenattribute meinst, die werden von keiner der hier vorgestellten Lösungen unterstützt. Alle Codes arbeiten nur mit dem reinen Text - ohne Formatierung.

Gruß Hawkeye

[Karstadt]

das mit RFT ist schade.. nun ist das problem.. , das ich mit TAB Tasten arbeiten will. das funktioniert abernicht. dort wird immer ein "anderes" Zeichen dartegestllt. Gibt es hier für auch eine lösung?

MFG