diff --git a/lcl/forms.pp b/lcl/forms.pp index b61901773c..82f566e35c 100644 --- a/lcl/forms.pp +++ b/lcl/forms.pp @@ -852,6 +852,8 @@ type FFonts : TStrings; FFormList: TList; FDataModuleList: TList; + FIconFont: TFont; + FMenuFont: TFont; FScreenHandlers: array[TScreenNotification] of TMethodList; FLastActiveControl: TWinControl; FLastActiveCustomForm: TCustomForm; @@ -860,6 +862,7 @@ type FOnActiveFormChange: TNotifyEvent; FPixelsPerInch : integer; FSaveFocusedList: TList; + FSystemFont: TFont; procedure DeleteCursor(AIndex: Integer); procedure DestroyCursors; procedure DestroyMonitors; @@ -884,6 +887,10 @@ type procedure RemoveForm(AForm: TCustomForm); procedure SetCursor(const AValue: TCursor); procedure SetCursors(AIndex: Integer; const AValue: HCURSOR); + procedure SetHintFont(const AValue: TFont); + procedure SetIconFont(const AValue: TFont); + procedure SetMenuFont(const AValue: TFont); + procedure SetSystemFont(const AValue: TFont); procedure UpdateLastActive; procedure UpdateMonitors; procedure RestoreLastActive; @@ -895,6 +902,9 @@ type procedure DoRemoveDataModule(DataModule: TDataModule); protected function GetHintFont: TFont; virtual; + function GetIconFont: TFont; virtual; + function GetMenuFont: TFont; virtual; + function GetSystemFont: TFont; virtual; public constructor Create(AOwner : TComponent); override; destructor Destroy; override; @@ -955,9 +965,13 @@ type property DataModuleCount: Integer read GetDataModuleCount; property DataModules[Index: Integer]: TDataModule read GetDataModules; + property HintFont: TFont read GetHintFont write SetHintFont; + property IconFont: TFont read GetIconFont write SetIconFont; + property MenuFont: TFont read GetMenuFont write SetMenuFont; + property SystemFont: TFont read GetSystemFont write SetSystemFont; property Fonts: TStrings read GetFonts; + property Height: Integer read Getheight; - property HintFont: TFont read GetHintFont; property MonitorCount: Integer read GetMonitorCount; property Monitors[Index: Integer]: TMonitor read GetMonitor; property PixelsPerInch: integer read FPixelsPerInch; diff --git a/lcl/graphics.pp b/lcl/graphics.pp index 0182a9b6e6..744be7e8c8 100644 --- a/lcl/graphics.pp +++ b/lcl/graphics.pp @@ -491,7 +491,7 @@ type procedure FreeReference; function GetCanUTF8: boolean; function GetHandle: HFONT; - procedure GetData(var FontData: TFontData); + function GetData: TFontData; function GetIsMonoSpace: boolean; function GetReference: TWSFontReference; function IsHeightStored: boolean; @@ -530,6 +530,7 @@ type procedure Assign(const ALogFont: TLogFont); procedure BeginUpdate; procedure EndUpdate; + property FontData: TFontData read GetData write SetData; function HandleAllocated: boolean; property Handle: HFONT read GetHandle write SetHandle; deprecated; function IsDefault: boolean; @@ -1774,6 +1775,7 @@ function TColorToFPColor(const c: TColor): TFPColor; procedure GetCharsetValues(Proc: TGetStrProc); function CharsetToIdent(Charset: Longint; var Ident: string): Boolean; function IdentToCharset(const Ident: string; var Charset: Longint): Boolean; +function GetFontData(Font: HFont): TFontData; function GetDefFontCharSet: TFontCharSet; function IsFontNameXLogicalFontDesc(const LongFontName: string): boolean; diff --git a/lcl/include/font.inc b/lcl/include/font.inc index 4edc15084e..1777e60fd5 100644 --- a/lcl/include/font.inc +++ b/lcl/include/font.inc @@ -1199,16 +1199,19 @@ begin end; end; -procedure TFont.GetData(var FontData: TFontData); +function TFont.GetData: TFontData; begin - FontData := DefFontData; - FontData.Handle := 0; - FontData.Height := Height; - FontData.Pitch := Pitch; - FontData.Style := Style; - FontData.CharSet := CharSet; - FontData.Quality := Quality; - FontData.Name := LeftStr(Name, SizeOf(FontData.Name) - 1); + Result := DefFontData; + if HandleAllocated then + Result.Handle := Reference.Handle + else + Result.Handle := 0; + Result.Height := Height; + Result.Pitch := Pitch; + Result.Style := Style; + Result.CharSet := CharSet; + Result.Quality := Quality; + Result.Name := LeftStr(Name, SizeOf(Result.Name) - 1); end; function TFont.GetIsMonoSpace: boolean; diff --git a/lcl/include/intfbasewinapi.inc b/lcl/include/intfbasewinapi.inc index 09623878db..c1cf6bad11 100644 --- a/lcl/include/intfbasewinapi.inc +++ b/lcl/include/intfbasewinapi.inc @@ -1052,9 +1052,9 @@ begin Result := False; end; -function TWidgetSet.InitHintFont(HintFont: TObject): Boolean; +function TWidgetSet.InitStockFont(AFont: TObject; AStockFont: TStockFont): Boolean; begin - Result := false; + Result := False; end; function TWidgetSet.IsHelpKey(Key: Word; Shift: TShiftState): Boolean; diff --git a/lcl/include/screen.inc b/lcl/include/screen.inc index ad204121ff..3567e2c743 100644 --- a/lcl/include/screen.inc +++ b/lcl/include/screen.inc @@ -91,6 +91,9 @@ begin for HandlerType := Low(FScreenHandlers) to High(FScreenHandlers) do FreeThenNil(FScreenHandlers[HandlerType]); FreeThenNil(FHintFont); + FreeThenNil(FIconFont); + FreeThenNil(FMenuFont); + FreeThenNil(FSystemFont); FreeThenNil(FDataModuleList); FreeThenNil(FFormList); FreeThenNil(FCustomForms); @@ -663,22 +666,54 @@ begin Result := nil; end; +function TScreen.GetSystemFont: TFont; +begin + if (FSystemFont = nil) then + FSystemFont := TFont.Create; + if not WidgetSet.InitStockFont(FSystemFont, sfSystem) then + begin + FSystemFont.FontData := DefFontData; + FSystemFont.Color := clWindowText; + end; + Result := FSystemFont; +end; + function TScreen.GetHintFont: TFont; begin - if (FHintFont=nil) then + if (FHintFont = nil) then FHintFont := TFont.Create; - if not WidgetSet.InitHintFont(FHintFont) then + if not WidgetSet.InitStockFont(FHintFont, sfHint) then begin -// FHintFont.Name := 'courier'; - FHintFont.Name:=DefFontData.Name; - FHintFont.Style := []; - FHintFont.Size := DefFontData.Height; + FHintFont.FontData := DefFontData; FHintFont.Color := clInfoText; - FHintFont.Pitch := fpDefault; end; Result := FHintFont; end; +function TScreen.GetIconFont: TFont; +begin + if (FIconFont = nil) then + FIconFont := TFont.Create; + if not WidgetSet.InitStockFont(FIconFont, sfIcon) then + begin + FIconFont.FontData := DefFontData; + FIconFont.Color := clWindowText; + end; + Result := FIconFont; +end; + +function TScreen.GetMenuFont: TFont; +begin + if (FMenuFont = nil) then + FMenuFont := TFont.Create; + if not WidgetSet.InitStockFont(FMenuFont, sfMenu) then + begin + FMenuFont.FontData := DefFontData; + FMenuFont.Color := clMenuText; + end; + Result := FMenuFont; +end; + {------------------------------------------------------------------------------ Function: TScreen.RemoveForm @@ -733,6 +768,26 @@ begin end; end; +procedure TScreen.SetHintFont(const AValue: TFont); +begin + FHintFont.Assign(AValue); +end; + +procedure TScreen.SetIconFont(const AValue: TFont); +begin + FIconFont.Assign(AValue); +end; + +procedure TScreen.SetMenuFont(const AValue: TFont); +begin + FMenuFont.Assign(AValue); +end; + +procedure TScreen.SetSystemFont(const AValue: TFont); +begin + FSystemFont.Assign(AValue); +end; + {------------------------------------------------------------------------------ procedure TScreen.UpdateLastActive; ------------------------------------------------------------------------------} diff --git a/lcl/interfacebase.pp b/lcl/interfacebase.pp index 85836333cd..9ab922a113 100644 --- a/lcl/interfacebase.pp +++ b/lcl/interfacebase.pp @@ -111,7 +111,7 @@ type procedure DCSetAntialiasing(CanvasHandle: HDC; AEnabled: Boolean); virtual; procedure SetDesigning(AComponent: TComponent); virtual; abstract; - function InitHintFont(HintFont: TObject): Boolean; virtual; + function InitStockFont(AFont: TObject; AStockFont: TStockFont): Boolean; virtual; function IsHelpKey(Key: Word; Shift: TShiftState): Boolean; virtual; // create and destroy diff --git a/lcl/interfaces/fpgui/fpguiint.pp b/lcl/interfaces/fpgui/fpguiint.pp index 86f9d0105b..0cd8426ddf 100644 --- a/lcl/interfaces/fpgui/fpguiint.pp +++ b/lcl/interfaces/fpgui/fpguiint.pp @@ -70,10 +70,7 @@ type function DCGetPixel(CanvasHandle: HDC; X, Y: integer): TGraphicsColor; override; procedure DCSetPixel(CanvasHandle: HDC; X, Y: integer; AColor: TGraphicsColor); override; procedure DCRedraw(CanvasHandle: HDC); override; - procedure SetDesigning(AComponent: TComponent); override; - - function InitHintFont(HintFont: TObject): Boolean; override; - + procedure SetDesigning(AComponent: TComponent); override; // create and destroy function CreateTimer(Interval: integer; TimerFunc: TFNTimerProc): THandle; override; diff --git a/lcl/interfaces/fpgui/fpguiobject.inc b/lcl/interfaces/fpgui/fpguiobject.inc index 78cd937383..f50ac95fd8 100644 --- a/lcl/interfaces/fpgui/fpguiobject.inc +++ b/lcl/interfaces/fpgui/fpguiobject.inc @@ -193,11 +193,6 @@ begin // Include(AComponent.ComponentState, csDesigning); end; -function TFpGuiWidgetSet.InitHintFont(HintFont: TObject): Boolean; -begin - Result:=false; -end; - {------------------------------------------------------------------------------ Function: TFpGuiWidgetSet.IsValidDC Params: DC - handle to a device context (TFpGuiDeviceContext) diff --git a/lcl/interfaces/qt/qtint.pp b/lcl/interfaces/qt/qtint.pp index cc397df530..0a8c70223d 100644 --- a/lcl/interfaces/qt/qtint.pp +++ b/lcl/interfaces/qt/qtint.pp @@ -113,8 +113,6 @@ type procedure DCSetAntialiasing(CanvasHandle: HDC; AEnabled: Boolean); override; procedure SetDesigning(AComponent: TComponent); override; - function InitHintFont(HintFont: TObject): Boolean; override; - // create and destroy function CreateTimer(Interval: integer; TimerFunc: TFNTimerProc): THandle; override; function DestroyTimer(TimerHandle: THandle): boolean; override; diff --git a/lcl/interfaces/qt/qtobject.inc b/lcl/interfaces/qt/qtobject.inc index fd8248f4bf..494be67926 100644 --- a/lcl/interfaces/qt/qtobject.inc +++ b/lcl/interfaces/qt/qtobject.inc @@ -433,11 +433,6 @@ begin end; -function TQtWidgetSet.InitHintFont(HintFont: TObject): Boolean; -begin - Result := False; -end; - {------------------------------------------------------------------------------ Function: TQtWidgetSet.IsValidDC Params: DC - handle to a device context (TQtDeviceContext) diff --git a/lcl/interfaces/win32/win32int.pp b/lcl/interfaces/win32/win32int.pp index 7153bbae88..a27a2f9cb6 100644 --- a/lcl/interfaces/win32/win32int.pp +++ b/lcl/interfaces/win32/win32int.pp @@ -127,6 +127,7 @@ type FMetrics: TNonClientMetrics; FMetricsFailed: Boolean; + FDefaultFont: HFONT; FWaitHandleCount: dword; FWaitHandles: array of HANDLE; @@ -175,8 +176,8 @@ type procedure AppSetTitle(const ATitle: string); override; procedure AppSetVisible(const AVisible: Boolean); override; - function InitHintFont(HintFont: TObject): Boolean; Override; - procedure AttachMenuToWindow(AMenuObject: TComponent); Override; + function InitStockFont(AFont: TObject; AStockFont: TStockFont): Boolean; override; + procedure AttachMenuToWindow(AMenuObject: TComponent); override; procedure DCSetPixel(CanvasHandle: HDC; X, Y: integer; AColor: TGraphicsColor); override; function DCGetPixel(CanvasHandle: HDC; X, Y: integer): TGraphicsColor; override; @@ -192,6 +193,7 @@ type // thread synchronize support procedure HandleWakeMainThread(Sender: TObject); function AppHandle: THandle; override; + property DefaultFont: HFONT read FDefaultFont; {$I win32winapih.inc} {$I win32lclintfh.inc} diff --git a/lcl/interfaces/win32/win32object.inc b/lcl/interfaces/win32/win32object.inc index a662669ae3..866ea84dc4 100644 --- a/lcl/interfaces/win32/win32object.inc +++ b/lcl/interfaces/win32/win32object.inc @@ -39,6 +39,11 @@ begin if FMetricsFailed then begin FMetrics.iMenuHeight := GetSystemMetrics(SM_CYMENU); + FDefaultFont := GetStockObject(DEFAULT_GUI_FONT); + end + else + begin + FDefaultFont := Windows.CreateFontIndirect(FMetrics.lfMessageFont); end; OnClipBoardRequest := nil; Pointer(InitCommonControlsEx) := GetProcAddress(GetModuleHandle(comctl32), 'InitCommonControlsEx'); @@ -91,6 +96,9 @@ begin Windows.UnregisterClass(@ClsName, System.HInstance); Windows.UnregisterClass(@ClsHintName, System.HInstance); end; + + if FDefaultFont <> 0 then + Windows.DeleteObject(FDefaultFont); inherited Destroy; end; @@ -270,14 +278,48 @@ begin if Window = 0 then Exit; end; -function TWin32WidgetSet.InitHintFont(HintFont: TObject): Boolean; +function TWin32WidgetSet.InitStockFont(AFont: TObject; AStockFont: TStockFont): Boolean; +var + Font: TFont absolute AFont; + LogFont: TLogFont; + + procedure AssignDefault; + var + LogFont: TLogFont; + begin + GetObject(DefaultFont, SizeOf(LogFont), @LogFont); + Font.Assign(LogFont); + end; + begin - TFont(HintFont).Name := FMetrics.lfStatusFont.lfFaceName; - TFont(HintFont).Style := []; - TFont(HintFont).Height := FMetrics.lfStatusFont.lfHeight; - TFont(HintFont).Color := clInfoText; - TFont(HintFont).Pitch := fpDefault; - Result := true; + case AStockFont of + sfSystem: + Font.FontData := GetFontData(DefaultFont); + sfHint: + begin + if FMetricsFailed then + AssignDefault + else + Font.Assign(FMetrics.lfStatusFont); + Font.Color := clInfoText; + end; + sfIcon: + begin + if SystemParametersInfo(SPI_GETICONTITLELOGFONT, SizeOf(LogFont), @LogFont, 0) then + Font.Assign(LogFont) + else + AssignDefault + end; + sfMenu: + begin + if FMetricsFailed then + AssignDefault + else + Font.Assign(FMetrics.lfMenuFont); + Font.Color := clMenuText; + end; + end; + Result := True; end; {------------------------------------------------------------------------------ diff --git a/lcl/interfaces/win32/win32wscontrols.pp b/lcl/interfaces/win32/win32wscontrols.pp index 609bb0a51a..51a47ee199 100644 --- a/lcl/interfaces/win32/win32wscontrols.pp +++ b/lcl/interfaces/win32/win32wscontrols.pp @@ -248,7 +248,7 @@ begin WindowInfo^.DefWndProc := Windows.WNDPROC(SetWindowLong( Window, GWL_WNDPROC, PtrInt(SubClassWndProc))); if AWinControl.Font.IsDefault then - lhFont := GetStockObject(DEFAULT_GUI_FONT) + lhFont := Win32WidgetSet.DefaultFont else lhFont := AWinControl.Font.Reference.Handle; Windows.SendMessage(Window, WM_SETFONT, WPARAM(lhFont), 0); @@ -277,7 +277,7 @@ begin BuddyWindowInfo^.DefWndProc := Windows.WNDPROC(SetWindowLong( Buddy, GWL_WNDPROC, PtrInt(SubClassWndProc))); if AWinControl.Font.IsDefault then - lhFont := GetStockObject(DEFAULT_GUI_FONT) + lhFont := Win32Widgetset.DefaultFont else lhFont := AWinControl.Font.Reference.Handle; Windows.SendMessage(Buddy, WM_SETFONT, WPARAM(lhFont), 0); diff --git a/lcl/interfaces/win32/win32wsforms.pp b/lcl/interfaces/win32/win32wsforms.pp index 311af4daff..faee487fad 100644 --- a/lcl/interfaces/win32/win32wsforms.pp +++ b/lcl/interfaces/win32/win32wsforms.pp @@ -179,7 +179,7 @@ class function TWin32WSScrollBox.CreateHandle(const AWinControl: TWinControl; if SubClassWndProc <> nil then WindowInfo^.DefWndProc := Windows.WNDPROC(SetWindowLong( Window, GWL_WNDPROC, PtrInt(SubClassWndProc))); - lhFont := GetStockObject(DEFAULT_GUI_FONT) + lhFont := FDefaultFont; Windows.SendMessage(Window, WM_SETFONT, WPARAM(lhFont), 0);} end; end; diff --git a/lcl/interfaces/wince/winceint.pp b/lcl/interfaces/wince/winceint.pp index 9199d0f0a2..5b4fd20c6c 100644 --- a/lcl/interfaces/wince/winceint.pp +++ b/lcl/interfaces/wince/winceint.pp @@ -194,7 +194,6 @@ type procedure AppWaitMessage; override; procedure AppTerminate; override; procedure AppSetTitle(const ATitle: string); override; - //function InitHintFont(HintFont: TObject): Boolean; override; procedure AttachMenuToWindow(AMenuObject: TComponent); override; procedure DCSetPixel(CanvasHandle: HDC; X, Y: integer; AColor: TGraphicsColor); override; function DCGetPixel(CanvasHandle: HDC; X, Y: integer): TGraphicsColor; override; diff --git a/lcl/interfaces/wince/winceobject.inc b/lcl/interfaces/wince/winceobject.inc index 7eac8dc18b..5f8cd46fd2 100644 --- a/lcl/interfaces/wince/winceobject.inc +++ b/lcl/interfaces/wince/winceobject.inc @@ -272,18 +272,6 @@ begin if Window=0 then exit; end; -//roozbeh : how can we have hints on ce? -{ -function TWinCEWidgetSet.InitHintFont(HintFont: TObject): Boolean; -begin - TFont(HintFont).Name := FMetrics.lfStatusFont.lfFaceName; - TFont(HintFont).Style := []; - TFont(HintFont).Height := FMetrics.lfStatusFont.lfHeight; - TFont(HintFont).Color := clInfoText; - TFont(HintFont).Pitch := fpDefault; - Result := true; -end; -} {------------------------------------------------------------------------------ Method: TWinCEWidgetSet.AppProcessMessages Params: None diff --git a/lcl/interfaces/wince/wincewscontrols.pp b/lcl/interfaces/wince/wincewscontrols.pp index 083935d05e..3c44d792d9 100644 --- a/lcl/interfaces/wince/wincewscontrols.pp +++ b/lcl/interfaces/wince/wincewscontrols.pp @@ -249,7 +249,7 @@ begin WindowInfo^.DefWndProc := Windows.WNDPROC(Windows.SetWindowLong( Window, GWL_WNDPROC, LongInt(SubClassWndProc))); if AWinControl.Font.IsDefault then - lhFont := GetStockObject(DEFAULT_GUI_FONT) + lhFont := WinCEWidgetset.MessageFont else lhFont := AWinControl.Font.Reference.Handle; Windows.SendMessage(Window, WM_SETFONT, lhFont, 0) @@ -269,7 +269,7 @@ begin Params.BuddyWindowInfo^.DefWndProc := Windows.WNDPROC(Windows.SetWindowLong( Params.Buddy, GWL_WNDPROC, LongInt(Params.SubClassWndProc))); if AWinControl.Font.IsDefault then - lhFont := GetStockObject(DEFAULT_GUI_FONT) + lhFont := WinCEWidgetset.MessageFont else lhFont := AWinControl.Font.Reference.Handle; Windows.SendMessage(Params.Buddy, WM_SETFONT, lhFont, 0); diff --git a/lcl/lcltype.pp b/lcl/lcltype.pp index 8db6682d6e..4d03dafb9d 100644 --- a/lcl/lcltype.pp +++ b/lcl/lcltype.pp @@ -1584,7 +1584,6 @@ const DC_PEN = 19; STOCK_LAST = 19; - //============================================== // Stock Pixmap Types //============================================== @@ -2655,6 +2654,13 @@ type NM_LISTVIEW = TNMListView; tagNMLISTVIEW = TNMListView; + // enum to use with InitStockFont + TStockFont = ( + sfSystem, // stock system font + sfHint, // stock hint font + sfIcon, // stock icon font + sfMenu // stock menu font + ); function CS_To_String(CompStyle: Integer): String; // key mapping