lcl: fonts:

- add TScreen.IconFont, TScreen.MenuFont, TScreen.SystemFont
  - replace TWidgetset.InitHintFont with TWidgetset.InitStockFont
win32, wince: retrieve default font from SystemParametersInfo as described in issue #0013848

git-svn-id: trunk@20275 -

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;

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;

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;

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;

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;
  ------------------------------------------------------------------------------}

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

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;

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)

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;

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)

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}

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;
 
 {------------------------------------------------------------------------------

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);

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;

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;

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

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);

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