forked from HeidiSQL/HeidiSQL
-
Notifications
You must be signed in to change notification settings - Fork 0
Expand file tree
/
Copy pathVcl.FormsFix.pas
More file actions
123 lines (107 loc) · 3.41 KB
/
Copy pathVcl.FormsFix.pas
File metadata and controls
123 lines (107 loc) · 3.41 KB
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
unit Vcl.FormsFix;
interface
implementation
uses
System.SysUtils, Winapi.Windows, Vcl.Forms, Vcl.Graphics, System.UITypes
//
, DDetours
//
;
var
trampoline_GetMetricSettings: Procedure = nil;
type
TFontHelper = class helper for TFont
public
function Equals(const AOther: TFont): Boolean;
end;
function TFontHelper.Equals(const AOther: TFont): Boolean;
begin
Result := (AOther.PixelsPerInch = self.PixelsPerInch)
and (AOther.Charset = self.Charset)
and (AOther.Color = self.Color)
and (AOther.Height = self.Height)
and (AOther.Name = self.Name)
and (AOther.Orientation = self.Orientation)
and (AOther.Pitch = self.Pitch)
and (AOther.Size = self.Size)
and (AOther.Style = self.Style)
and (AOther.Quality = self.Quality);
end;
type
TScreenHelper = class Helper for TScreen
public
function getPtr_GetMetricSettings:Pointer;
end;
function TScreenHelper.getPtr_GetMetricSettings:Pointer;
begin
result:=@TScreen.GetMetricSettings;
end;
procedure HookedGetMetricSettings(const Self);
procedure CheckedFontChange(const ACurrFont: TFont; const ANewFont: tagLOGFONTW);
var
TmpFont: TFont;
begin
TmpFont := TFont.Create;
try
TmpFont.Assign(ACurrFont);
TmpFont.Handle := CreateFontIndirect(ANewFont);
if not TmpFont.Equals(ACurrFont) then
begin
ACurrFont.Handle := CreateFontIndirect(ANewFont);
end;
finally
FreeAndNil(TmpFont);
end;
end;
var
LSize: Cardinal;
LogFont: TLogFont;
NonClientMetrics: TNonClientMetrics;
SaveShowHint: Boolean;
begin
SaveShowHint := False;
if Assigned(Application) then SaveShowHint := Application.ShowHint;
try
if Assigned(Application) then Application.ShowHint := False;
{$IF DEFINED(CLR)}
LSize := Marshal.SizeOf(TypeOf(TLogFont));
{$ELSE}
LSize := SizeOf(TLogFont);
{$IFEND}
if SystemParametersInfo(SPI_GETICONTITLELOGFONT, LSize, {$IFNDEF CLR}@{$ENDIF}LogFont, 0) then
begin
CheckedFontChange(Screen.IconFont, LogFont);
end
else
Screen.IconFont.Handle := GetStockObject(SYSTEM_FONT);
{$IF DEFINED(CLR)}
LSize := Marshal.SizeOf(TypeOf(TNonClientMetrics));
{$ELSE}
LSize := TNonClientMetrics.SizeOf;
{$IFEND}
NonClientMetrics.cbSize := LSize;
if SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, {$IFNDEF CLR}@{$ENDIF}NonClientMetrics, 0) then
begin
CheckedFontChange(Screen.HintFont, NonClientMetrics.lfStatusFont);
CheckedFontChange(Screen.MenuFont, NonClientMetrics.lfMenuFont);
CheckedFontChange(Screen.MessageFont, NonClientMetrics.lfMessageFont);
CheckedFontChange(Screen.CaptionFont, NonClientMetrics.lfCaptionFont);
end else
begin
Screen.HintFont.Size := 8;
Screen.MenuFont.Handle := GetStockObject(SYSTEM_FONT);
Screen.MessageFont.Handle := GetStockObject(SYSTEM_FONT);
Screen.CaptionFont.Handle := GetStockObject(SYSTEM_FONT);
end;
Screen.HintFont.Color := clInfoText;
Screen.MenuFont.Color := clMenuText;
Screen.MessageFont.Color := clWindowText;
finally
if Assigned(Application) then Application.ShowHint := SaveShowHint;
end;
end;
initialization
@trampoline_GetMetricSettings := InterceptCreate(Screen.getPtr_GetMetricSettings, @HookedGetMetricSettings);
finalization
InterceptRemove(@trampoline_GetMetricSettings);
end.