The Road to Delphi

Delphi – Free Pascal – Oxygene


17 Comments

VCL Styles Utils Project – New Addition : Patch for System colors.

Introduction

A result of the work in a new sub project of the VCL Styles Utils , many new features as been added to the library, One of my favorites is a patch for the GetSysColor WinApi function. This fix replace the original call to this function by a jump to the StyleServices.GetSystemColor method replacing the original system colors by the current VCL Style colors. One of the advantages of use this fix is which the controls uses the proper VCL Style highlight color.

Screenshots

Check these controls with the VCL Styles

full

Now using the Vcl.Styles.Hooks unit

Full_Fix

TColorBox

ColorBox ColorBox_Fix

Source Code

This is the actual source code of the Vcl.Styles.Hooks unit which includes the patch to the GetSysColor function. To use this unit in your code you must add the KOLDetours unit too.

unit Vcl.Styles.Hooks;

interface

implementation

uses
  KOLDetours,
  WinApi.Windows,
  Vcl.Styles,
  Vcl.Themes;

var
  TrampolineGetSysColor:  function (nIndex: Integer): DWORD; stdcall;
  GetSysColorOrgPointer : Pointer = nil;

function InterceptGetSysColor(nIndex: Integer): DWORD; stdcall;
begin
  if StyleServices.IsSystemStyle then
   Result:= TrampolineGetSysColor(nIndex)
  else
   Result:= StyleServices.GetSystemColor(nIndex or Integer($FF000000));
end;

initialization
 if StyleServices.Available then
 begin
   GetSysColorOrgPointer  := GetProcAddress(GetModuleHandle('user32.dll'), 'GetSysColor');
   @TrampolineGetSysColor := InterceptCreate(GetSysColorOrgPointer, @InterceptGetSysColor);
 end;
finalization
 if GetSysColorOrgPointer<>nil then
  InterceptRemove(@TrampolineGetSysColor, @InterceptGetSysColor);

end.


2 Comments

Vcl Styles Utils updated to fix QC #114040, #114032 (XE2 and XE3)

I just commit in the Vcl Styles Project two new fixes to patch the QC 114040 and QC 114032 (these issues exist in Delphi XE2 and XE3), both reports are related to the Highlight colors used to draw the TColorBox and TComboBoxEx components when the Vcl Styles are active.

QC 114032

As you can see in the below image the TColorBox component doesn’t use the proper highlight color, but the TColorListBox uses the highlight color of the current Vcl Style.

TColorBoxQC

The TColorBox control doesn’t use a Style Hook, so the fix was done using a interposer class. To apply the path just add the Vcl.Styles.Fixes unit to your uses list after of the Vcl.ExtCtrls unit. And the result will be

TColorBoxFix

QC 114040

The TComboBoxEx control have a similar issue.

TcomboboxExQc

In this case fixing the Style Hook related to the TComboBoxEx control was the key.

TcomboboxExFix

To apply this fix, just register the TComboBoxExStyleHookFix style hook located in the Vcl.Styles.Fixes unit.


4 Comments

Added new vcl style hook to the Vcl Styles Utils to fix QC #108678, #108875 (XE2 and XE3)

I just added a new vcl style hook (TListViewStyleHookFix) for the TListView component in the Vcl Styles Utils project to fix the QC #108678, #108875 (XE2 and XE3)

The issue reported in both reports, is that the images are not displayed in the TListView header with the VCL Styles enabled.

When you uses the Windows Theme in a TListView with images in the header will look like so

LVWindows

But if you enable the Vcl Styles, the images in the header are lost.

LVStyles2

The issue is located in the TListViewStyleHook.DrawHeaderSection method, this method must paint the image and text of each section of the header of the ListView.

This is part of the code with the bug

  ...
  ...
  ImageList := SendMessage(Handle, HDM_GETIMAGELIST, 0, 0);
  Item.Mask := HDI_FORMAT or HDI_IMAGE;
  InflateRect(R, -2, -2);
  if (ImageList <> 0) and Header_GetItem(Handle, Index, Item) then
  begin
    if Item.fmt and HDF_IMAGE = HDF_IMAGE then
      ImageList_Draw(ImageList, Item.iImage, Canvas.Handle, R.Left, R.Top, ILD_TRANSPARENT);
    ImageList_GetIconSize(ImageList, IconWidth, IconHeight);
    Inc(R.Left, IconWidth + 5);
  end;
  ...
  ...

The problem with the above code is that the SendMessage function with the HDM_GETIMAGELIST message (which is used to get the current imagelist) is not using the proper Handle. The above code is passing the handle of the ListView, but must pass the handle of the Header control, the same applies to the call to the Header_GetItem method.

The TListViewStyleHookFix introduces a new DrawHeaderSection method which passes the handle of the header control and fix the issue. You can use this Stylehook adding Vcl.Styles.Fixes unit to you uses clause and then register the hook on this way.

initialization
   TStyleManager.Engine.RegisterStyleHook(TListView, TListViewStyleHookFix);

LVStylesFix


2 Comments

How customize the fonts of a TActionMainMenuBar and TPopupActionBar with the VCL Styles Enabled

This week I received two emails from different Delphi developers asking about : How customize the fonts of a TActionMainMenuBar and TPopupActionBar with the Vcl Styles Enabled? Also a question about the same topic was asked in StackOverflow.

This post shows how this task can be done.

In order to change the font and size of a TActionMainMenuBar and a TPopupActionBar in a VCL application you must use the Screen.MenuFont property like so.

  Screen.MenuFont.Name := 'Impact';
  Screen.MenuFont.Size := 12;

But if the Vcl Styles are enabled these changes are not reflected (This is because the Vcl Styles uses the fonts defined in style file).

Now if you want change the font type or font size of the Vcl Styles elements related to the menus like MenuItemTextNormal, MenuItemTextHot and so on, you will use the Style Designer and set font values which you want.

But unfortunately this will not work either, I mean even if you edit the fonts of the Vcl Style file, the changes are not reflected in the Menus components (or others controls). The reason for this is that the Vcl Styles Engine ignores the fonts types and font size defined in the style file. and just use the font color value to draw the text of the controls.

Note : The font used by the Vcl Styles is Tahoma and the Size is 8.

So what is the solution for customize the font of a TActionMainMenuBar component? A possible workaround is create a new Action Bar Style and also create a new TCustomMenuItem and TCustomMenuButton to override the DrawText method and draw your self the menu text using the Screen.MenuFont values, the good news are which since now, you can find a implementation of a new Action Bar Style in the <a href="https://github.com/RRUZ/vcl-styles-utils/blob/master/Common/Vcl.PlatformVclStylesActnCtrls.pas unit (which is part of the VCL Styles Utils project) which allows you to modify the font of the TActionMainMenuBar and TPopupActionBar components.

So to use this new Action Bar Style, just add the Vcl.PlatformVclStylesActnCtrls unit to your project and then assign the new style to your Action Manager like so :

  ActionManager1.Style:=PlatformVclStylesStyle;

And now when you run your app the TActionMainMenuBar and TPopupActionBar will use the font defined in the Screen.MenuFont property.


6 Comments

Using custom colors in the TDBGrid columns with vcl styles enabled

The TDBGrid component allows you to customize the colors of the columns and fonts used to draw the data.

Unfortunately if you uses the vcl styles all these customizations are lost

This issue is caused because the TCustomDBGrid.DrawCell method ignores the custom colors of the columns when the vcl styles are enabled. So the solution is patch this method to allow use the proper colors. After of this you will get a result like so.

I just uploaded this patch as part of the vcl styles utils project. To use it you must add the Vcl.Styles.DbGrid unit to the uses part of your form after of the Vcl.DBGrids unit.


2 Comments

Added new unit to the vcl style utils to fix the QC #103708, #107764 reports

I just uploaded a new unit to the vcl style utils project called Vcl.Styles.Fixes, this unit contains the TButtonStyleHook style hook which fix these QC #103708, #107764 reports for Delphi XE2.

Note : The QC #103708 still exist in Delphi XE2 Update 4, even if appears as resolved (XE3 maybe?)


13 Comments

Creating colorful tabsheets with the VCL Styles


Introduction

Until now if you want change the color of a TTabSheet in a VCL application you must create a new descendant class of the TTabSheet component, then handle the WM_ERASEBKGND message, set the TPageControl to OwnerDraw property to true and finally implement the OnDrawTab event. And after that you will have an awfull and un-themed TPageControl.

In this post I will show you how using the vcl styles you can gain full control over to paint methods with very nice results.

The TTabSheet

To customize the colors of the TabSheets of a TPageControl we need to handle the WM_ERASEBKGND message of the TTabsheet and create a new Vcl Style Hook. For the first part we can use a interposer class like so

type
  TTabSheet = class(Vcl.ComCtrls.TTabSheet)
  private
    procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
  end;

And then in the implementation of the WMEraseBkgnd method

{ TTabSheet }
procedure TTabSheet.WMEraseBkgnd(var Message: TWMEraseBkgnd);
var
  LRect  : TRect;
  LSize  : Integer;
  LCanvas: TCanvas;
begin
  if (PageControl <> nil) and StyleServices.Enabled and
     ((PageControl.Style = tsTabs) or TStyleManager.IsCustomStyleActive) then
  begin
    //Get the bounds of the Tabsheet
    GetWindowRect(Handle, LRect);
    OffsetRect(LRect, -LRect.Left, -LRect.Top);
    //Get the size of the border
    LSize := ClientToParent(Point(0, 0)).X;
    InflateRect(LRect, LSize, LSize); // remove the border
    //create a TCanvas for erase the background, using the DC of the message
    LCanvas := TCanvas.Create;
    try
      LCanvas.Handle := Message.DC;
      LCanvas.Brush.Color:=GetColorTab(TabIndex);
      LCanvas.FillRect(LRect);
    finally
      LCanvas.Handle := 0;
      LCanvas.Free;
    end;

    Message.Result := 1;
    //the call to this method produces which the Style hook paint the active tabsheet
    PageControl.UpdateTab2(PageControl.ActivePage);
  end
  else
    inherited;
end;

In the above code you can note a call to the methods GetColorTab and PageControl.UpdateTab2

The GetColorTab is a simple function which return a color based in the index of the tab (you an modify the colors returned as you want)

function GetColorTab(Index : Integer) : TColor;
Const
  MaxColors =9;
  //this is a sample palette of colors 
  Colors : Array [0..MaxColors-1] of TColor = (6512214,16755712,8355381,1085522,115885,1098495,1735163,2248434,4987610);
begin
  Result:=Colors[Index mod MaxColors];
end;

The PageControl.UpdateTab2 is part of a helper class to execute the private method TPageControl.UpdateTab and is just a trick used to inform to vcl style that need paint the active tabsheet.

type
  TPageControlHelper = class helper for TPageControl
  public
    procedure UpdateTab2(Page: Vcl.ComCtrls.TTabSheet);
  end;

procedure TPageControlHelper.UpdateTab2(Page: Vcl.ComCtrls.TTabSheet);
begin
  Self.UpdateTab(Page);
end;

The Vcl style hook

Now the second part is implement the style hook using the existing TTabControlStyleHook as base class, so in this way we only need override 3 methods (PaintBackground, Paint and DrawTab) and handle the WM_ERASEBKGND message again.

Take a look to the declaration of the new vcl style hook

  TTabColorControlStyleHook= class(TTabControlStyleHook)
  private
    procedure WMEraseBkgnd(var Message: TMessage); message WM_ERASEBKGND;
  protected
    procedure PaintBackground(Canvas: TCanvas); override;
    procedure Paint(Canvas: TCanvas); override;
    procedure DrawTab(Canvas: TCanvas; Index: Integer); override;
  end;

Before we handle the WM_ERASEBKGND message of the TTabsheet, now we need do the same but for the style hook, because the style hook (TStyleHook) has their own messages handle routine.

procedure TTabColorControlStyleHook.WMEraseBkgnd(var Message: TMessage);
var
  LCanvas : TCanvas;
begin
  if (Message.LParam = 1) and StyleServices.Available then
  begin
    //create a Local canvas based in the HDC returned in the Message.WParam
    LCanvas := TCanvas.Create;
    try
      LCanvas.Handle := HDC(Message.WParam);
      //get the color
      LCanvas.Brush.Color:=GetColorTab(TabIndex);
      //apply the color
      LCanvas.FillRect(Control.ClientRect);
    finally
      LCanvas.Handle := 0;
      LCanvas.Free;
    end;
  end;
  Message.Result := 1;
  Handled := True;
end;

Following the implementation of the vcl style hook, this is the implementation of the PaintBackground method.

procedure TTabColorControlStyleHook.PaintBackground(Canvas: TCanvas);
var
  LColor : TColor;
begin
  if StyleServices.Available then
  begin
    //get the background color
    LColor:=StyleServices.GetSystemColor(clWindowFrame);
    Canvas.Brush.Color:=LColor;
    Canvas.FillRect(Control.ClientRect);
  end;
end;

Now the code for the Paint method, this procedure paint the body of the tabsheet and draw the child controls.

procedure TTabColorControlStyleHook.Paint(Canvas: TCanvas);
var
  LRect  : TRect;
  LIndex : Integer;
  SavedDC: Integer;
begin
  SavedDC := SaveDC(Canvas.Handle);
  try
    LRect := DisplayRect;
    ExcludeClipRect(Canvas.Handle, LRect.Left, LRect.Top, LRect.Right, LRect.Bottom);
    PaintBackground(Canvas);
  finally
    RestoreDC(Canvas.Handle, SavedDC);
  end;

  // Update the state of the tabs, except the active
  for LIndex := 0 to TabCount - 1 do
  begin
    if LIndex = TabIndex then
      Continue;
    DrawTab(Canvas, LIndex);
  end;

  //modify the bounds of the body to paint, based in the postion of the tab
  case TabPosition of
    tpTop   : InflateRect(LRect, Control.Width - LRect.Right, Control.Height - LRect.Bottom);
    tpLeft  : InflateRect(LRect, Control.Width - LRect.Right, Control.Height - LRect.Bottom);
    tpBottom: InflateRect(LRect, LRect.Left, LRect.Top);
    tpRight : InflateRect(LRect, LRect.Left, LRect.Top);
  end;

  //Paint the body of the tabsheet
  if StyleServices.Available then
  begin
    Canvas.Brush.Color:=GetColorTab(TabIndex);
    Canvas.FillRect(LRect);
  end;

  // Draw the active tab
  if TabIndex >= 0 then
    DrawTab(Canvas, TabIndex);

  // paint the controls of the tab
  TWinControlClass(Control).PaintControls(Canvas.Handle, nil);
end;

We’re almost done the job, now we just need to implement the code for draw the Tab. Check the next full commented code

procedure TTabColorControlStyleHook.DrawTab(Canvas: TCanvas; Index: Integer);
var
  LDetails    : TThemedElementDetails;
  LImageIndex : Integer;
  LThemedTab  : TThemedTab;
  LIconRect   : TRect;
  R, LayoutR  : TRect;
  LImageW, LImageH, DxImage : Integer;
  LTextX, LTextY: Integer;
  LTextColor    : TColor;
    //draw the text in the tab
    procedure DrawControlText(const S: string; var R: TRect; Flags: Cardinal);
    var
      TextFormat: TTextFormatFlags;
    begin
      Canvas.Font       := TWinControlClass(Control).Font; //the TWinControlClass is a just a crack class for the TWinControl to access the protected members
      TextFormat        := TTextFormatFlags(Flags);
      Canvas.Font.Color := LTextColor;    
      StyleServices.DrawText(Canvas.Handle, LDetails, S, R, TextFormat, Canvas.Font.Color);
    end;

begin
  //get the size of tab image (icon)
  if (Images <> nil) and (Index < Images.Count) then
  begin
    LImageW := Images.Width;
    LImageH := Images.Height;
    DxImage := 3;
  end
  else
  begin
    LImageW := 0;
    LImageH := 0;
    DxImage := 0;
  end;

  R := TabRect[Index];
  //check the left position of the tab , because can be hide 
  if R.Left < 0 then Exit;

  //adjust the size of the tab to draw
  if TabPosition in [tpTop, tpBottom] then
  begin
    if Index = TabIndex then
      InflateRect(R, 0, 2);
  end
  else 
  if Index = TabIndex then
    Dec(R.Left, 2) 
  else 
    Dec(R.Right, 2);

  
  Canvas.Font.Assign(TCustomTabControlClass(Control).Font);//the TCustomTabControlClass is another crack class to access the protected font property
  LayoutR := R;
  LThemedTab := ttTabDontCare;
  //Get the type of the active tab to draw
  case TabPosition of
    tpTop:
      begin
        if Index = TabIndex then
          LThemedTab := ttTabItemSelected
        else 
        if (Index = HotTabIndex) and MouseInControl then
          LThemedTab := ttTabItemHot
        else
          LThemedTab := ttTabItemNormal;
      end;
    tpLeft:
      begin
        if Index = TabIndex then
          LThemedTab := ttTabItemLeftEdgeSelected
        else 
        if (Index = HotTabIndex) and MouseInControl then
          LThemedTab := ttTabItemLeftEdgeHot
        else
          LThemedTab := ttTabItemLeftEdgeNormal;
      end;
    tpBottom:
      begin
        if Index = TabIndex then
          LThemedTab := ttTabItemBothEdgeSelected
        else 
        if (Index = HotTabIndex) and MouseInControl then
          LThemedTab := ttTabItemBothEdgeHot
        else
          LThemedTab := ttTabItemBothEdgeNormal;
      end;
    tpRight:
      begin
        if Index = TabIndex then
          LThemedTab := ttTabItemRightEdgeSelected
        else 
        if (Index = HotTabIndex) and MouseInControl then
          LThemedTab := ttTabItemRightEdgeHot
        else
          LThemedTab := ttTabItemRightEdgeNormal;
      end;
  end;

  //draw the tab
  if StyleServices.Available then
  begin
    LDetails := StyleServices.GetElementDetails(LThemedTab);//necesary for DrawControlText and draw the icon
    InflateRect(R,-1,0);//adjust the size of the tab creating a blank space between the tabs
    Canvas.Brush.Color:=GetColorTab(Index);//get the color 
    Canvas.FillRect(R);
  end;

  //get the index of the image (icon)
  if Control is TCustomTabControl then
    LImageIndex := TCustomTabControlClass(Control).GetImageIndex(Index)
  else
    LImageIndex := Index;

  //draw the image
  if (Images <> nil) and (LImageIndex >= 0) and (LImageIndex < Images.Count) then
  begin
    LIconRect := LayoutR;
    case TabPosition of
      tpTop, tpBottom:
        begin
          LIconRect.Left := LIconRect.Left + DxImage;
          LIconRect.Right := LIconRect.Left + LImageW;
          LayoutR.Left := LIconRect.Right;
          LIconRect.Top := LIconRect.Top + (LIconRect.Bottom - LIconRect.Top) div 2 - LImageH div 2;
          if (TabPosition = tpTop) and (Index = TabIndex) then
            OffsetRect(LIconRect, 0, -1)
          else
          if (TabPosition = tpBottom) and (Index = TabIndex) then
            OffsetRect(LIconRect, 0, 1);
        end;
      tpLeft:
        begin
          LIconRect.Bottom := LIconRect.Bottom - DxImage;
          LIconRect.Top := LIconRect.Bottom - LImageH;
          LayoutR.Bottom := LIconRect.Top;
          LIconRect.Left := LIconRect.Left + (LIconRect.Right - LIconRect.Left) div 2 - LImageW div 2;
        end;
      tpRight:
        begin
          LIconRect.Top := LIconRect.Top + DxImage;
          LIconRect.Bottom := LIconRect.Top + LImageH;
          LayoutR.Top := LIconRect.Bottom;
          LIconRect.Left := LIconRect.Left + (LIconRect.Right - LIconRect.Left) div 2 - LImageW div 2;
        end;
    end;
    if StyleServices.Available then
      StyleServices.DrawIcon(Canvas.Handle, LDetails, LIconRect, Images.Handle, LImageIndex);
  end;

  //draw the text of the tab
  if StyleServices.Available then
  begin
    LTextColor:=GetColorTextTab(LThemedTab);//this is a helper function which get the  text color of the tab based in his current state (normal, select, hot).

    if (TabPosition = tpTop) and (Index = TabIndex) then
      OffsetRect(LayoutR, 0, -1)
    else
    if (TabPosition = tpBottom) and (Index = TabIndex) then
      OffsetRect(LayoutR, 0, 1);

    if TabPosition = tpLeft then
    begin
      LTextX := LayoutR.Left + (LayoutR.Right - LayoutR.Left) div 2 - Canvas.TextHeight(Tabs[Index]) div 2;
      LTextY := LayoutR.Top + (LayoutR.Bottom - LayoutR.Top) div 2 + Canvas.TextWidth(Tabs[Index]) div 2;
      Canvas.Font.Color := LTextColor;
      AngleTextOut2(Canvas, 90, LTextX, LTextY, Tabs[Index]);
    end
    else
    if TabPosition = tpRight then
    begin
      LTextX := LayoutR.Left + (LayoutR.Right - LayoutR.Left) div 2 + Canvas.TextHeight(Tabs[Index]) div 2;
      LTextY := LayoutR.Top + (LayoutR.Bottom - LayoutR.Top) div 2 - Canvas.TextWidth(Tabs[Index]) div 2;
      Canvas.Font.Color := LTextColor;
      AngleTextOut2(Canvas, -90, LTextX, LTextY, Tabs[Index]);
    end
    else
     DrawControlText(Tabs[Index], LayoutR, DT_VCENTER or DT_CENTER or DT_SINGLELINE  or DT_NOCLIP);
  end;
end;

The final result

Ok, that was a lot of code, now this is the final result

To use this style hook you must include the Vcl.Styles.ColorTabs unit in your uses class after of the Vcl.ComCtrls unit and then register the hook in this way.

  TCustomStyleEngine.RegisterStyleHook(TCustomTabControl, TTabColorControlStyleHook);
  TCustomStyleEngine.RegisterStyleHook(TTabControl, TTabColorControlStyleHook);

The full source code of this style hook is located in the vcl style utils repository.