unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, Forms, Controls, Graphics, StdCtrls, LCLIntf, LCLType, Types;
type
TForm1 = class(TForm)
Button1: TButton;
Memo1: TMemo;
procedure Button1Click(Sender: TObject);
end;
function WrapAnsiText(Canvas: TCanvas; const Text: String; MaxWidth: Integer): String;
function GetAnsiTextWrappedMemoHeight(aMemo: TMemo): Integer;
var
Form1: TForm1;
implementation
{$R *.lfm}
function WrapAnsiText(Canvas: TCanvas; const Text: String; MaxWidth: Integer): String;
var
DC: HDC;
TextExtent: TSize;
S, P, E: PChar;
Line: String;
IsFirstLine: Boolean;
begin
Result := '';
DC := Canvas.Handle;
IsFirstLine := True;
P := PChar(Text);
while P^ = ' ' do
Inc(P);
while P^ <> #0 do
begin
S := P;
E := Nil;
while (P^ <> #0) and (P^ <> #13) and (P^ <> #10) do
begin
GetTextExtentPoint(DC, S, P - S + 1, TextExtent{%H-});
if (TextExtent.CX > MaxWidth) and (E <> Nil) then
begin
if (P^ <> ' ') and (P^ <> ^I) then
begin
while (E >= S) do
case E^ of
'.', ',', ';', '?', '!', '-', ':',
')', ']', '}', '>', '/', '\', ' ':
Break;
else
Dec(E);
end;
if E < S then
E := P - 1;
end;
Break;
end;
E := P;
Inc(P);
end;
if E <> Nil then
begin
while (E >= S) and (P^ = ' ') do
Dec(E);
end;
if E <> Nil then
SetString(Line, S, E - S + 1)
else
SetLength(Line, 0);
if (P^ = #13) or (P^ = #10) then
begin
Inc(P);
if (P^ <> (P - 1)^) and ((P^ = #13) or (P^ = #10)) then
Inc(P);
if P^ = #0 then
Line := Line + LineEnding;
end
else if P^ <> ' ' then
P := E + 1;
while P^ = ' ' do
Inc(P);
if IsFirstLine then
begin
Result := Line;
IsFirstLine := False;
end
else
Result := Result + LineEnding + Line;
end;
end;
function GetAnsiTextWrappedMemoHeight(aMemo: TMemo): Integer;
const
flags = DT_NOPREFIX or DT_EDITCONTROL or DT_CALCRECT or DT_WORDBREAK;
var
wrappedText: String;
pWrap: PChar absolute wrappedText;
cnv: TControlCanvas;
r: TRect;
begin
if not Assigned(aMemo) or (aMemo.Text = '') then
Exit(0);
cnv := TControlCanvas.Create;
try
cnv.Control := aMemo;
r := aMemo.ClientRect;
wrappedText := WrapAnsiText(cnv, aMemo.Text, aMemo.Width);
DrawText(cnv.Handle, pWrap, Length(aMemo.Text), r, flags);
Result := r.Height;
finally
cnv.Free;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Memo1.Text := 'afdлкйслакдф йдсалкйфдлксайфдклйдсайлкдасйлкдйклсдалкйдлс,асдфласйдфлксадйфлкдаслдфк асдфклйасдлкдфйклас асдлкфйсадлкфдйсавияуроиевяу асфлкдйлкдфсайдс';
Memo1.Height := GetAnsiTextWrappedMemoHeight(Memo1);
end;
end.
Bookstore
