Memo-Text für Zeichenfläche formatieren?

[Dani]

Hallo,

bin am verzweifeln. Seit Wochen versuche ich eine Funktion zu schreiben, die mir einen Text so formatiert, dass man diesen Text dann Zeile für Zeile auf ein Bitmap zeichnen kann. Aber es will nicht funktionieren

Entweder es wird ein Wort zu viel in die Zeile geschrieben oder es sind zu viele Zeilenumbrüche darin, ich blicke den eigenen Code nicht mehr durch... besonders elegant ist der auch nicht. Gibt's denn keine einfache Möglichkeit, den Text zu formatieren? Funktioniert EM_FORMATRANGE auch mit Memos?

Zum Lachen hier noch mein bisheriger Code:

Delphi-Quellcode:

function TMyMemo.CreateFormattedStrings(sInput: TStrings; OnCanvas: TCanvas): TStringlist;
var
 sWord, sNonWord, sTmp, sResult, sLine: String;
 LastChar, MaxChar: Integer;
 Clusters: TStringlist;
const
 WordSeperators = [' '];
begin
 Result := TStringlist.Create;
 Clusters := TStringlist.Create;

 sTmp := sInput.Text;
 sResult := '';
 LastChar := 1;
 MaxChar := Length(sTmp);
 sWord := '';
 sNonWord := '';
 sLine := '';
 Clusters.Clear;

 With OnCanvas do
 while LastChar < MaxChar do
 try
  //sLine bilden
  sLine := '';
  while (TextWidth(sLine) < FPxWidth)
    AND (LastChar < MaxChar) do
   begin
    //Wort finden
    sWord := '';
    sNonWord := '';
    Clusters.Clear;
    while (LastChar <= MaxChar) AND not (sTmp[LastChar] in WordSeperators) do
     begin
      sWord := sWord + sTmp[LastChar];
      Inc(LastChar);
     end;
   // ShowMessage('sWord:' + '"'+sWord+'"');
    //Leerzeichen finden
    while (LastChar <= MaxChar) AND (sTmp[LastChar] in WordSeperators) do
     begin
      sNonWord := sNonWord + sTmp[LastChar];
      Inc(LastChar);
     end;
     //Passt das Wort noch in sLine?
     If TextWidth(sLine + sWord) > FPxWidth then
      begin 
       Clusters.Add('');
       //Ist das Wort zu lang für 1 Zeile?
       If TextWidth(sWord) > FPxWidth then
        begin
         while (Length(sWord)>0) do
          begin
           If TextWidth(Clusters[Clusters.Count-1]) > PxWidth then Clusters.Add('');
           Clusters[Clusters.Count-1] := Clusters[Clusters.Count-1] + sWord[1];
           Delete(sWord, 1, 1);
           If TextWidth(sWord) <= PxWidth then break;
          end;
        end;
       while (Clusters.Count>0) AND (Clusters[Clusters.Count-1] = #13#10) do
        Clusters.Delete(Clusters.Count-1);
       //If Clusters.Text = #13#10 then Windows.Beep(400,100); 
       sLine := sLine + Clusters.Text + sWord;
      end
       //Das Wort passt noch in sLine
       else sLine := sLine + sWord;

   sLine := sLine + sNonWord;
   //ShowMessage('sLine:' + '"'+sLine+'"');
  end;
  //sLine hinzufügen
  sResult := sResult + sLine + #13#10;
 except
  exit;
 end;
 //ShowMessage('Final Result:' + #13#10 + '"' + sResult + '"');
 Result.Text := sResult;
 While (Result.Count > 0) AND (Result[Result.Count-1] = #13#10) do
  Result.Delete(Result.Count-1);
end;

[Fossibaer58809]

Schon mal geschaut ob die Api- Funktion DrawText dafür zu gebrauchen ist?

Beispiel:

Code:

  hdc := OnCanvas.Handle;
  DrawText(hdc, PAnsiChar(S), Length(S), R, DT_WORDBREAK);

[Dani]

Gibt es keine Möglichkeit, an den formatierten Text (String) zu kommen?

Edit: Merke gerade, dass DrawText den Text ziemlich besch...eiden formatiert...

[Kedariodakon]

Kannst du nicht mit WrapText nen Zeilenumbruch machen ?

Bye

[Dani]

Zitat von Kedariodakon:

Kannst du nicht mit WrapText nen Zeilenumbruch machen ?

Nein, das geht nicht, da die Buchstaben unterschiedliche Breiten haben können . Ausserdem sollten Wörter, die nicht in eine Zeile passen, getrennt werden (ohne irgendwelche Trennungsregeln, einfach nur einen Zeilenumbruch einfügen)

[Dani]

So, ich glaube, es funktioniert jetzt. TCanvas.TextWidth scheint Zeilenumbrüche zu ignorieren, diese werden aber in "sWord" mitgespeichert.

Folgender grausamer Code ist nicht zum Nachmachen empfohlen

Delphi-Quellcode:

function TextWidthEx(aCanvas: TCanvas; sText: String): Integer;
var sList: TStringList;
      arr: array of Integer;
        i: Integer;
begin
 Result := -1;
 sList := TStringList.Create;
 try
  sList.Text := sText;
  SetLength(arr, sList.Count);
  for i:=0 to High(arr) do
   arr[i] := aCanvas.TextWidth(sList[i]);
  for i:=0 to High(arr) do
   If arr[i] > Result then Result := arr[i]; 
 finally
  sList.Free;
 end;
end;

function TextHeightEx(aCanvas: TCanvas; sText: String): Integer;
var sList: TStringList;
      arr: array of Integer;
        i: Integer;
begin
 Result := -1;
 sList := TStringList.Create;
 try
  sList.Text := sText;
  SetLength(arr, sList.Count);
  for i:=0 to High(arr) do
   arr[i] := aCanvas.TextHeight(sList[i]);
  for i:=0 to High(arr) do
   If arr[i] > Result then Result := arr[i]; 
 finally
  sList.Free;
 end;
end;


function TSpecialMemo.CreateFormattedStrings(sInput: TStrings; OnCanvas: TCanvas): TStringlist;
var 
 sWord, sNonWord, sTmp, sResult, sLine: String;
 LastChar, MaxChar: Integer;
 Clusters: TStringlist;
 DidLB: Boolean;
const
 WordSeperators = [' '];
begin
 Result := TStringlist.Create;
 Clusters := TStringlist.Create;

 sTmp := sInput.Text;
 sResult := '';
 LastChar := 1;
 MaxChar := Length(sTmp);
 sWord := '';
 sNonWord := '';
 sLine := '';
 Clusters.Clear;

 while LastChar < MaxChar do
 try
   //sLine bilden
   sLine := '';
   while (TextWidthEx(OnCanvas, sLine) < FPxWidth)
     AND (LastChar < MaxChar) do
    begin
     sWord := '';
     sNonWord := '';
     DidLB := false;
     Clusters.Clear;
     //Wort finden
     while (LastChar <= MaxChar) AND not (sTmp[LastChar] in WordSeperators) do
      begin
       sWord := sWord + sTmp[LastChar];
       Inc(LastChar);
      end;
     //ShowMessage('sWord:' + '"'+sWord+'"');
     //Leerzeichen finden
     while (LastChar <= MaxChar) AND (sTmp[LastChar] in WordSeperators) do
      begin
       sNonWord := sNonWord + sTmp[LastChar];
       Inc(LastChar);
      end;
      //Passt das Wort noch in sLine?
      If TextWidthEx(OnCanvas, sLine + sWord) > FPxWidth then
       begin
        DidLB := true;
        Clusters.Add('');
        //Ist das Wort zu lang für 1 Zeile?
        If TextWidthEx(OnCanvas, sWord) > FPxWidth then
         begin
          while (Length(sWord)>0) do
           begin
            If TextWidthEx(OnCanvas, Clusters[Clusters.Count-1]) > PxWidth then Clusters.Add('');
            Clusters[Clusters.Count-1] := Clusters[Clusters.Count-1] + sWord[1];
            Delete(sWord, 1, 1);
            If TextWidthEx(OnCanvas, sWord) <= PxWidth then break;
           end;
         end;
        while (Clusters.Count>0) AND (Clusters[Clusters.Count-1] = #13#10) do
         Clusters.Delete(Clusters.Count-1);
        //If Clusters.Text = #13#10 then Windows.Beep(400,100);
        sLine := sLine + Clusters.Text + sWord;
       end
        //Das Wort passt noch in sLine
        else sLine := sLine + sWord;

    sLine := sLine + sNonWord;
   end;
   //sLine hinzufügen
   If not DidLB then sLine := sLine + #13#10;
   //ShowMessage('sLine:' + '"'+sLine+'"');
   sResult := sResult + sLine;
 except
   exit;
 end;
 //ShowMessage('Final Result:' + #13#10 + '"' + sResult + '"');
 Result.Text := sResult;
 While (Result.Count > 0) AND (Result[Result.Count-1] = #13#10) do
   Result.Delete(Result.Count-1);
end;