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

Win32: improve FontIsMonoSpace. issue #28898

Browse Source 
git-svn-id: trunk@57926 -
This commit is contained in:
ondrej 2018-05-13 13:16:37 +00:00
parent 32d9cf118f
commit 76bf7b4649
1 changed files with 20 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
lcl/interfaces/win32/win32lclintf.inc
View File

@ -103,22 +103,29 @@ begin
Result := True;
end;
type
TFontIsMonoSpaceRec = record
Name: string;
Result: Boolean;
end;
PFontIsMonoSpaceRec = ^TFontIsMonoSpaceRec;
function EnumFontsCallBack(
var LogFont: TEnumLogFontEx;
var Metric: TNewTextMetricEx;
FontType: Longint;
Data: LParam):LongInt; stdcall;
var
L: TStringList;
S: String;
R: PFontIsMonoSpaceRec;
begin
L := TStringList(PtrInt(Data));
S := LogFont.elfLogFont.lfFaceName;
if ((logfont.elfLogFont.lfPitchAndFamily and FIXED_PITCH) = FIXED_PITCH) then
R := PFontIsMonoSpaceRec(Data);
if ((logfont.elfLogFont.lfPitchAndFamily and FIXED_PITCH) = FIXED_PITCH)
and SameStr(R^.Name, LogFont.elfLogFont.lfFaceName) then
begin
L.Add(S);
end;
result := 1;
R^.Result := True;
Result := 0 // we found it -> stop enumeration
end else
Result := 1;
end;
@ -126,9 +133,8 @@ function TWin32WidgetSet.FontIsMonoSpace(Font: HFont): boolean;
var
LF: LogFontA;
Res: LongInt;
List: TStringList;
FontName: String;
DC: HDC;
Rec: TFontIsMonoSpaceRec;
begin
Result := False;
FillChar(LF{%H-}, SizeOf(LogFontA), #0);
@ -139,16 +145,15 @@ begin
Exit;
LF.lfCharSet := DEFAULT_CHARSET;
LF.lfPitchAndFamily := 0;
FontName := LF.lfFaceName;
Rec.Name := LF.lfFaceName;
Rec.Result := False;
DC := GetDC(0);
List := TStringList.Create;
try
EnumFontFamiliesEX(DC, @LF, @EnumFontsCallback, PtrInt(List), 0);
Result := (List.IndexOf(FontName) > -1);
EnumFontFamiliesEX(DC, @LF, @EnumFontsCallback, LPARAM(@Rec), 0);
finally
ReleaseDC(0, DC);
List.Free;
end;
Result := Rec.Result;
end;
procedure TWin32WidgetSet.HandleProcessEvent(AData: PtrInt; AFlags: dword);