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

Merged revision(s) 51983 #7ccb2f58d2 from trunk:

Browse Source 
Win32: first attempt to implement TWin32WidgetSet.FontIsMonoSpace. Issue #0028898.
........

git-svn-id: branches/fixes_1_6@51996 -
This commit is contained in:
maxim 2016-03-19 13:35:51 +00:00
parent 7c789e1ef4
commit 304a191c25
2 changed files with 49 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -103,6 +103,54 @@ begin
Result := True;
end;
function EnumFontsCallBack(
var LogFont: TEnumLogFontEx;
var Metric: TNewTextMetricEx;
FontType: Longint;
Data: LParam):LongInt; stdcall;
var
L: TStringList;
S: String;
begin
L := TStringList(PtrInt(Data));
S := LogFont.elfLogFont.lfFaceName;
if ((logfont.elfLogFont.lfPitchAndFamily and FIXED_PITCH) = FIXED_PITCH) then
begin
L.Add(S);
end;
result := 1;
end;
function TWin32WidgetSet.FontIsMonoSpace(Font: HFont): boolean;
var
LF: LogFontA;
Res: LongInt;
List: TStringList;
FontName: String;
DC: HDC;
begin
Result := False;
FillChar(LF{%H-}, SizeOf(LogFontA), #0);
Res := GetObject(Font, SizeOf(LogFontA),@LF);
//writeln('TWin32WidgetSet.FontIsMonoSpace: Res = ',Res,' SizeOf(LogFont) = ',SizeOf(LogFontA));
//TWin32WidgetSet.GetObject uses LogFontW and converts back to LogFontA, so Res should be SizeOf(LogFontW)
if (Res <> SizeOf(LogFontW)) then
Exit;
LF.lfCharSet := DEFAULT_CHARSET;
LF.lfPitchAndFamily := 0;
FontName := LF.lfFaceName;
DC := GetDC(0);
List := TStringList.Create;
try
EnumFontFamiliesEX(DC, @LF, @EnumFontsCallback, PtrInt(List), 0);
Result := (List.IndexOf(FontName) > -1);
finally
ReleaseDC(0, DC);
List.Free;
end;
end;
procedure TWin32WidgetSet.HandleProcessEvent(AData: PtrInt; AFlags: dword);
var
lProcessEvent: PProcessEvent absolute AData;

1
lcl/interfaces/win32/win32lclintfh.inc
View File

@ -44,6 +44,7 @@ function ExtUTF8Out(DC: HDC; X, Y: Integer; Options: Longint; Rect: PRect;
Str: PChar; Count: Longint; Dx: PInteger): Boolean; override;
function FontCanUTF8({%H-}Font: HFont): boolean; override;
function FontIsMonoSpace(Font: HFont): boolean; override;
function GetAcceleratorString(const AVKey: Byte; const AShiftState: TShiftState): String; override;
function GetControlConstraints(Constraints: TObject): boolean; override;