The Road to Delphi

Delphi – Free Pascal – Oxygene


13 Comments

VCL Styles Utils, Embarcadero Agreement and Delphi XE6

Embarcadero Agreement

As probably you know, a small part of the VCL Styles utils project was licensed to Embarcadero, via a non-exclusive proprietary license. This means which they can use, modify and distribute the code as part of the VCL, but the Copyright and the Open Source version of the project still belong us. So you can continue using this library in all the Delphi versions supported (XE2-XE6).

Delphi XE6

The VCL Styles utils was updated to support and avoid conflicts with Delphi XE6. Check the next image which show the Open Dialog styled using the New XE6 style Table Dark

Tabla_Dark_Open

Since now the main difference is that you can use the menu style hook which is included as part of the Delphi XE6 VCL Styles, or continue using the menu hook of the library, this is described in the Vcl.Styles.Utils.Menus unit.

{$DEFINE UseVCLStyleUtilsMenu}
{$IF CompilerVersion >= 27} // Use the XE6 menu syshooks by default
  {$UNDEF UseVCLStyleUtilsMenu} // comment this line if you want to use the VCL Styles Utils Menus Hooks instead
{$IFEND}

About the Styled Dialogs

Using the library is the only way to style the system dialogs, currently we support all the Common Dialog Box Types (Color, Find, Font, Open, Page Setup, Print, Replace, Save As).

Check the Common Dialogs styled using the Premium VCL Style Jet.

Jet

But not just the Common dialogs are styled, in fact any dialog (#32770 Class) which uses the windows common controls is supported (of course if the dialog had a owner draw control this cannot be styled). For an example take a look to the next images.

Prompt DataSource Dialog

output_sWoRA1

Select User Dialog

ObjectSelect_4

Note: Some dialogs cannot be styled, because uses the undocumented DirectUIHWND control, these include the new (introduced in windows Vista) Open and Save As dialog and the Task Dialogs

Rodrigo.


3 Comments

VCL Styles for NSIS

Important Update

The new location of this project is https://code.google.com/p/vcl-styles-plugins/

NSIS

The VCL Styles Utils project, now includes  a plugin (dll) to skin the installers created by NSIS (2.46 and 3.0). The current size of the plugin is about 1.6 mb, but when is included (and compressed) in the script only add ~550 Kb to the final installer.

output_A6NOFn

How to use it

To use the plugin in a NSIS installer you must call the LoadVCLStyle function passing the skin name in the .onInit function.

Function .onInit
  InitPluginsDir
  ;Get the skin file to use
  File /oname=$PLUGINSDIR\Amakrits.vsf "..\Styles\Amakrits.vsf"
  ;Load the skin using the LoadVCLStyle function
  NSISVCLStyles::LoadVCLStyle $PLUGINSDIR\Amakrits.vsf
FunctionEnd

To use the plugin in a NSIS Uninstaller you must call the LoadVCLStyle function passing the skin name in the un.onInit function.

Function un.onInit
  InitPluginsDir
  File /oname=$PLUGINSDIR\Amakrits.vsf "..\Styles\Amakrits.vsf"
  ;Load the skin using the LoadVCLStyle function
  NSISVCLStyles::LoadVCLStyle $PLUGINSDIR\Amakrits.vsf
FunctionEnd

For download and more info check the page of the plugin


26 Comments

VCL Styles Utils and Popup Menus – Major Update

As you probably know the VCL Styles doesn’t support  Popup menus, this means if you apply any VCL Style  to your VCL Application  the popup menus will remain with the Windows native look and feel  (exists some workarounds for this like use a TPopupActionBar  as described here, but this only works partially, and doesn’t support the child menus of a TMainMenu) Since Sometime ago the VCL Styles Utils project can help you to overcome this limitation adding support for VCL Styled Popup Menus.

Now we just uploaded a major update to the VCL Styles Utils project. This new version fix all the issues reported via mail and the issue page related the PopUp menus like support for  the Break property, Checkboxes,  Radio Items,  Default items and so on.

Sample images

TMainMenu with VCL Styles

1

TMainMenu with VCL Styles and VCL Styles Utils

2

Popup Menu with VCL Styles

3

Popup Menu with VCL Styles and VCL Styles Utils

4

Right to left Popup Menu with VCL Styles

5

Right to left Popup Menu with VCL Styles and VCL Styles Utils

6

System Menu with VCL Styles

7

System Menu with VCL Styles and VCL Styles Utils

8

To add support for VCL Styled Popup Menus in your Application only you must add these units to your project Vcl.Styles.Utils.Menus, Vcl.Styles.Utils.SysStyleHook and Vcl.Styles.Utils.SysControls.

You can download sample application from here and the source of the Application is here.


49 Comments

VCL Styles for Inno Setup

Introduction

As part of the VCL Styles Utils project, I made a plugin (dll) to skin the installers created by Inno setup. The current size of the plugin is about 1.6 mb, but when is included (and compressed) in the script only add ~490 Kb to the final installer.

output_qkRcra

How to use it

In order to use the plugin you must follow these steps

  1. Add the VclStylesinno.dll file to your inno setup script and the VCL Style file to use.
  2. Import the function LoadVCLStyleW for Unicode versions of Inno setup or the LoadVCLStyleA method for the Ansi version
  3. Import the function UnLoadVCLStyles
  4. In the InitializeSetup function extract the style to use and call the LoadVCLStyle method passing the name of the style file
  5. Finally in the DeinitializeSetup function call the UnLoadVCLStyles method.

Check the next sample script

[Files]
Source: ..\VclStylesinno.dll; DestDir: {app}; Flags: dontcopy
Source: ..\Styles\Amakrits.vsf; DestDir: {app}; Flags: dontcopy

[Code]
// Import the LoadVCLStyle function from VclStylesInno.DLL
procedure LoadVCLStyle(VClStyleFile: String); external 'LoadVCLStyleW@files:VclStylesInno.dll stdcall';
// Import the UnLoadVCLStyles function from VclStylesInno.DLL
procedure UnLoadVCLStyles; external 'UnLoadVCLStyles@files:VclStylesInno.dll stdcall';

function InitializeSetup(): Boolean;
begin
  ExtractTemporaryFile('Amakrits.vsf');
  LoadVCLStyle(ExpandConstant('{tmp}\Amakrits.vsf'));
  Result := True;
end;

procedure DeinitializeSetup();
begin
  UnLoadVCLStyles;
end;

TODO

  • Add support for TFolderTreeView and TStartMenuFolderTreeView components
  • Add support for themed controls in the TNewCheckBoxList component
  • Add support for the npbstMarquee style in the TNewProgressBar component

Source code and Installer

The source code and installer is available on Github.

As always all your comments and feedback is welcome.


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.


7 Comments

Using the Windows Firewall with Advanced Security scripting API and Delphi

firewallThese are a set of useful Delphi snippets to handle the Windows Firewall using the Advanced Security scripting.

Note : Some of the below samples requires elevation.

Adding a LAN Rule

{$APPTYPE CONSOLE}

uses
  SysUtils,
  ActiveX,
  ComObj;

//This code adds a LAN rule using the Microsoft Windows Firewall APIs.
Procedure AddLANRule;
Const
 NET_FW_IP_PROTOCOL_TCP = 6;
 NET_FW_ACTION_ALLOW = 1;
var
 CurrentProfiles : OleVariant;
 fwPolicy2       : OleVariant;
 RulesObject     : OleVariant;
 NewRule         : OleVariant;
begin
  // Create the FwPolicy2 object.
  fwPolicy2   := CreateOleObject('HNetCfg.FwPolicy2');
  RulesObject := fwPolicy2.Rules;
  CurrentProfiles := fwPolicy2.CurrentProfileTypes;

  //Create a Rule Object.
  NewRule := CreateOleObject('HNetCfg.FWRule');

  NewRule.Name := 'Per_InterfaceType_Rule';
  NewRule.Description := 'Allow incoming network traffic over port 2400 coming from LAN interface type';
  NewRule.Protocol := NET_FW_IP_PROTOCOL_TCP;
  NewRule.LocalPorts := 2300;
  NewRule.Interfacetypes := 'LAN';
  NewRule.Enabled := True;
  NewRule.Grouping := 'My Group';
  NewRule.Profiles := CurrentProfiles;
  NewRule.Action := NET_FW_ACTION_ALLOW;

  //Add a new rule
  RulesObject.Add(NewRule);
end;

begin
 try
    CoInitialize(nil);
    try
      AddLANRule;
    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.

Adding a Per Interface Rule

{$APPTYPE CONSOLE}

uses
  SysUtils,
  ActiveX,
  Variants,
  ComObj;

//This code that adds a per interface rule using the Microsoft Windows Firewall APIs.
Procedure AddPerInterfaceRule;
Const
 NET_FW_IP_PROTOCOL_TCP = 6;
 NET_FW_IP_PROTOCOL_UDP = 17;
 NET_FW_ACTION_ALLOW = 1;
var
 CurrentProfiles : OleVariant;
 fwPolicy2       : OleVariant;
 RulesObject     : OleVariant;
 NewRule         : OleVariant;
begin
  // Create the FwPolicy2 object.
  fwPolicy2   := CreateOleObject('HNetCfg.FwPolicy2');
  RulesObject := fwPolicy2.Rules;
  CurrentProfiles := fwPolicy2.CurrentProfileTypes;

  //Create a Rule Object.
  NewRule := CreateOleObject('HNetCfg.FWRule');

  NewRule.Name := 'Per_Interface_Rule';
  NewRule.Description := 'Add a Per Interface Rule';
  NewRule.Protocol := NET_FW_IP_PROTOCOL_TCP;
  NewRule.LocalPorts := 2300;
  NewRule.Interfacetypes := 'LAN';
  NewRule.Enabled := True;
  NewRule.Grouping := 'My Group';
  NewRule.Profiles := CurrentProfiles;
  NewRule.Interfaces := VarArrayOf(['Local Area Connection']);
  NewRule.Action := NET_FW_ACTION_ALLOW;

  //Add a new rule
  RulesObject.Add(NewRule);
end;

begin
 try
    CoInitialize(nil);
    try
      AddPerInterfaceRule;
    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.

Adding a Protocol Rule

{$APPTYPE CONSOLE}

uses
  SysUtils,
  ActiveX,
  ComObj;

//This code adds a Generic Routing Encapsulation (GRE) protocol rule 
//using the Microsoft Windows Firewall APIs.
Procedure AddProtocolRule;
Const
 NET_FW_ACTION_ALLOW = 1;
var
 CurrentProfiles : OleVariant;
 fwPolicy2       : OleVariant;
 RulesObject     : OleVariant;
 NewRule         : OleVariant;
begin
  // Create the FwPolicy2 object.
  fwPolicy2   := CreateOleObject('HNetCfg.FwPolicy2');
  RulesObject := fwPolicy2.Rules;
  CurrentProfiles := fwPolicy2.CurrentProfileTypes;

  //Create a Rule Object.
  NewRule := CreateOleObject('HNetCfg.FWRule');

  NewRule.Name := 'GRE_RULE';
  NewRule.Description := 'Allow GRE Traffic';
  NewRule.Protocol := 47;
  NewRule.Enabled := True;
  NewRule.Profiles := CurrentProfiles;
  NewRule.Action := NET_FW_ACTION_ALLOW;

  //Add a new rule
  RulesObject.Add(NewRule);
end;

begin
 try
    CoInitialize(nil);
    try
      AddProtocolRule;
    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.

Adding a Rule with Edge Traversal

{$APPTYPE CONSOLE}

uses
  SysUtils,
  ActiveX,
  ComObj;

//This code adds an application rule with Edge Traversal using the Microsoft Windows Firewall APIs.
Procedure AddRuleEdgeTraversal;
Const
 NET_FW_ACTION_ALLOW = 1;
 NET_FW_IP_PROTOCOL_TCP = 6;
var
 CurrentProfiles : OleVariant;
 fwPolicy2       : OleVariant;
 RulesObject     : OleVariant;
 NewRule         : OleVariant;
begin
  // Create the FwPolicy2 object.
  fwPolicy2   := CreateOleObject('HNetCfg.FwPolicy2');
  RulesObject := fwPolicy2.Rules;
  CurrentProfiles := fwPolicy2.CurrentProfileTypes;

  //Create a Rule Object.
  NewRule := CreateOleObject('HNetCfg.FWRule');

  NewRule.Name := 'My Application Name with Edge Traversal';
  NewRule.Description := 'Allow GRE TrafficAllow my application network traffic with Edge Traversal';
  NewRule.Applicationname := 'MyApplication.exe';
  NewRule.Protocol := NET_FW_IP_PROTOCOL_TCP;
  NewRule.LocalPorts := 5000;
  NewRule.Enabled := True;
  NewRule.Grouping := 'My Group';
  NewRule.Profiles := CurrentProfiles;
  NewRule.Action := NET_FW_ACTION_ALLOW;
  NewRule.EdgeTraversal := True;

  //Add a new rule
  RulesObject.Add(NewRule);
end;

begin
 try
    CoInitialize(nil);
    try
      AddRuleEdgeTraversal;
    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.

Adding a Service Rule

{$APPTYPE CONSOLE}

uses
  SysUtils,
  ActiveX,
  ComObj;

//This code adds a service rule in the local public store using the Microsoft Windows Firewall APIs.
Procedure AddServiceRule;
Const
 NET_FW_ACTION_ALLOW = 1;
 NET_FW_IP_PROTOCOL_TCP = 6;
var
 CurrentProfiles : OleVariant;
 fwPolicy2       : OleVariant;
 RulesObject     : OleVariant;
 NewRule         : OleVariant;
begin
  // Create the FwPolicy2 object.
  fwPolicy2   := CreateOleObject('HNetCfg.FwPolicy2');
  RulesObject := fwPolicy2.Rules;
  CurrentProfiles := fwPolicy2.CurrentProfileTypes;

  //Create a Rule Object.
  NewRule := CreateOleObject('HNetCfg.FWRule');

  NewRule.Name := 'Service_Rule';
  NewRule.Description := 'Allow incoming network traffic to myservice';
  NewRule.Applicationname := 'MyService.exe';
  NewRule.ServiceName := 'myservicename';
  NewRule.Protocol := NET_FW_IP_PROTOCOL_TCP;
  NewRule.LocalPorts := 135;
  NewRule.Enabled := True;
  NewRule.Grouping := 'My Group';
  NewRule.Profiles := CurrentProfiles;
  NewRule.Action := NET_FW_ACTION_ALLOW;

  //Add a new rule
  RulesObject.Add(NewRule);
end;

begin
 try
    CoInitialize(nil);
    try
      AddServiceRule;
    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.

Adding an ICMP Rule

{$APPTYPE CONSOLE}

uses
  SysUtils,
  ActiveX,
  ComObj;

//This code adds an ICMP rule using the Microsoft Windows Firewall APIs.
Procedure AddICMPRule;
Const
 NET_FW_ACTION_ALLOW = 1;
 NET_FW_IP_PROTOCOL_ICMPv4 = 1;
 NET_FW_IP_PROTOCOL_ICMPv6 = 58;
var
 CurrentProfiles : OleVariant;
 fwPolicy2       : OleVariant;
 RulesObject     : OleVariant;
 NewRule         : OleVariant;
begin
  // Create the FwPolicy2 object.
  fwPolicy2   := CreateOleObject('HNetCfg.FwPolicy2');
  RulesObject := fwPolicy2.Rules;
  CurrentProfiles := fwPolicy2.CurrentProfileTypes;

  //Create a Rule Object.
  NewRule := CreateOleObject('HNetCfg.FWRule');

  NewRule.Name := 'ICMP_Rule';
  NewRule.Description := 'Allow ICMP network traffic';
  NewRule.Protocol := NET_FW_IP_PROTOCOL_ICMPv4;
  NewRule.IcmpTypesAndCodes := '1:1';
  NewRule.Enabled := True;
  NewRule.Grouping := 'My Group';
  NewRule.Profiles := CurrentProfiles;
  NewRule.Action := NET_FW_ACTION_ALLOW;

  //Add a new rule
  RulesObject.Add(NewRule);
end;

begin
 try
    CoInitialize(nil);
    try
      AddICMPRule;
    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.

Adding an Application Rule

{$APPTYPE CONSOLE}

uses
  SysUtils,
  ActiveX,
  ComObj;

// This code adds an application rule using the Microsoft Windows Firewall APIs.
Procedure AddApplicationRule;
Const
 NET_FW_ACTION_ALLOW = 1;
 NET_FW_IP_PROTOCOL_TCP = 6;
var
 CurrentProfiles : OleVariant;
 fwPolicy2       : OleVariant;
 RulesObject     : OleVariant;
 NewRule         : OleVariant;
begin
  // Create the FwPolicy2 object.
  fwPolicy2   := CreateOleObject('HNetCfg.FwPolicy2');
  RulesObject := fwPolicy2.Rules;
  CurrentProfiles := fwPolicy2.CurrentProfileTypes;

  //Create a Rule Object.
  NewRule := CreateOleObject('HNetCfg.FWRule');

  NewRule.Name := 'My Application Name';
  NewRule.Description := 'Allow my application network traffic';
  NewRule.Applicationname := 'C:\Foo\MyApplication.exe';
  NewRule.Protocol := NET_FW_IP_PROTOCOL_TCP;
  NewRule.LocalPorts := 4000;
  NewRule.Enabled := True;
  NewRule.Grouping := 'My Group';
  NewRule.Profiles := CurrentProfiles;
  NewRule.Action := NET_FW_ACTION_ALLOW;

  //Add a new rule
  RulesObject.Add(NewRule);
end;

begin
 try
    CoInitialize(nil);
    try
      AddApplicationRule;
    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.

Adding an Outbound Rule

{$APPTYPE CONSOLE}

uses
  SysUtils,
  ActiveX,
  ComObj;

//This code adds an outbound rule using the Microsoft Windows Firewall APIs.
Procedure AddOutboundRule;
Const
 NET_FW_ACTION_ALLOW = 1;
 NET_FW_IP_PROTOCOL_TCP = 6;
 NET_FW_RULE_DIR_OUT = 2;
var
 CurrentProfiles : OleVariant;
 fwPolicy2       : OleVariant;
 RulesObject     : OleVariant;
 NewRule         : OleVariant;
begin
  // Create the FwPolicy2 object.
  fwPolicy2   := CreateOleObject('HNetCfg.FwPolicy2');
  RulesObject := fwPolicy2.Rules;
  CurrentProfiles := fwPolicy2.CurrentProfileTypes;

  //Create a Rule Object.
  NewRule := CreateOleObject('HNetCfg.FWRule');

  NewRule.Name := 'Outbound_Rule';
  NewRule.Description := 'Allow outbound network traffic from my Application over TCP port 4000';
  NewRule.Applicationname := 'C:\Foo\MyApplication.exe';
  NewRule.Protocol := NET_FW_IP_PROTOCOL_TCP;
  NewRule.LocalPorts := 4000;
  NewRule.Direction := NET_FW_RULE_DIR_OUT;
  NewRule.Enabled := True;
  NewRule.Grouping := 'My Group';
  NewRule.Profiles := CurrentProfiles;
  NewRule.Action := NET_FW_ACTION_ALLOW;

  //Add a new rule
  RulesObject.Add(NewRule);
end;

begin
 try
    CoInitialize(nil);
    try
      AddOutboundRule;
    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.

Checking if a Rule is Enabled

{$APPTYPE CONSOLE}

uses
  SysUtils,
  ActiveX,
  ComObj;

//This code checks if the rule group is enabled in the current profile using the Microsoft Windows Firewall APIs.
Procedure CheckingRuleEnabled;
Const
 NET_FW_MODIFY_STATE_OK = 0;
 NET_FW_MODIFY_STATE_GP_OVERRIDE = 1;
 NET_FW_MODIFY_STATE_INBOUND_BLOCKED = 2;
var
 fwPolicy2         : OleVariant;
 PolicyModifyState : Integer;
 bIsEnabled : Boolean;
begin
  // Create the FwPolicy2 object.
  fwPolicy2   := CreateOleObject('HNetCfg.FwPolicy2');

  bIsEnabled := fwPolicy2.IsRuleGroupCurrentlyEnabled('File and Printer Sharing');

  if bIsEnabled then
      Writeln('File and Printer Sharing is currently enabled on at least one of the current profiles')
  else
      Writeln('File and Printer Sharing is currently not enabled on any of the current profiles');

   PolicyModifyState := fwPolicy2.LocalPolicyModifyState;

  case PolicyModifyState of
    NET_FW_MODIFY_STATE_OK             : Writeln('Changing or adding a firewall rule (or group) will take effect on at least one of the current profiles.');
    NET_FW_MODIFY_STATE_GP_OVERRIDE    : Writeln('Changing or adding a firewall rule (or group) to the current profiles will not take effect because group policy overrides it on at least one of the current profiles.');
    NET_FW_MODIFY_STATE_INBOUND_BLOCKED: Writeln('Changing or adding an inbound firewall rule (or group) to the current profiles will not take effect because inbound rules are not allowed on at least one of the current profiles.')
    else                                 Writeln('Invalid Modify State returned by LocalPolicyModifyState.');
  End;

end;

begin
 try
    CoInitialize(nil);
    try
      CheckingRuleEnabled;
    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.

Disabling the Firewall per Interface

{$APPTYPE CONSOLE}

uses
  SysUtils,
  ActiveX,
  Variants,
  ComObj;


//This code disables the firewall on a per interface basis using the Microsoft Windows Firewall APIs.
Procedure DisableFirewallPerInterface;
Const
 NET_FW_PROFILE2_DOMAIN  = 1;
 NET_FW_PROFILE2_PRIVATE = 2;
 NET_FW_PROFILE2_PUBLIC  = 4;
var
 CurrentProfiles : Integer;
 fwPolicy2       : OleVariant;
begin
  // Create the FwPolicy2 object.
  fwPolicy2   := CreateOleObject('HNetCfg.FwPolicy2');
  CurrentProfiles := fwPolicy2.CurrentProfileTypes;

   //Disable Firewall on interface in the Domain profile
   if (CurrentProfiles and NET_FW_PROFILE2_DOMAIN)<>0 then
    begin
      if not fwPolicy2.FirewallEnabled[NET_FW_PROFILE2_DOMAIN]  then
        fwPolicy2.FirewallEnabled[NET_FW_PROFILE2_DOMAIN]:= True;

      fwPolicy2.ExcludedInterfaces(NET_FW_PROFILE2_DOMAIN, VarArrayOf(['Local Area Connection']));
    end;

   //Disable Firewall on interface in the Private profile
   if (CurrentProfiles and NET_FW_PROFILE2_PRIVATE)<>0 then
    begin
      if not fwPolicy2.FirewallEnabled[NET_FW_PROFILE2_PRIVATE]  then
        fwPolicy2.FirewallEnabled[NET_FW_PROFILE2_PRIVATE]:= True;

      fwPolicy2.ExcludedInterfaces(NET_FW_PROFILE2_PRIVATE, VarArrayOf(['Local Area Connection']));
    end;

   //Disable Firewall on interface in the Public profile
   if (CurrentProfiles and NET_FW_PROFILE2_PUBLIC)<>0 then
    begin
      if not fwPolicy2.FirewallEnabled[NET_FW_PROFILE2_PUBLIC]  then
        fwPolicy2.FirewallEnabled[NET_FW_PROFILE2_PUBLIC]:= True;

      fwPolicy2.ExcludedInterfaces(NET_FW_PROFILE2_PUBLIC, VarArrayOf(['Local Area Connection']));
    end;

end;

begin
 try
    CoInitialize(nil);
    try
      DisableFirewallPerInterface;
    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.

Enabling Rule Groups

{$APPTYPE CONSOLE}

uses
  SysUtils,
  ActiveX,
  ComObj;

//This code enables the Windows Firewall rule groups using the Microsoft Windows Firewall APIs.
Procedure EnableRuleGroups;
var
 CurrentProfiles : Integer;
 fwPolicy2       : OleVariant;
 RulesObject     : OleVariant;
begin
  // Create the FwPolicy2 object.
  fwPolicy2   := CreateOleObject('HNetCfg.FwPolicy2');
  RulesObject := fwPolicy2.Rules;
  CurrentProfiles := fwPolicy2.CurrentProfileTypes;
  fwPolicy2.EnableRuleGroup(CurrentProfiles, 'File and Printer Sharing', True);
end;

begin
 try
    CoInitialize(nil);
    try
      EnableRuleGroups;
    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.

Enumerating Firewall Rules

{$APPTYPE CONSOLE}

uses
  SysUtils,
  ActiveX,
  Variants,
  ComObj;

//This code enumerates Windows Firewall rules using the Microsoft Windows Firewall APIs.
Procedure EnumerateFirewallRules;
Const
  NET_FW_PROFILE2_DOMAIN  = 1;
  NET_FW_PROFILE2_PRIVATE = 2;
  NET_FW_PROFILE2_PUBLIC  = 4;

  NET_FW_IP_PROTOCOL_TCP = 6;
  NET_FW_IP_PROTOCOL_UDP = 17;
  NET_FW_IP_PROTOCOL_ICMPv4 = 1;
  NET_FW_IP_PROTOCOL_ICMPv6 = 58;

  NET_FW_RULE_DIR_IN = 1;
  NET_FW_RULE_DIR_OUT = 2;

  NET_FW_ACTION_BLOCK = 0;
  NET_FW_ACTION_ALLOW = 1;

var
 CurrentProfiles : Integer;
 fwPolicy2       : OleVariant;
 RulesObject     : OleVariant;
 rule            : OleVariant;
 oEnum           : IEnumvariant;
 iValue          : LongWord;
begin
  // Create the FwPolicy2 object.
  fwPolicy2   := CreateOleObject('HNetCfg.FwPolicy2');
  RulesObject := fwPolicy2.Rules;
  CurrentProfiles := fwPolicy2.CurrentProfileTypes;

  if (CurrentProfiles AND NET_FW_PROFILE2_DOMAIN)<>0 then
     Writeln('Domain Firewall Profile is active');

  if ( CurrentProfiles AND NET_FW_PROFILE2_PRIVATE )<>0 then
      Writeln('Private Firewall Profile is active');

  if ( CurrentProfiles AND NET_FW_PROFILE2_PUBLIC )<>0 then
      Writeln('Public Firewall Profile is active');

  Writeln('Rules:');

  oEnum         := IUnknown(Rulesobject._NewEnum) as IEnumVariant;
  while oEnum.Next(1, rule, iValue) = 0 do
  begin
    if (rule.Profiles And CurrentProfiles)<>0 then
    begin
        Writeln('  Rule Name:          ' + rule.Name);
        Writeln('   ----------------------------------------------');
        Writeln('  Description:        ' + rule.Description);
        Writeln('  Application Name:   ' + rule.ApplicationName);
        Writeln('  Service Name:       ' + rule.ServiceName);

        Case rule.Protocol of
           NET_FW_IP_PROTOCOL_TCP    : Writeln('  IP Protocol:        TCP.');
           NET_FW_IP_PROTOCOL_UDP    : Writeln('  IP Protocol:        UDP.');
           NET_FW_IP_PROTOCOL_ICMPv4 : Writeln('  IP Protocol:        UDP.');
           NET_FW_IP_PROTOCOL_ICMPv6 : Writeln('  IP Protocol:        UDP.');
        Else                           Writeln('  IP Protocol:        ' + VarToStr(rule.Protocol));
        End;


        if (rule.Protocol = NET_FW_IP_PROTOCOL_TCP) or (rule.Protocol = NET_FW_IP_PROTOCOL_UDP) then
        begin
          Writeln('  Local Ports:        ' + rule.LocalPorts);
          Writeln('  Remote Ports:       ' + rule.RemotePorts);
          Writeln('  LocalAddresses:     ' + rule.LocalAddresses);
          Writeln('  RemoteAddresses:    ' + rule.RemoteAddresses);
        end;

        if (rule.Protocol = NET_FW_IP_PROTOCOL_ICMPv4) or (rule.Protocol = NET_FW_IP_PROTOCOL_ICMPv6) then
          Writeln('  ICMP Type and Code: ' + rule.IcmpTypesAndCodes);

        Case rule.Direction of
            NET_FW_RULE_DIR_IN :  Writeln('  Direction:          In');
            NET_FW_RULE_DIR_OUT:  Writeln('  Direction:          Out');
        End;

        Writeln('  Enabled:            ' + VarToStr(rule.Enabled));
        Writeln('  Edge:               ' + VarToStr(rule.EdgeTraversal));

        Case rule.Action of
           NET_FW_ACTION_ALLOW : Writeln('  Action:             Allow');
           NET_FW_ACTION_BLOCk : Writeln('  Action:             Block');
        End;


        Writeln('  Grouping:           ' + rule.Grouping);
        Writeln('  Edge:               ' + VarToStr(rule.EdgeTraversal));
        Writeln('  Interface Types:    ' + rule.InterfaceTypes);

     Writeln;
    end;
    rule:=Unassigned;
  end;


end;

begin
 try
    CoInitialize(nil);
    try
      EnumerateFirewallRules;
    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.

Enumerating Firewall Rules with a Matching Group String

{$APPTYPE CONSOLE}

uses
  SysUtils,
  ActiveX,
  Variants,
  ComObj;

//This code enumerates  Windows Firewall rules with a matching grouping string 
Procedure EnumerateFirewallRules;
Const
  NET_FW_PROFILE2_DOMAIN  = 1;
  NET_FW_PROFILE2_PRIVATE = 2;
  NET_FW_PROFILE2_PUBLIC  = 4;

  NET_FW_IP_PROTOCOL_TCP = 6;
  NET_FW_IP_PROTOCOL_UDP = 17;
  NET_FW_IP_PROTOCOL_ICMPv4 = 1;
  NET_FW_IP_PROTOCOL_ICMPv6 = 58;

  NET_FW_RULE_DIR_IN = 1;
  NET_FW_RULE_DIR_OUT = 2;

  NET_FW_ACTION_BLOCK = 0;
  NET_FW_ACTION_ALLOW = 1;

var
 CurrentProfiles : Integer;
 fwPolicy2       : OleVariant;
 RulesObject     : OleVariant;
 rule            : OleVariant;
 oEnum           : IEnumvariant;
 iValue          : LongWord;
begin
  // Create the FwPolicy2 object.
  fwPolicy2   := CreateOleObject('HNetCfg.FwPolicy2');
  RulesObject := fwPolicy2.Rules;
  CurrentProfiles := fwPolicy2.CurrentProfileTypes;

  if (CurrentProfiles AND NET_FW_PROFILE2_DOMAIN)<>0 then
     Writeln('Domain Firewall Profile is active');

  if ( CurrentProfiles AND NET_FW_PROFILE2_PRIVATE )<>0 then
      Writeln('Private Firewall Profile is active');

  if ( CurrentProfiles AND NET_FW_PROFILE2_PUBLIC )<>0 then
      Writeln('Public Firewall Profile is active');

  Writeln('Rules:');

  oEnum         := IUnknown(Rulesobject._NewEnum) as IEnumVariant;
  while oEnum.Next(1, rule, iValue) = 0 do
  begin
    if (rule.Grouping = 'My Group') then
    begin
        Writeln('  Rule Name:          ' + rule.Name);
        Writeln('   ----------------------------------------------');
        Writeln('  Description:        ' + rule.Description);
        Writeln('  Application Name:   ' + rule.ApplicationName);
        Writeln('  Service Name:       ' + rule.ServiceName);

        Case rule.Protocol of
           NET_FW_IP_PROTOCOL_TCP    : Writeln('  IP Protocol:        TCP.');
           NET_FW_IP_PROTOCOL_UDP    : Writeln('  IP Protocol:        UDP.');
           NET_FW_IP_PROTOCOL_ICMPv4 : Writeln('  IP Protocol:        UDP.');
           NET_FW_IP_PROTOCOL_ICMPv6 : Writeln('  IP Protocol:        UDP.');
        Else                           Writeln('  IP Protocol:        ' + VarToStr(rule.Protocol));
        End;


        if (rule.Protocol = NET_FW_IP_PROTOCOL_TCP) or (rule.Protocol = NET_FW_IP_PROTOCOL_UDP) then
        begin
          Writeln('  Local Ports:        ' + rule.LocalPorts);
          Writeln('  Remote Ports:       ' + rule.RemotePorts);
          Writeln('  LocalAddresses:     ' + rule.LocalAddresses);
          Writeln('  RemoteAddresses:    ' + rule.RemoteAddresses);
        end;

        if (rule.Protocol = NET_FW_IP_PROTOCOL_ICMPv4) or (rule.Protocol = NET_FW_IP_PROTOCOL_ICMPv6) then
          Writeln('  ICMP Type and Code: ' + rule.IcmpTypesAndCodes);

        Case rule.Direction of
            NET_FW_RULE_DIR_IN :  Writeln('  Direction:          In');
            NET_FW_RULE_DIR_OUT:  Writeln('  Direction:          Out');
        End;

        Writeln('  Enabled:            ' + VarToStr(rule.Enabled));
        Writeln('  Edge:               ' + VarToStr(rule.EdgeTraversal));

        Case rule.Action of
           NET_FW_ACTION_ALLOW : Writeln('  Action:             Allow');
           NET_FW_ACTION_BLOCk : Writeln('  Action:             Block');
        End;


        Writeln('  Grouping:           ' + rule.Grouping);
        Writeln('  Edge:               ' + VarToStr(rule.EdgeTraversal));
        Writeln('  Interface Types:    ' + rule.InterfaceTypes);

     Writeln;
    end;
    rule:=Unassigned;
  end;


end;

begin
 try
    CoInitialize(nil);
    try
      EnumerateFirewallRules;
    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.

Restricting Service

{$APPTYPE CONSOLE}

uses
  SysUtils,
  ActiveX,
  ComObj;

//This code restricts a service using the Microsoft Windows Firewall APIs.
Procedure RestrictService;
Const
  NET_FW_PROFILE2_DOMAIN  = 1;
  NET_FW_PROFILE2_PRIVATE = 2;
  NET_FW_PROFILE2_PUBLIC  = 4;

  NET_FW_IP_PROTOCOL_TCP = 6;

  NET_FW_RULE_DIR_IN = 1;
  NET_FW_RULE_DIR_OUT = 2;

  NET_FW_ACTION_BLOCK = 0;
  NET_FW_ACTION_ALLOW = 1;

var
 fwPolicy2       : OleVariant;
 RulesObject, wshRules   : OleVariant;
 ServiceRestriction, NewInboundRule, NewOutboundRule : OleVariant;
begin
  // Create the FwPolicy2 object.
  fwPolicy2   := CreateOleObject('HNetCfg.FwPolicy2');
  RulesObject := fwPolicy2.Rules;

  // Get the Service Restriction object for the local firewall policy.
  ServiceRestriction := fwPolicy2.ServiceRestriction;

  // Put in block-all inbound and block-all outbound Windows Service Hardening (WSH) networking rules for the service
  ServiceRestriction.RestrictService('TermService', '%systemDrive%\WINDOWS\system32\svchost.exe', True, False);

  //If the service requires sending/receiving certain type of traffic, then add "allow" WSH rules as follows

  //Get the collection of Windows Service Hardening networking rules
  wshRules := ServiceRestriction.Rules;

  //Add inbound WSH allow rules
  NewInboundRule := CreateOleObject('HNetCfg.FWRule');
  NewInboundRule.Name := 'Allow only TCP 3389 inbound to service';
  NewInboundRule.ApplicationName := '%systemDrive%\WINDOWS\system32\svchost.exe';
  NewInboundRule.ServiceName := 'TermService';
  NewInboundRule.Protocol := NET_FW_IP_PROTOCOL_TCP;
  NewInboundRule.LocalPorts := 3389;

  NewInboundRule.Action := NET_FW_ACTION_ALLOW;
  NewInboundRule.Direction := NET_FW_RULE_DIR_IN;
  NewInboundRule.Enabled := True;

  wshRules.Add(NewInboundRule);

  //Add outbound WSH allow rules
  NewOutboundRule := CreateOleObject('HNetCfg.FWRule');
  NewOutboundRule.Name := 'Allow outbound traffic from service only from TCP 3389';
  NewOutboundRule.ApplicationName := '%systemDrive%\WINDOWS\system32\svchost.exe';
  NewOutboundRule.ServiceName := 'TermService';
  NewOutboundRule.Protocol := NET_FW_IP_PROTOCOL_TCP;
  NewOutboundRule.LocalPorts := 3389;

  NewOutboundRule.Action := NET_FW_ACTION_ALLOW;
  NewOutboundRule.Direction := NET_FW_RULE_DIR_OUT;
  NewOutboundRule.Enabled := True;

  wshRules.Add(NewOutboundRule);
end;

begin
 try
    CoInitialize(nil);
    try
      RestrictService;
    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.

Retrieving Firewall Settings

{$APPTYPE CONSOLE}

uses
  SysUtils,
  ActiveX,
  ComObj;

//This code reads the Windows Firewall settings per profile using the Microsoft Windows Firewall APIs.
Procedure GetFirewallSettings;
Const
  NET_FW_PROFILE2_DOMAIN  = 1;
  NET_FW_PROFILE2_PRIVATE = 2;
  NET_FW_PROFILE2_PUBLIC  = 4;

var
 CurrentProfiles : Integer;
 fwPolicy2       : OleVariant;
begin
  // Create the FwPolicy2 object.
  fwPolicy2   := CreateOleObject('HNetCfg.FwPolicy2');
  CurrentProfiles := fwPolicy2.CurrentProfileTypes;

  if (CurrentProfiles AND NET_FW_PROFILE2_DOMAIN)<>0 then
     if fwPolicy2.FirewallEnabled[NET_FW_PROFILE2_DOMAIN] then
       Writeln('Firewall is ON on domain profile.')
     else
       Writeln('Firewall is OFF on domain profile.');

  if (CurrentProfiles AND NET_FW_PROFILE2_PRIVATE)<>0 then
     if fwPolicy2.FirewallEnabled[NET_FW_PROFILE2_PRIVATE] then
       Writeln('Firewall is ON on private profile.')
     else
       Writeln('Firewall is OFF on private profile.');

  if (CurrentProfiles AND NET_FW_PROFILE2_PUBLIC)<>0 then
     if fwPolicy2.FirewallEnabled[NET_FW_PROFILE2_PUBLIC] then
       Writeln('Firewall is ON on public profile.')
     else
       Writeln('Firewall is OFF on public profile.');
end;

begin
 try
    CoInitialize(nil);
    try
      GetFirewallSettings;
    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.

Turning the Firewall Off

{$APPTYPE CONSOLE}

uses
  SysUtils,
  ActiveX,
  ComObj;

//This code that disables the firewall using the Microsoft Windows Firewall APIs.
Procedure SetFirewallOff;
Const
  NET_FW_PROFILE2_DOMAIN  = 1;
  NET_FW_PROFILE2_PRIVATE = 2;
  NET_FW_PROFILE2_PUBLIC  = 4;
var
 fwPolicy2       : OleVariant;
begin
  // Create the FwPolicy2 object.
  fwPolicy2   := CreateOleObject('HNetCfg.FwPolicy2');

  fwPolicy2.FirewallEnabled[NET_FW_PROFILE2_DOMAIN]:= False;
  fwPolicy2.FirewallEnabled[NET_FW_PROFILE2_PRIVATE]:= False;
  fwPolicy2.FirewallEnabled[NET_FW_PROFILE2_PUBLIC]:= False;
end;

begin
 try
    CoInitialize(nil);
    try
      SetFirewallOff;
    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.

This post is based in the MSDN entry Using Windows Firewall with Advanced Security


31 Comments

The VCL Styles Utils Project now supports dialogs and popup menus

Two missing parts of the standard VCL Styles is the lack of the capacity to theme the popup menus and the standard Windows dialogs. I started to work a year ago in the dialogs area, but due to my limited time I was not able to finish that. But a few months ago I receive a very interesting mail from Mahdi Safsafi (SMP3) that show me his own work on this topic. So we decided merge the code of his project and the VCL Styles Utils. So finally the VCL Styles Utils project was updated to support standard dialogs, popup and system menus.

How it works?

The key is using a WH_CBT Hook, detecting the HCBT_CREATEWND and HCBT_DESTROYWND codes and then checking if the class of the window is #32770 (the class for a dialog box.) or the #32768 (the class for a popupmenu) from here you can replace the window procedure (WndProc) using the SetWindowLongPtr function with the GWL_WNDPROC index. Now we have the control of the messages sent by the windows dialogs and menus and we can iterate over the child controls and replace the window procedure again using the GWL_WNDPROC index. Finally depending of the class of the control (button, syslistview32, Combobox and so on) a Wrapper class (like the VCL does) is created to handle the messages related to the paint of the control.

Check the next source code which install the hook and process the Win32 controls

unit Vcl.Styles.SysControls;

interface

implementation

uses
  Winapi.Windows,
  System.Generics.Collections,
  System.SysUtils,
  Vcl.Controls,
  Vcl.Dialogs,
  Vcl.Styles,
  Vcl.Themes,
  Vcl.Styles.PopupWnd,
  Vcl.Styles.EditWnd,
  Vcl.Styles.StaticWnd,
  Vcl.Styles.ThemedDialog,
  Vcl.Styles.ToolbarWindow32Wnd,
  Vcl.Styles.SysListView32Wnd,
  Vcl.Styles.ButtonWnd,
  Vcl.Styles.UnknownControlWnd,
  Vcl.Styles.ControlWnd,
  Vcl.Styles.ComboBoxWnd,
  Vcl.Styles.ToolTipsWnd;

type
  TThemedSysControls = class
  private
  class var
    FBalloonHint: TBalloonHint;
    FPreviousSysBtn: Integer;
    FPreviousHandle: THandle;
    FHook: HHook;
  protected
    class function HookActionCallBack(Code: Integer; wParam: wParam;
      lParam: lParam): LRESULT; stdcall; static;
    procedure InstallHook;
    procedure RemoveHook;
  public
    constructor Create; overload;
    destructor Destroy; override;
  end;

var
  MenuItemInfoArray: array of TMenuItemInfo;
  TooltipsWndList: TObjectDictionary<HWND, TooltipsWnd>;
  PopupWndList: TObjectDictionary<HWND, TPopupWnd>;
  StaticWndList: TObjectDictionary<HWND, TStaticWnd>;
  DialogWndList: TObjectDictionary<HWND, TDialogWnd>;
  EditWndList: TObjectDictionary<HWND, TEditWnd>;
  ComboBoxWndList: TObjectDictionary<HWND, TComboBoxWnd>;
  UnknownControlList: TObjectDictionary<HWND, TUnknownControlWnd>;
  ToolbarWindow32WndList : TObjectDictionary<HWND, TToolbarWindow32Wnd>;
  SysListView32WndList : TObjectDictionary<HWND, TSysListView32Wnd>;
  BtnWndArrayList : TObjectDictionary<HWND, TButtonWnd>;
  ThemedSysControls: TThemedSysControls;

{ TThemedSysControls }

constructor TThemedSysControls.Create;
begin
  inherited;
  FBalloonHint := TBalloonHint.Create(nil);
  FBalloonHint.Style := bhsStandard;
  FBalloonHint.Delay := 1500;
  FBalloonHint.HideAfter := 3000;
  FPreviousHandle := 0;
  FHook := 0;
  InstallHook;
  PopupWndList:= TObjectDictionary<HWND, TPopupWnd>.Create([doOwnsValues]);
  TooltipsWndList:= TObjectDictionary<HWND, TooltipsWnd>.Create([doOwnsValues]);
  StaticWndList:= TObjectDictionary<HWND, TStaticWnd>.Create([doOwnsValues]);
  DialogWndList:= TObjectDictionary<HWND,TDialogWnd>.Create([doOwnsValues]);
  EditWndList:= TObjectDictionary<HWND, TEditWnd>.Create([doOwnsValues]);
  ComboBoxWndList:= TObjectDictionary<HWND, TComboBoxWnd>.Create([doOwnsValues]);
  UnknownControlList:= TObjectDictionary<HWND, TUnknownControlWnd>.Create([doOwnsValues]);
  ToolbarWindow32WndList:= TObjectDictionary<HWND, TToolbarWindow32Wnd>.Create([doOwnsValues]);
  SysListView32WndList := TObjectDictionary<HWND, TSysListView32Wnd>.Create([doOwnsValues]);
  BtnWndArrayList := TObjectDictionary<HWND, TButtonWnd>.Create([doOwnsValues]);
end;

destructor TThemedSysControls.Destroy;
begin
  RemoveHook;

  PopupWndList.Free;
  TooltipsWndList.Free;
  StaticWndList.Free;
  DialogWndList.Free;
  EditWndList.Free;
  ComboBoxWndList.Free;
  UnknownControlList.Free;
  ToolbarWindow32WndList.Free;
  SysListView32WndList.Free;
  BtnWndArrayList.Free;

  FBalloonHint.Free;
  inherited;
end;

class function TThemedSysControls.HookActionCallBack(Code: Integer;
  wParam: wParam; lParam: lParam): LRESULT;
var
  Msg: TMOUSEHOOKSTRUCT;
  C: array [0 .. 256] of Char;

  procedure HideSysToolTip;
  var
    hSysToolTip: THandle;
  begin
    For hSysToolTip := 65550 To 65600 do
      begin
        If IsWindowVisible(hSysToolTip) then
          begin
            GetClassName(hSysToolTip, C, 256);
            ShowWindow(hSysToolTip, SW_HIDE);
          end;
      end;
  end;

  procedure ShowToolTip(HintTitle: String);
  begin
    HideSysToolTip;
    if FPreviousSysBtn <> Integer(Msg.wHitTestCode) then
      begin
        FBalloonHint.HideHint;
        FBalloonHint.Title := HintTitle;
        FPreviousSysBtn := Msg.wHitTestCode;
        FBalloonHint.ShowHint(Msg.pt);
      end;
  end;

var
  CBTSturct: TCBTCreateWnd;
  sClassName : string;
begin
    if (StyleServices.Enabled) and not (StyleServices.IsSystemStyle) then
    begin
      if Code = HCBT_SYSCOMMAND then
        begin
          FBalloonHint.HideHint;
          FPreviousSysBtn := 0;
        end
      else
      if Code = HCBT_DESTROYWND then
      begin
        sClassName := GetWindowClassName(wParam);
          if sClassName = '#32768' then
          {PopupMenu}
          begin
            if PopupWndList.ContainsKey(wParam) then
              PopupWndList.Remove(wParam);
            //OutputDebugString(PChar('remove PopupWndList count '+IntToStr(PopupWndList.Count)));
          end
          else
          if sClassName = '#32770' then
          {Dialog}
          begin
            if DialogWndList.ContainsKey(wParam) then
              DialogWndList.Remove(wParam);
            //OutputDebugString(PChar('remove DialogWndList count '+IntToStr(DialogWndList.Count)));
          end
          else
          if sClassName = 'Button' then
          {Button}
          begin
            if BtnWndArrayList.ContainsKey(wParam) then
              BtnWndArrayList.Remove(wParam);
            //OutputDebugString(PChar('remove BtnWndArrayList count '+IntToStr(BtnWndArrayList.Count)));
          end
          else
          if (sClassName = 'ScrollBar') or (sClassName = 'ReBarWindow32') {or (sClassName = 'ToolbarWindow32')} then
          begin
            if UnknownControlList.ContainsKey(wParam) then
              UnknownControlList.Remove(wParam);
          end
          else
          if sClassName = 'SysListView32' then
          begin
            if SysListView32WndList.ContainsKey(wParam) then
              SysListView32WndList.Remove(wParam);
          end
          else
          if sClassName = 'ToolbarWindow32' then
          begin
            if ToolbarWindow32WndList.ContainsKey(wParam) then
              ToolbarWindow32WndList.Remove(wParam);
          end
          else
          if sClassName = 'Edit' then
          begin
            if EditWndList.ContainsKey(wParam) then
              EditWndList.Remove(wParam);
          end
          else
          if sClassName = 'Static' then
          begin
            if StaticWndList.ContainsKey(wParam) then
              StaticWndList.Remove(wParam);
          end
          else
          if sClassName = 'ComboBox' then
          begin
            if ComboBoxWndList.ContainsKey(wParam) then
              ComboBoxWndList.Remove(wParam);
          end
          else
          if sClassName = 'tooltips_class32' then
          begin
            if TooltipsWndList.ContainsKey(wParam) then
              TooltipsWndList.Remove(wParam);
          end
      end
      else
      if Code = HCBT_CREATEWND then
        begin
          CBTSturct := PCBTCreateWnd(lParam)^;
          sClassName := GetWindowClassName(wParam);
          //PopupMenu
          if Integer(CBTSturct.lpcs.lpszClass) = 32768 then
              PopupWndList.Add(wParam, TPopupWnd.Create(wParam))
          else
          //Dialog
          if Integer(CBTSturct.lpcs.lpszClass) = 32770 then
            begin
              if (CBTSturct.lpcs.cx <> 0) and (CBTSturct.lpcs.cy <> 0) then
                DialogWndList.Add(wParam, TDialogWnd.Create(wParam))
            end
          else
          if sClassName = 'Button' then
              BtnWndArrayList.Add(wParam, TButtonWnd.Create(wParam))
          else
          if (sClassName = 'ScrollBar') or (sClassName = 'ReBarWindow32') {or (sClassName = 'ToolbarWindow32')} then
              UnknownControlList.Add(wParam, TUnknownControlWnd.Create(wParam))
          else
          if sClassName = 'SysListView32' then
              SysListView32WndList.Add(wParam, TSysListView32Wnd.Create(wParam))
          else
          if sClassName = 'ToolbarWindow32' then
            begin
              if not UseLatestCommonDialogs then
                ToolbarWindow32WndList.Add(wParam, TToolbarWindow32Wnd.Create(wParam));
            end
          else
          if sClassName = 'Edit' then
              EditWndList.Add(wParam, TEditWnd.Create(wParam))
          else
          if sClassName = 'Static' then
            begin
              { This condition can solve the Edit animated cursor : see ColorDialog !! }
              if (CBTSturct.lpcs.Style and SS_ICON <> SS_ICON) and
                (CBTSturct.lpcs.Style and SS_BITMAP <> SS_BITMAP) and
                (CBTSturct.lpcs.Style and SS_GRAYRECT <> SS_GRAYRECT) and
                (CBTSturct.lpcs.Style and SS_GRAYFRAME <> SS_GRAYFRAME) then
                  StaticWndList.Add(wParam, TStaticWnd.Create(wParam));
            end
          else
          if sClassName = 'ComboBox' then
            ComboBoxWndList.Add(wParam, TComboBoxWnd.Create(wParam))
          else
          if sClassName = 'tooltips_class32' then
            TooltipsWndList.Add(wParam, TooltipsWnd.Create(wParam))
        end
    end;
  Result := CallNextHookEx(FHook, Code, wParam, lParam);
end;

procedure TThemedSysControls.InstallHook;
begin
  FHook := SetWindowsHookEx(WH_CBT, @TThemedSysControls.HookActionCallBack, 0, GetCurrentThreadId);
end;

procedure TThemedSysControls.RemoveHook;
begin
  if FHook <> 0 then
    UnhookWindowsHookEx(FHook);
end;

initialization

  ThemedSysControls:=nil;
  if StyleServices.Available then
    ThemedSysControls := TThemedSysControls.Create;

finalization

if Assigned(ThemedSysControls) then
    ThemedSysControls.Free;


end.

Menus

Standard TMainMenu with VCL Styles Enabled.
1

using the Vcl.Styles.SysControls unit
4

SysMenu with VCL Styles Enabled.

3

using the Vcl.Styles.SysControls unit

6

System menu with VCL Styles Enabled.

2

System menu using the Vcl.Styles.SysControls unit
5

Dialogs

Open Dialog With VCL Styles enabled

8

Open Dialog using the Vcl.Styles.SysControls unit
9

Even the shell menu inside of the dialog is themed

dialog_full

Others Dialogs

11

15

14

13

12

10

You can activate this functionality in your apps just adding the Vcl.Styles.SysControls unit to your project. Also a new sample project was added to test all the new features.

As always all your comments and suggestions are welcome.