spktoolbar: Fix fonts not changeable in OI

git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@5982 8e941d3f-bd1b-0410-a28a-d453659cc2b4

components/spktoolbar/SpkToolbar/SpkToolbar.pas

@@ -1389,6 +1389,8 @@ procedure TSpkToolbar.ValidateBuffer;
       TabRect := FTabRects[index];
 
       FBuffer.canvas.font.Assign(AFont);
+      SpkScaleFont(FBuffer.Canvas.Font);
+
       if AOverrideTextColor <> clNone then
         clr := AOverrideTextColor else
         clr := AFont.Color;
@@ -1730,6 +1732,7 @@ begin
         else
           TabAppearance := FAppearance;
         FBuffer.Canvas.font.Assign(TabAppearance.Tab.TabHeaderFont);
+        SpkScaleFont(FBuffer.Canvas.Font);
 
         TabWidth := 2 +  // Frame
           2 * TabCornerRadius +

components/spktoolbar/SpkToolbar/spkt_Appearance.pas

@@ -53,6 +53,8 @@ type
     procedure SetGradientType(const Value: TBackgroundKind);
     procedure SetInactiveHeaderFontColor(const Value: TColor);
 
+    procedure TabHeaderFontChange(Sender: TObject);
+
   public
     // *** Konstruktor, destruktor, assign ***
     // <remarks>Appearance musi mieæ assign, bo wystêpuje jako w³asnoœæ
@@ -100,6 +102,8 @@ type
     procedure SetHotTrackBrightnessChange(const Value: Integer);
     procedure SetStyle(const Value: TSpkPaneStyle);
 
+    procedure CaptionFontChange(Sender: TObject);
+
   public
     constructor Create(ADispatch: TSpkBaseAppearanceDispatch);
     destructor Destroy; override;
@@ -176,6 +180,7 @@ type
     procedure SetIdleInnerLightColor(const Value: TColor);
     procedure SetStyle(const Value: TSpkElementStyle);
 
+    procedure CaptionFontChange(Sender: TObject);
   public
     constructor Create(ADispatch: TSpkBaseAppearanceDispatch);
     destructor Destroy; override;
@@ -297,6 +302,7 @@ begin
   inherited Create;
   FDispatch := ADispatch;
   FTabHeaderFont := TFont.Create;
+  FTabHeaderFont.OnChange := TabHeaderFontChange;
   Reset;
 end;
 
@@ -491,6 +497,12 @@ begin
     FDispatch.NotifyAppearanceChanged;
 end;
 
+procedure TSpkTabAppearance.TabHeaderFontChange(Sender: TObject);
+begin
+  if FDispatch <> nil then
+    FDispatch.NotifyAppearanceChanged;
+end;
+
 
 { TSpkPaneAppearance }
 
@@ -499,6 +511,7 @@ begin
   inherited Create;
   FDispatch := ADispatch;
   FCaptionFont := TFont.Create;
+  FCaptionFont.OnChange := CaptionFontChange;
   FHotTrackBrightnessChange := 20;
   FStyle := psRectangleEtched;
   Reset;
@@ -534,6 +547,12 @@ begin
     raise AssignException.create('TSpkPaneAppearance.Assign: Nie mogê przypisaæ obiektu '+Source.ClassName+' do TSpkPaneAppearance!');
 end;
 
+procedure TSpkPaneAppearance.CaptionFontChange(Sender: TObject);
+begin
+  if FDispatch <> nil then
+    FDispatch.NotifyAppearanceChanged;
+end;
+
 procedure TSpkPaneAppearance.LoadFromXML(Node: TSpkXMLNode);
 var
   Subnode: TSpkXMLNode;
@@ -765,6 +784,7 @@ begin
   inherited Create;
   FDispatch := ADispatch;
   FCaptionFont := TFont.Create;
+  FCaptionFont.OnChange := CaptionFontChange;
   FHotTrackBrightnessChange := 40;
   Reset;
 end;
@@ -814,6 +834,12 @@ begin
     raise AssignException.create('TSpkElementAppearance.Assign: Nie mogê przypisaæ obiektu '+Source.ClassName+' do TSpkElementAppearance!');
 end;
 
+procedure TSpkElementAppearance.CaptionFontChange(Sender: TObject);
+begin
+  if FDispatch <> nil then
+    FDispatch.NotifyAppearanceChanged;
+end;
+
 procedure TSpkElementAppearance.GetActiveColors(IsChecked: Boolean;
   out AFrameColor, AInnerLightColor, AInnerDarkColor, AGradientFromColor,
   AGradientToColor: TColor; out AGradientKind: TBackgroundKind;

components/spktoolbar/SpkToolbar/spkt_Const.pas

@@ -14,9 +14,13 @@ unit spkt_Const;
 
 interface
 
+uses
+  Graphics;
+
 procedure SpkInitLayoutConsts(FromDPI: Integer; ToDPI: Integer = 0);
 function SpkScaleX(Size: Integer; FromDPI: Integer; ToDPI: Integer = 0): integer;
 function SpkScaleY(Size: Integer; FromDPI: Integer; ToDPI: Integer = 0): integer;
+procedure SpkScaleFont(AFont: TFont; ToDPI: Integer = 0);
 
 const
   // ****************
@@ -262,7 +266,7 @@ const
 implementation
 
 uses
-  Graphics, LCLType;
+  LCLType;
 
 procedure SpkInitLayoutConsts(FromDPI: Integer; ToDPI: Integer = 0);
 begin
@@ -383,6 +387,25 @@ begin
 
 end;
 
+procedure SpkScaleFont(AFont: TFont; ToDPI: Integer = 0);
+var
+  FromDPI: Integer;
+begin
+  if ToDPI = 0 then
+    ToDPI := ScreenInfo.PixelsPerInchY;
+
+  FromDPI := AFont.PixelsPerInch;
+
+  if (not DPI_AWARE) or (ToDPI = FromDPI) then
+    exit;
+
+  if AFont.Size = 0 then
+    AFont.Height := MulDiv(GetFontData(AFont.Reference.Handle).Height, FromDPI, ToDPI)
+  else
+    AFont.Height := MulDiv(AFont.Height, FromDPI, ToDPI);
+  AFont.PixelsPerInch := ToDPI;
+end;
+
 
 initialization
 

components/spktoolbar/designtime/SpkToolbarEditor.pas

@@ -261,43 +261,40 @@ implementation
 { TSpkToolbarEditor }
 
 procedure TSpkToolbarEditor.DoOpenContentsEditor;
-
 var
-  Component : TComponent;
+  Component: TComponent;
-
 begin
-Component:=self.GetComponent;
+  Component:=self.GetComponent;
+  if not(Component is TSpkToolbar) then
+    exit;
 
-if not(Component is TSpkToolbar) then
+  EditWindow.SetData(TSpkToolbar(Component),Self.GetDesigner);
-   exit;
+  EditWindow.Show;
-
-EditWindow.SetData(TSpkToolbar(Component),Self.GetDesigner);
-EditWindow.Show;
 end;
 
 procedure TSpkToolbarEditor.Edit;
 
 begin
-DoOpenContentsEditor;
+  DoOpenContentsEditor;
 end;
 
 procedure TSpkToolbarEditor.ExecuteVerb(Index: Integer);
 begin
-case Index of
+  case Index of
-     0 : DoOpenContentsEditor;
+    0 : DoOpenContentsEditor;
-end;
+  end;
 end;
 
 function TSpkToolbarEditor.GetVerb(Index: Integer): string;
 begin
-case Index of
+  case Index of
-     0 : result:='Contents editor...';
+    0 : result:='Contents editor...';
-end;
+  end;
 end;
 
 function TSpkToolbarEditor.GetVerbCount: Integer;
 begin
-result:=1;
+  Result := 1;
 end;
 
 { TSpkToolbarCaptionEditor }
@@ -325,48 +322,47 @@ end;
 { TSpkToolbarAppearanceEditor }
 
 procedure TSpkToolbarAppearanceEditor.Edit;
-
+var
-var Obj : TObject;
+  Obj: TObject;
-    Toolbar : TSpkToolbar;
+  Toolbar: TSpkToolbar;
-    Tab : TSpkTab;
+  Tab: TSpkTab;
-    AppearanceEditor : tfrmAppearanceEditWindow;
+  AppearanceEditor: tfrmAppearanceEditWindow;
-
 begin
-Obj:=GetComponent(0);
+  Obj:=GetComponent(0);
-if Obj is TSpkToolbar then
+  if Obj is TSpkToolbar then
-   begin
+  begin
-   Toolbar:=TSpkToolbar(Obj);
+    Toolbar := TSpkToolbar(Obj);
 
-   AppearanceEditor:=TfrmAppearanceEditWindow.Create(nil);
+    AppearanceEditor:=TfrmAppearanceEditWindow.Create(nil);
-   try
+    try
-     AppearanceEditor.Appearance.Assign(Toolbar.Appearance);
+      AppearanceEditor.Appearance.Assign(Toolbar.Appearance);
-     if AppearanceEditor.ShowModal = mrOK then
+      if AppearanceEditor.ShowModal = mrOK then
-        begin
+      begin
         Toolbar.Appearance.Assign(AppearanceEditor.Appearance);
         Modified;
-        end;
+      end;
-   finally
+    finally
-     AppearanceEditor.Free;
+      AppearanceEditor.Free;
-   end;
+    end;
 
-   end else
+  end else
-if Obj is TSpkTab then
+    if Obj is TSpkTab then
-   begin
+    begin
-   Tab:=TSpkTab(Obj);
+      Tab:=TSpkTab(Obj);
 
-   AppearanceEditor:=TfrmAppearanceEditWindow.Create(nil);
+      AppearanceEditor:=TfrmAppearanceEditWindow.Create(nil);
-   try
+      try
-     AppearanceEditor.Appearance.Assign(Tab.CustomAppearance);
+        AppearanceEditor.Appearance.Assign(Tab.CustomAppearance);
-     if AppearanceEditor.ShowModal = mrOK then
+        if AppearanceEditor.ShowModal = mrOK then
         begin
-        Tab.CustomAppearance.Assign(AppearanceEditor.Appearance);
+          Tab.CustomAppearance.Assign(AppearanceEditor.Appearance);
-        Modified;
+          Modified;
         end;
-   finally
+      finally
-     AppearanceEditor.Free;
+        AppearanceEditor.Free;
-   end;
+      end;
 
-   end;
+    end;
 end;
 
 function TSpkToolbarAppearanceEditor.GetAttributes: TPropertyAttributes;

components/spktoolbar/designtime/spkte_AppearanceEditor.pas

@@ -207,6 +207,7 @@ type
     procedure bTabGradientToColorClick(Sender: TObject);
     procedure bActiveTabHeaderFontColorClick(Sender: TObject);
     procedure bCopyToClipboardClick(Sender: TObject);
+
     procedure cbItemActiveGradientKindChange(Sender: TObject);
     procedure cbItemHottrackGradientKindChange(Sender: TObject);
     procedure cbItemIdleGradientKindChange(Sender: TObject);