The Road to Delphi – a Blog about programming

Delphi – Free Pascal – Oxygene


8 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.


4 Comments

How obtain the source of the WMI Data

We normally use the WMI to either return information about software and hardware installed, but you probably ever wondered from where this data is obtained?. Well the answer is, this data is obtained from many sources like the WinApi, the Windows Registry, the SMBIOS or custom functions embedded inside of the MOF definition.

WMI Metadata

All the WMI classes have a very rich set of metadata which defines the properties names, data types, descriptions and also each class and property have a special type of attribute called qualifiers which contain addtional metadata information about the WMI element ,within these qualifiers there is one called MappingStrings.

The MSDN documentation about this qualifier states

MappingStrings : Set of values that indicate a path to a location where you can find more information about the origin of a property, class, association, indication, or reference. The mapping string can be a directory path, a URL, a registry key, an include file, reference to a CIM class, or some other format.

This means that by analyzing the content of the MappingStrings qualifier you can determine the source of the data or obtain extra information about this property. Let me explain with a sample. The Win32_DiskDrive WMI class provides information about the physical disks present in the system like Bytes Per Sector, Firmware Revision, Interface Type (SCSI, IDE, USB) and so on. Now if you analize the MappingStrings qualifier of these properties you can determine where is located the information of the disks in the system.

The Code

Check the next function to access the MappingStrings qualifier (if exist) from any WMI class.

{$APPTYPE CONSOLE}

uses
  SysUtils,
  ActiveX,
  ComObj,
  Variants;

procedure  GetWmiPropsSources(Const NameSpace, ClassName: string);
const
  wbemFlagUseAmendedQualifiers = $00020000;
Var
  Properties        : OleVariant;
  Qualifiers        : OleVariant;
  rgvarProp         : OleVariant;
  rgvarQualif       : OleVariant;
  objSWbemLocator   : OleVariant;
  objSWbemObjectSet : OleVariant;
  objWMIService     : OleVariant;
  EnumProps         : IEnumVariant;
  EnumQualif        : IEnumVariant;
  pceltFetched      : Cardinal;
  Lindex            : Integer;
begin
    //create the WMI Scripting object
    objSWbemLocator  := CreateOleObject('WbemScripting.SWbemLocator');
    //connect to the WMi service on the local mahicne
    objWMIService    := objSWbemLocator.ConnectServer('localhost', NameSpace, '', '');
    //get the metadata of the WMI class
    objSWbemObjectSet:= objWMIService.Get(ClassName, wbemFlagUseAmendedQualifiers);
    //get a pointer to the properties
    Properties := objSWbemObjectSet.Properties_;
    //get an enumerator to the properties
    EnumProps         := IUnknown(Properties._NewEnum) as IEnumVariant;
    //iterate over the properties
    while EnumProps.Next(1, rgvarProp, pceltFetched) = 0 do
    begin
      //get a pointer to the qualifiers of the current property
      Qualifiers      := rgvarProp.Qualifiers_;
      //get an enumerator to the qualifiers
      EnumQualif     := IUnknown(Qualifiers._NewEnum) as IEnumVariant;
      //iterate over the qualifiers
      while EnumQualif.Next(1, rgvarQualif, pceltFetched) = 0 do
      begin
        //check the name of the qualifier
        if SameText('MappingStrings',rgvarQualif.Name) then
        begin
           Writeln(rgvarProp.Name);
           //write the value of the qualifier
           if not VarIsNull(rgvarQualif.Value) and  VarIsArray(rgvarQualif.Value) then
            for Lindex := VarArrayLowBound(rgvarQualif.Value, 1) to VarArrayHighBound(rgvarQualif.Value, 1) do
              Writeln(Format('  %s',[String(rgvarQualif.Value[Lindex])]));
        end;
        rgvarQualif:=Unassigned;
      end;
      rgvarProp:=Unassigned;
    end;
end;


begin
 try
    CoInitialize(nil);
    try
      GetWmiPropsSources('root\cimv2', 'Win32_DiskDrive');
    finally
      CoUninitialize;
    end;
 except
    on E:EOleException do
        Writeln(Format('EOleException %s %x', [E.Message,E.ErrorCode]));
    on E:Exception do
        Writeln(E.Classname, ':', E.Message);
 end;
 Writeln('Press Enter to exit');
 Readln;
end.

After of execute the above code you will get a result like this

Availability
  MIF.DMTF|Operational State|003.5
  MIB.IETF|HOST-RESOURCES-MIB.hrDeviceStatus
BytesPerSector
  Win32API|Device Input and Output Structures|DISK_GEOMETRY|BytesPerSector
Capabilities
  MIF.DMTF|Storage Devices|001.9
  MIF.DMTF|Storage Devices|001.11
  MIF.DMTF|Storage Devices|001.12
  MIF.DMTF|Disks|003.7
DeviceID
  WMI
FirmwareRevision
  Win32API|Device Input and Output Structures|STORAGE_DEVICE_DESCRIPTOR|ProductRevisionOffset
Index
  Win32API|Windows 95/98 Functions|DRIVE_MAP_INFObtInt13Unit
InstallDate
  MIF.DMTF|ComponentID|001.5
InterfaceType
  Win32API|Device Input and Output Functions|DeviceIoControl
Manufacturer
  Win32Registry|HKEY_LOCAL_MACHINE\HARDWARE\DEVICEMAP\Scsi\Scsi Port\Scsi Bus\Target Id\Logical Unit
 Id\Identifier
  Win32Registry|Manufacturer
MaxMediaSize
  MIF.DMTF|Sequential Access Devices|001.2
MediaLoaded
  Win32API|Device Input and Output Structures|DISK_GEOMETRY|MediaType|FixedMedia
MediaType
  Win32API|Device Input and Output Structures|DISK_GEOMETRY|MediaType
Model
  Win32Registry|HKEY_LOCAL_MACHINE\HARDWARE\DEVICEMAP\Scsi\Scsi Port\Scsi Bus\Target Id\Logical Unit
 Id\Identifier
  Win32Registry|ProductId
Partitions
  Win32API|Device Input and Output Structures|PARTITION_INFORMATION|RecognizedPartition
SCSIBus
  Win32API|Device Input and Output Structures|SCSI_ADDRESS|PathId
SCSILogicalUnit
  Win32API|Device Input and Output Structures|SCSI_ADDRESS|Lun
SCSIPort
  Win32API|Device Input and Output Structures|SCSI_ADDRESS|PortNumber
SCSITargetId
  Win32API|Device Input and Output Structures|SCSI_ADDRESS|TargetId
SectorsPerTrack
  Win32API|Device Input and Output Structures|DISK_GEOMETRY|SectorsPerTrack
SerialNumber
  Win32API|Device Input and Output Structures|STORAGE_DEVICE_DESCRIPTOR|SerialNumberOffset
Signature
  Win32API|Device Input and Output Structures|DRIVE_LAYOUT_INFORMATION|Signature
Size
  Win32API|Device Input and Output Structures|DISK_GEOMETRY
StatusInfo
  MIF.DMTF|Operational State|003.3
TotalCylinders
  Win32API|Device Input and Output Structures|DISK_GEOMETRY|Cylinders
TotalHeads
  Win32API|Device Input and Output Structures|DISK_GEOMETRY|TracksPerCylinder
TotalSectors
  Win32API|Device Input and Output Structures|DISK_GEOMETRY|SectorsPerTrack
TotalTracks
  Win32API|Device Input and Output Structures|DISK_GEOMETRY|TracksPerCylinder
TracksPerCylinder
  Win32API|Device Input and Output Structures|DISK_GEOMETRY|TracksPerCylinder

As you can see most of the properties of this class have a MappingStrings qualifier which shows the source (Win32API, Win32Registry, MIF.DMTF) of the data.

Finally if you are interested on this topic take a look to the WMI Delphi Code Creator which includes this feature.

Follow

Get every new post delivered to your Inbox.

Join 658 other followers