paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-09-03 13:20:13 +02:00
Code Issues Packages Projects Releases Wiki Activity

LCL-GTK2: Implement TGtk2WidgetSet.GetTextExtentExPoint(). Issue #34276, patch from accorp.

Browse Source 
git-svn-id: trunk@58987 -
This commit is contained in:
juha 2018-09-14 08:45:30 +00:00
parent 11ad2639aa
commit 574bb4ecb7
3 changed files with 92 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
lcl/interfaces/gtk2/gtk2extrah.inc
View File

@ -127,6 +127,8 @@ function pango_attr_gravity_new(gravity: TPangoGravity): PPangoAttribute; cdecl;
function pango_version_check(required_major, required_minor, required_micro: integer): PChar; cdecl; external pangolib;
procedure pango_extents_to_pixels(inclusive: PPangoRectangle; nearest: PPangoRectangle); cdecl; external pangolib;
{$IF FPC_FULLVERSION<20501}
function pango_font_family_is_monospace(family:PPangoFontFamily):gboolean; cdecl; external pangolib;
{$ENDIF}

114
lcl/interfaces/gtk2/gtk2winapi.inc
View File

@ -5964,6 +5964,94 @@ begin
end;
end;
{------------------------------------------------------------------------------
Function: GetTextExtentExPoint
Params:
Returns:
------------------------------------------------------------------------------}
function TGtk2WidgetSet.GetTextExtentExPoint(DC: HDC; Str: PChar;
Count, MaxWidth: Integer; MaxCount, PartialWidths: PInteger;
var Size: TSize): Boolean;
var
DevCtx: TGtkDeviceContext absolute DC;
UseFont : TGtkIntfFont;
Utf8Len, Accu, I: PtrInt;
Iter: PPangoLayoutIter;
CharRect: TPangoRectangle;
begin
if not IsValidDC(DC) then
Exit(False);
Size.cx := 0;
Size.cy := 0;
if MaxCount <> nil then
MaxCount^ := 0;
if Count = 0 then
Exit(True);
if (Count < -1) or (Str = nil) then
Exit(False);
if Count = -1 then
Count := Length(Str);
Utf8Len := UTF8Length(Str, Count);
if Utf8Len = 0 then
Exit(True);
UseFont := GetGtkFont(DevCtx);
UpdateDCTextMetric(DevCtx);
SetLayoutText(UseFont, Str, Count);
pango_layout_get_pixel_size(UseFont, @Size.cx, @Size.cy);
if DevCtx.HasTransf then
begin
DevCtx.InvTransfExtent(Size.cx, Size.cy);
Size.cx := Abs(Size.cx);
Size.cy := Abs(Size.cy);
end;
if PartialWidths = nil then
begin
if MaxCount = nil then
Exit(True);
if Size.cx <= MaxWidth then
begin
MaxCount^ := Utf8Len;
Exit(True);
end;
end;
I := 1;
Accu := 0;
Iter := pango_layout_get_iter(UseFont);
repeat
pango_layout_iter_get_char_extents(Iter, @CharRect);
Inc(Accu, CharRect.Width);
CharRect.Width := Accu;
pango_extents_to_pixels(nil, @CharRect);
if DevCtx.HasTransf then
begin
DevCtx.InvTransfExtent(CharRect.Width, CharRect.Height);
CharRect.Width := Abs(CharRect.Width);
end;
if MaxCount <> nil then
begin
if CharRect.Width > MaxWidth then
Break;
MaxCount^ := I;
end;
if PartialWidths <> nil then
PartialWidths[I - 1] := CharRect.Width;
Inc(I);
until not pango_layout_iter_next_char(Iter);
pango_layout_iter_free(Iter);
Exit(True);
end;
{------------------------------------------------------------------------------
Function: GetTextExtentPoint
Params: none
@ -5973,32 +6061,8 @@ end;
------------------------------------------------------------------------------}
function TGtk2WidgetSet.GetTextExtentPoint(DC: HDC; Str: PChar; Count: Integer;
var Size: TSize): Boolean;
var
DevCtx: TGtkDeviceContext absolute DC;
UseFont : PPangoLayout;
begin
Result := IsValidDC(DC);
if not Result then Exit;
if (Count <= 0) or (Str = nil) or (StrPas(Str) = '') then
begin
FillChar(Size, SizeOf(Size), 0);
Exit;
end;
UseFont := GetGtkFont(TGtkDeviceContext(DC));
UpdateDCTextMetric(TGtkDeviceContext(DC));
SetLayoutText(UseFont, Str, Count);
pango_layout_get_pixel_size(UseFont, @Size.cX, @Size.cY);
//DebugLn(['TGtk2WidgetSet.GetTextExtentPoint Str="',copy(Str,1,Count),' Count=',Count,' X=',Size.cx,' Y=',Size.cY]);
if DevCtx.HasTransf then
begin
DevCtx.InvTransfExtent(Size.cx, Size.cy);
Size.cx := Abs(Size.cx);
Size.cy := Abs(Size.cy);
end;
Result := GetTextExtentExPoint(DC, Str, Count, 0, nil, nil, Size);
end;
{------------------------------------------------------------------------------

1
lcl/interfaces/gtk2/gtk2winapih.inc
View File

@ -139,6 +139,7 @@ function GetSysColor(nIndex: Integer): DWORD; override;
function GetSysColorBrush(nIndex: Integer): HBrush; override;
function GetSystemMetrics(nIndex: Integer): Integer; override;
function GetTextColor(DC: HDC) : TColorRef; override;
function GetTextExtentExPoint(DC: HDC; Str: PChar; Count, MaxWidth: Integer; MaxCount, PartialWidths: PInteger; var Size: TSize): Boolean; override;
function GetTextExtentPoint(DC: HDC; Str: PChar; Count: Integer; var Size: TSize): Boolean; override;
function GetTextMetrics(DC: HDC; var TM: TTextMetric): Boolean; override;
function GetViewPortExtEx(DC: HDC; Size: PSize): Integer; override;