Memo-Text für Zeichenfläche formatieren?

[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;