The Road to Delphi – a Blog about programming

Vcl Style Utils site updated and new demo video

January 20, 2012 Rodrigo Leave a comment

In the past days I’ve added many new features and a lot of improvements in the Vcl Style Utils project. You can see the updated site here and a new video showing the Vcl Style Utils library in action, also the repository contains a set of demo projects to check how use the library.

Check this video of an Demo app which was built using the Vcl Style Utils.

You can download the demo app VCL Styles Equalizer from here.

Categories: Delphi, Delphi XE2, VCL Styles

Demo video of the Vcl Style Utils Library

January 10, 2012 Rodrigo Leave a comment

I just uploaded a video showing how you can change the HSL values of any VCL Style in runtime using the vcl styles utils library. in the code google site you can found the the full source code of the application and more demo projects.

Categories: Delphi, Delphi XE2, VCL Styles

Exploring Delphi XE2 – VCL Styles Part III

January 8, 2012 Rodrigo 1 comment

Introduction

The VCL Styles are great but it seems that was designed to hide (and protect?) a lot of useful properties and classes. Because that I wrote a small (for the moment) library that using class helpers (and another tricks) can access to hidden properties and classes of the VCL Styles. Today I will show you how using this library you can create a previewer for your vcl styles.

When you design a GUI and include the option to change the current VCL Style of an application you generally provide a list of the availables VCL Styles, then the user without knowing nothing about the appearance of the style must choose one and then apply the changes. Well you can improve the user experience showing a preview image of the VCL style before to apply the selection.

Check out this sample image of a settings option of the WDCC, that shows a preview of the VCL Styles.

The internals

The TStyleManager class contains an internal collection with all the registered (loaded) styles, this list is stored in a Dictionary class var like this FRegisteredStyles: TDictionary; and each TPair contains the style name and a TSourceInfo value.

This is the definition of the TSourceInfo type

TStyleServicesHandle = type Pointer;
  strict private type
    TSourceInfo = record
      Data: TStyleServicesHandle;
      StyleClass: TCustomStyleServicesClass;
    end;

The Data field point to a TStream that contains all the objects and bitmaps related to the style and the StyleClass field has the type of the class Style Service. Now in order to access the visual elements of the style we need interpret the content of the Data field. The logic to interpret the streams with the VCL style info is placed in two files StyleUtils.inc and StyleAPI.inc, these files are in the source\vcl folder of your Rad Studio installation. As probably you must know these files are not units and are embedded in the implementation part of the Vcl.Styles unit, because that the classes and methods of these files are not accesible in any way (for now).

Note : The StyleUtils.inc and StyleAPI.inc files contains code that originally was part of the SkineEngine library of Eugene A. Kryukov (Yeah Eugene is the original author of the DXScene the antecesor of FireMonkey).

Accesing the TSourceInfo

The first task is gain access to the class var FRegisteredStyles of the TStyleManager class. So using a class helper we can do the trick.

  //we need redeclare these types because are defined as <em>strict private</em> types inside of the <em>TStyleManager </em>class and are not accesible of outside.
  TStyleServicesHandle = type Pointer;
  TSourceInfo = record
    Data: TStyleServicesHandle;
    StyleClass: TCustomStyleServicesClass;
  end;
   
  //the class helper
  TStyleManagerHelper = Class Helper for TStyleManager
  strict private
    class function GetStyleSourceInfo(const StyleName: string): TSourceInfo; static;
  public
   class function GetRegisteredStyles: TDictionary<string, TSourceInfo>;
   class property StyleSourceInfo[const StyleName: string]: TSourceInfo read GetStyleSourceInfo;
  end;

class function TStyleManagerHelper.GetRegisteredStyles: TDictionary<string, TSourceInfo>;
var
  t            : TPair<string, TStyleManager.TSourceInfo>;
  SourceInfo   : TSourceInfo;
begin
 Result:=TDictionary<string, TSourceInfo>.Create;
  for t in Self.FRegisteredStyles do
  begin
   SourceInfo.Data:=t.Value.Data;
   SourceInfo.StyleClass:=t.Value.StyleClass;
   Result.Add(t.Key,SourceInfo);
  end;
end;

class function TStyleManagerHelper.GetStyleSourceInfo(const StyleName: string): TSourceInfo;
Var
 LRegisteredStyles : TDictionary<string, TSourceInfo>;
begin
  LRegisteredStyles:=TStyleManager.GetRegisteredStyles;
  try
    if LRegisteredStyles.ContainsKey(StyleName) then
      Result:=LRegisteredStyles[StyleName];
  finally
     LRegisteredStyles.Free;
  end;
end;

So in this point we have access to the TSourceInfo of each registered style. Now we can use the above class helper in this way

var
  SourceInfo: TSourceInfo;
begin
  SourceInfo:=TStyleManager.StyleSourceInfo[StyleName];
  //do something 
end;

Writting a TCustomStyle

The second part of the task is interpret the stream stored in TSourceInfo.Data, to do this we need create a TCustomStyle descendant class and use the code of the StyleUtils.inc and StyleAPI.inc files. The TCustomStyle class has a private field FSource: TObject; that store the VCL Style content (objects, fonts, colors, bitmaps and so on) this field must be filled with the content of the Stream stored in the TSourceInfo.Data. After of that you will have a new Style Class ready to use as you want.

This is the definiton of the TCustomStyleExt class.

type
  TCustomStyleHelper = Class Helper for TCustomStyle
  private
    function GetSource: TObject;
  public
    property Source: TObject read GetSource;
  End;

  TCustomStyleExt = class(TCustomStyle)
  strict private
    FStream    : TStream;
  public
    function  GetStyleInfo : TStyleInfo;
  public
    constructor Create(const FileName :string);overload;
    constructor Create(const Stream:TStream);overload;
    destructor Destroy;override;
    property StyleInfo : TStyleInfo read GetStyleInfo;
  end;

//we need include this files in the implemnetation part to use the TseStyle class
{$I 'C:\Program Files (x86)\Embarcadero\RAD Studio\9.0\source\vcl\StyleUtils.inc'}
{$I 'C:\Program Files (x86)\Embarcadero\RAD Studio\9.0\source\vcl\StyleAPI.inc'}

//Gain acess to the FSource field of the TCustomStyle
function TCustomStyleHelper.GetSource: TObject;
begin
  Result:=Self.FSource;
end;

//with this constructor we can load a Vcl Style file, without register in the system
constructor TCustomStyleExt.Create(const FileName: string);
var
  LStream: TFileStream;
begin
  LStream := TFileStream.Create(FileName, fmOpenRead);
  try
    Create(LStream);
  finally
    LStream.Free;
  end;
end;

//Load an stream with the Vcl Style Data
constructor TCustomStyleExt.Create(const Stream: TStream);
begin
  inherited Create;
  FStream:=TMemoryStream.Create;

  Stream.Seek(0, soBeginning); //set position to 0 before to copy
  FStream.CopyFrom(Stream, Stream.Size); //copy the content in a local stream
  Stream.Seek(0, soBeginning); //very importan restore the index to 0.

  FStream.Seek(0, soBeginning);//set position to 0 before to load
  TseStyle(Source).LoadFromStream(FStream);//makes the magic, fill the 
end;

//free the resources
destructor TCustomStyleExt.Destroy;
begin
  if Assigned(FStream) then
    FStream.Free;
  inherited Destroy;
end;

//Get misc info about the Vcl Style
function TCustomStyleExt.GetStyleInfo: TStyleInfo;
begin
 Result.Name        :=  TseStyle(Source).StyleSource.Name;
 Result.Author      :=  TseStyle(Source).StyleSource.Author;
 Result.AuthorEMail :=  TseStyle(Source).StyleSource.AuthorEMail;
 Result.AuthorURL   :=  TseStyle(Source).StyleSource.AuthorURL;
 Result.Version     :=  TseStyle(Source).StyleSource.Version;
end;

Creating the preview

Finally now we can create a image that represent the VCL Style.

Check out the code to create a simple image of a form using a TCustomStyle.

//draws a form (window) over a Canvas using a TCustomStyle
procedure DrawSampleWindow(Style:TCustomStyle;Canvas:TCanvas;ARect:TRect;const ACaption : string);
var
  LDetails        : TThemedElementDetails;
  CaptionDetails  : TThemedElementDetails;
  IconDetails     : TThemedElementDetails;
  IconRect        : TRect;
  BorderRect      : TRect;
  CaptionRect     : TRect;
  ButtonRect      : TRect;
  TextRect        : TRect;
  CaptionBitmap   : TBitmap;

    function GetBorderSize: TRect;
    var
      Size: TSize;
      Details: TThemedElementDetails;
      Detail: TThemedWindow;
    begin
      Result  := Rect(0, 0, 0, 0);
      Detail  := twCaptionActive;
      Details := Style.GetElementDetails(Detail);
      Style.GetElementSize(0, Details, esActual, Size);
      Result.Top := Size.cy;
      Detail := twFrameLeftActive;
      Details := Style.GetElementDetails(Detail);
      Style.GetElementSize(0, Details, esActual, Size);
      Result.Left := Size.cx;
      Detail := twFrameRightActive;
      Details := Style.GetElementDetails(Detail);
      Style.GetElementSize(0, Details, esActual, Size);
      Result.Right := Size.cx;
      Detail := twFrameBottomActive;
      Details := Style.GetElementDetails(Detail);
      Style.GetElementSize(0, Details, esActual, Size);
      Result.Bottom := Size.cy;
    end;

    function RectVCenter(var R: TRect; Bounds: TRect): TRect;
    begin
      OffsetRect(R, -R.Left, -R.Top);
      OffsetRect(R, 0, (Bounds.Height - R.Height) div 2);
      OffsetRect(R, Bounds.Left, Bounds.Top);
      Result := R;
    end;

begin
  BorderRect := GetBorderSize;

  CaptionBitmap := TBitmap.Create;
  CaptionBitmap.SetSize(ARect.Width, BorderRect.Top);

  //Draw background
  LDetails.Element := teWindow;
  LDetails.Part := 0;
  Style.DrawElement(Canvas.Handle, LDetails, ARect);

  //Draw caption border
  CaptionRect := Rect(0, 0, CaptionBitmap.Width, CaptionBitmap.Height);
  LDetails := Style.GetElementDetails(twCaptionActive);
  Style.DrawElement(CaptionBitmap.Canvas.Handle, LDetails, CaptionRect);
  TextRect := CaptionRect;
  CaptionDetails := LDetails;

  //Draw icon
  IconDetails := Style.GetElementDetails(twSysButtonNormal);
  if not Style.GetElementContentRect(0, IconDetails, CaptionRect, ButtonRect) then
    ButtonRect := Rect(0, 0, 0, 0);
  IconRect := Rect(0, 0, GetSystemMetrics(SM_CXSMICON), GetSystemMetrics(SM_CYSMICON));
  RectVCenter(IconRect, ButtonRect);
  if ButtonRect.Width > 0 then
   if Assigned(Application.MainForm) then
    DrawIconEx(CaptionBitmap.Canvas.Handle, IconRect.Left, IconRect.Top, Application.MainForm.Icon.Handle, 0, 0, 0, 0, DI_NORMAL);

  Inc(TextRect.Left, ButtonRect.Width + 5);

  //Draw buttons

  //Close button
  LDetails := Style.GetElementDetails(twCloseButtonNormal);
  if Style.GetElementContentRect(0, LDetails, CaptionRect, ButtonRect) then
   Style.DrawElement(CaptionBitmap.Canvas.Handle, LDetails, ButtonRect);

  //Maximize button
  LDetails := Style.GetElementDetails(twMaxButtonNormal);
  if Style.GetElementContentRect(0, LDetails, CaptionRect, ButtonRect) then
    Style.DrawElement(CaptionBitmap.Canvas.Handle, LDetails, ButtonRect);

  //Minimize button
  LDetails := Style.GetElementDetails(twMinButtonNormal);

  if Style.GetElementContentRect(0, LDetails, CaptionRect, ButtonRect) then
    Style.DrawElement(CaptionBitmap.Canvas.Handle, LDetails, ButtonRect);

  //Help button
  LDetails := Style.GetElementDetails(twHelpButtonNormal);
  if Style.GetElementContentRect(0, LDetails, CaptionRect, ButtonRect) then
    Style.DrawElement(CaptionBitmap.Canvas.Handle, LDetails, ButtonRect);

  if ButtonRect.Left > 0 then
    TextRect.Right := ButtonRect.Left;

  //Draw text
  Style.DrawText(CaptionBitmap.Canvas.Handle, CaptionDetails, ACaption, TextRect, [tfLeft, tfSingleLine, tfVerticalCenter]);

  //Draw caption
  Canvas.Draw(0, 0, CaptionBitmap);
  CaptionBitmap.Free;

  //Draw left border
  CaptionRect := Rect(0, BorderRect.Top, BorderRect.Left, ARect.Height - BorderRect.Bottom);
  LDetails := Style.GetElementDetails(twFrameLeftActive);
  if CaptionRect.Bottom - CaptionRect.Top > 0 then
    Style.DrawElement(Canvas.Handle, LDetails, CaptionRect);

  //Draw right border
  CaptionRect := Rect(ARect.Width - BorderRect.Right, BorderRect.Top, ARect.Width, ARect.Height - BorderRect.Bottom);
  LDetails := Style.GetElementDetails(twFrameRightActive);
  Style.DrawElement(Canvas.Handle, LDetails, CaptionRect);

  //Draw Bottom border
  CaptionRect := Rect(0, ARect.Height - BorderRect.Bottom, ARect.Width, ARect.Height);
  LDetails := Style.GetElementDetails(twFrameBottomActive);
  Style.DrawElement(Canvas.Handle, LDetails, CaptionRect);
end;

Finally joining all the pieces we can access the objects, bitmaps, colors and fonts of any VCl style, no matter where is located (embedded in a resource or in a external file).

The library and the demo application of the above image is available in the code google site.

Stay tuned for more updates of this library, the next updates will be include HSL, RGB effects to VCL Styles, vcl style explorer and so on.

Categories: Delphi, Delphi XE2, VCL Styles

Determine Genuine Windows Installation using Delphi

January 6, 2012 Rodrigo Leave a comment

Starting with Windows Vista , Microsoft introduces the The Software Licensing API (SLAPI), this API can be used to determine a genuine Microsoft Windows installation.

So using the SLIsGenuineLocal function you can check if your app is running in a genuine Windows installation.

This is the definition of the function

HRESULT WINAPI SLIsGenuineLocal(
  __in         const SLID *pAppId,
  __out        SL_GENUINE_STATE *pGenuineState,
  __inout_opt  SL_NONGENUINE_UI_OPTIONS *pUIOptions
);

The use of this funtion is very easy, only you must pass the GUID (Application Id) of Windows {55c92734-d682-4d71-983e-d6ec3f16059f} and a variable of type SL_GENUINE_STATE to receive the status of the license.

Check this delphi implementation

{$APPTYPE CONSOLE}
uses
  Windows,
  SysUtils;

type
  SLID  = TGUID;
  _SL_GENUINE_STATE = (
    SL_GEN_STATE_IS_GENUINE        = 0,
    SL_GEN_STATE_INVALID_LICENSE   = 1,
    SL_GEN_STATE_TAMPERED          = 2,
    SL_GEN_STATE_LAST              = 3
  );
  SL_GENUINE_STATE = _SL_GENUINE_STATE;

function SLIsGenuineLocal(var pAppId: SLID; var pGenuineState: SL_GENUINE_STATE; pUIOptions: Pointer): HRESULT; stdcall; external 'Slwga.dll' name 'SLIsGenuineLocal' delayed;

Var
  pAppId : SLID;
  pGenuineState: SL_GENUINE_STATE;
  Status: HRESULT;
begin
  try
    if Win32MajorVersion>= 6 then //Windows Vista o newer
    begin
      pAppId:=StringToGUID('{55C92734-D682-4D71-983E-D6EC3F16059F}');
      Status:=SLIsGenuineLocal(pAppId, pGenuineState,nil);
      if Succeeded(Status) then
        case pGenuineState of
            SL_GEN_STATE_IS_GENUINE       : Writeln('The installation is genuine.');
            SL_GEN_STATE_INVALID_LICENSE  : Writeln('The application does not have a valid license.');
            SL_GEN_STATE_TAMPERED         : Writeln('The Tampered flag of the license associated with the application is set.');
            SL_GEN_STATE_LAST             : Writeln('The state of the installation has not changed since the last time it was checked.');
        end
      else
        Writeln(SysErrorMessage(Cardinal(Status)));
    end
    else
        Writeln('OS not supported');
  except
    on E: Exception do
      Writeln(E.ClassName, ': ', E.Message);
  end;
  Readln;
end.

In windows XP does not exist the SLAPI, but you can use the Win32_WindowsProductActivation WMI class to get simmilar information. the key is check the ActivationRequired property, If return 1 then the system activation is pending for the system. else If returns 0 (zero) the activation is not required.

{$APPTYPE CONSOLE}

uses
  SysUtils,
  ActiveX,
  ComObj,
  Variants;

procedure  GetWin32_WindowsProductActivationInfo;
const
  WbemUser            ='';
  WbemPassword        ='';
  WbemComputer        ='localhost';
  wbemFlagForwardOnly = $00000020;
var
  FSWbemLocator : OLEVariant;
  FWMIService   : OLEVariant;
  FWbemObjectSet: OLEVariant;
  FWbemObject   : OLEVariant;
  oEnum         : IEnumvariant;
  iValue        : LongWord;
begin;

  if (Win32MajorVersion=5) and (Win32MinorVersion=1) then
  begin
    NullStrictConvert :=False;
    FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
    FWMIService   := FSWbemLocator.ConnectServer(WbemComputer, 'root\CIMV2', WbemUser, WbemPassword);
    FWbemObjectSet:= FWMIService.ExecQuery('SELECT * FROM Win32_WindowsProductActivation','WQL',wbemFlagForwardOnly);
    oEnum         := IUnknown(FWbemObjectSet._NewEnum) as IEnumVariant;
    while oEnum.Next(1, FWbemObject, iValue) = 0 do
    begin
      Writeln(Format('Windows is Activated  %s',[BooltoStr(FWbemObject.ActivationRequired=0,True)]));
      Writeln(Format('ActivationRequired    %d',[Integer(FWbemObject.ActivationRequired)]));
      Writeln(Format('Description           %s',[String(FWbemObject.Description)]));
      Writeln(Format('ProductID             %s',[String(FWbemObject.ProductID)]));
      if FWbemObject.ActivationRequired=1 then
      begin
        Writeln(Format('RemainingEvaluationPeriod    %d',[Integer(FWbemObject.RemainingEvaluationPeriod)]));
        Writeln(Format('RemainingGracePeriod         %d',[Integer(FWbemObject.RemainingGracePeriod)]));
      end;
      Writeln(Format('ServerName            %s',[String(FWbemObject.ServerName)]));
      Writeln(Format('SettingID             %s',[String(FWbemObject.SettingID)]));

      Writeln;
      FWbemObject:=Unassigned;
    end;
  end
  else
  Writeln('OS not supported');
end;


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

Categories: Delphi, WinApi, WMI

Exploring Delphi XE2 – VCL Styles Part II

December 16, 2011 Rodrigo 1 comment

The TStyleHook Class

The VCL Styles uses the TStyleHook class to intercept the paint methods and the Windows messages related to the Vcl Styles operations, If you have a custom control or need change the way how a control like a TEdit, TMemo, TListView, etc. is painted you must create a new Style hook class inheriting from TStyleHook or using a existing like TEditStyleHook, TComboBoxStyleHook, TMemoStyleHook ans so on . After of creating your own hook you need to register your new style hook class using the RegisterStyleHook method. Also you can unregister a register style hook using the UnRegisterStyleHook procedure.

Check these samples of using custom TStyleHook classes

A Real World Sample

All the above links are about fixing bugs related to the VCL Styles. but that is not all what you can do do with the TStyleHook classes, for example check this image of a TSynEdit component inside of an VCL application with has the Carbon Vcl Style applied.

As you can see the scrollbars are not painted using the selected VCL style. So what I can do? In this case you can write a new style hook class or use an existing hook style. After of quick look for the existing style hook classes in the Vcl.StdCtrls unit, you will discover that the TMemoStyleHook class can do the work.

So writting just one line of code

TStyleManager.Engine.RegisterStyleHook(TCustomSynEdit, TMemoStyleHook);

The magic is done.

A Little of hack

When you need register a style hook using the RegisterStyleHook method, if you try to register the same hook class twice, an EStyleEngineException will be raised, So before to try to register a new hook class you must check if is the hook is already registered for a specific control or use a place like the initialization part of a unit to register the hooks . Unfortunally great part of the VCL styles logic and the collections containing the registered style hooks, is contained in sealed classes, strict private vars and strict private static classes. So that information is not accesible directly. Because that tasks how list the registered hooks, check if a hook has previously registered or if a class has a register style hook is not a trivial task.

The TCustomStyleEngine class (of the Vcl.Themes unit) has a strict protected class property called RegisteredStyleHooks this property points to a TDictionary declarated (as a private type) like this

    TStyleHookList = TList<TStyleHookClass>;
    TStyleHookDictionary = TDictionary<TClass, TStyleHookList>;

The info contained in this property is very usefull, but due to his visibility (strict protected class property) you need to use a hack to extract such info.

So using a helper class for the TCustomStyleEngine class you can gain access to the TDictionary with the registered hooks

type
  TStyleHookList = TList<TStyleHookClass>;  //you must need declare this type again because are declarated in the private section of the TCustomStyleEngine and are not visible
  TStyleHookDictionary = TDictionary<TClass, TStyleHookList>;//you must need declare this type again because are declarated in the private section of the TCustomStyleEngine and are not visible
  TCustomStyleEngineHelper = Class Helper for TCustomStyleEngine
  public
    class function GetRegisteredStyleHooks : TStyleHookDictionary;
  end;

And now using this helper class you can construct additional functions to work with the Style hooks.

Procedure ApplyEmptyVCLStyleHook(ControlClass :TClass); 
Procedure RemoveEmptyVCLStyleHook(ControlClass :TClass);
function  IsStyleHookRegistered(ControlClass: TClass; StyleHookClass: TStyleHookClass) : Boolean;
function  GetRegisteredStylesHooks(ControlClass: TClass) : TStyleHookList;

Using these functions you can list all the registerd style hooks in the system like so

var
 RttiType  : TRttiType;
 Item      : TListItem;
 List      : TStyleHookList;
 StyleClass: TStyleHookClass;
begin
  for RttiType in TRttiContext.Create.GetTypes do
    if RttiType.IsInstance and RttiType.AsInstance.MetaclassType.InheritsFrom(TComponent) then
    begin
       List:=GetRegisteredStylesHooks(RttiType.AsInstance.MetaclassType);
       if Assigned(List) then
       begin
         Item:=ListViewStyleHooks.Items.Add;
         Item.Caption:=RttiType.Name;

         for StyleClass in List do
          Item.SubItems.Add(StyleClass.ClassName);
       end;
    end;
end;

This is the code of the unit containing all the above code

unit uVCLStyleUtils;

interface

Uses
  Vcl.Themes,
  Vcl.Styles,
  Generics.Collections,
  Classes;

type
  TStyleHookList = TList<TStyleHookClass>;

Procedure ApplyEmptyVCLStyleHook(ControlClass :TClass);
Procedure RemoveEmptyVCLStyleHook(ControlClass :TClass);
function  IsStyleHookRegistered(ControlClass: TClass; StyleHookClass: TStyleHookClass) : Boolean;
function  GetRegisteredStylesHooks(ControlClass: TClass) : TStyleHookList;

implementation

uses
 Sysutils;

type
  TStyleHookDictionary = TDictionary<TClass, TStyleHookList>;
  TCustomStyleEngineHelper = Class Helper for TCustomStyleEngine
  public
    class function GetRegisteredStyleHooks : TStyleHookDictionary;
  end;


class function TCustomStyleEngineHelper.GetRegisteredStyleHooks: TStyleHookDictionary;
begin
  Result:= Self.FRegisteredStyleHooks;
end;

function  IsStyleHookRegistered(ControlClass: TClass; StyleHookClass: TStyleHookClass) : Boolean;
var
  List : TStyleHookList;
begin
 Result:=False;
    if TCustomStyleEngine.GetRegisteredStyleHooks.ContainsKey(ControlClass) then
    begin
      List := TCustomStyleEngine.GetRegisteredStyleHooks[ControlClass];
      Result:=List.IndexOf(StyleHookClass) <> -1;
    end;
end;

function  GetRegisteredStylesHooks(ControlClass: TClass) : TStyleHookList;
begin
 Result:=nil;
    if TCustomStyleEngine.GetRegisteredStyleHooks.ContainsKey(ControlClass) then
      Result:=TCustomStyleEngine.GetRegisteredStyleHooks[ControlClass];
end;

Procedure ApplyEmptyVCLStyleHook(ControlClass :TClass);
begin
   if not IsStyleHookRegistered(ControlClass, TStyleHook) then
    TStyleManager.Engine.RegisterStyleHook(ControlClass, TStyleHook);
end;

Procedure RemoveEmptyVCLStyleHook(ControlClass :TClass);
begin
   if IsStyleHookRegistered(ControlClass, TStyleHook) then
    TStyleManager.Engine.UnRegisterStyleHook(ControlClass, TStyleHook);
end;


end.

Download a sample application with the full sourcecode from here.

Categories: Delphi, Delphi XE2, VCL Styles

Adding a Standard Context Popup Menu to a SynEdit

December 7, 2011 Rodrigo 3 comments

When you uses an Edit control like a TMemo or TEdit component a context menu pops up with options to undo, copy, paste, select all, etc.

Unfortunally the TSynEdit component doesn’t include a menu like this, so you must write you own. You can fix this in a few lines of code using a interposer class. Check this unit which implements a standard context menu for a TSynEdit component, based on a TActionList (only be sure to include the uSynEditPopupEdit unit after of the SynEdit unit in your uses list).

unit uSynEditPopupEdit;

interface

uses
 ActnList,
 Menus,
 Classes,
 SynEdit;

type
  TSynEdit = class(SynEdit.TSynEdit)
  private
    FActnList: TActionList;
    FPopupMenu : TPopupMenu;
    procedure CreateActns;
    procedure FillPopupMenu(APopupMenu : TPopupMenu);
    procedure CutExecute(Sender: TObject);
    procedure CutUpdate(Sender: TObject);
    procedure CopyExecute(Sender: TObject);
    procedure CopyUpdate(Sender: TObject);
    procedure PasteExecute(Sender: TObject);
    procedure PasteUpdate(Sender: TObject);
    procedure DeleteExecute(Sender: TObject);
    procedure DeleteUpdate(Sender: TObject);
    procedure SelectAllExecute(Sender: TObject);
    procedure SelectAllUpdate(Sender: TObject);
    procedure RedoExecute(Sender: TObject);
    procedure RedoUpdate(Sender: TObject);
    procedure UndoExecute(Sender: TObject);
    procedure UndoUpdate(Sender: TObject);
    procedure SetPopupMenu_(const Value: TPopupMenu);
    function  GetPopupMenu_: TPopupMenu;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property PopupMenu: TPopupMenu read GetPopupMenu_ write SetPopupMenu_;
  end;

implementation

uses
 SysUtils;

const
 MenuName='uSynEditPopupMenu';

procedure TSynEdit.CopyExecute(Sender: TObject);
begin
  Self.CopyToClipboard;
end;

procedure TSynEdit.CopyUpdate(Sender: TObject);
begin
  TAction(Sender).Enabled :=Self.SelAvail;
end;

procedure TSynEdit.CutExecute(Sender: TObject);
begin
  Self.CutToClipboard;
end;

procedure TSynEdit.CutUpdate(Sender: TObject);
begin
  TAction(Sender).Enabled :=Self.SelAvail and not Self.ReadOnly;
end;

procedure TSynEdit.DeleteExecute(Sender: TObject);
begin
  Self.SelText := '';
end;

procedure TSynEdit.DeleteUpdate(Sender: TObject);
begin
  TAction(Sender).Enabled :=Self.SelAvail and not Self.ReadOnly;
end;

procedure TSynEdit.PasteExecute(Sender: TObject);
begin
 Self.PasteFromClipboard;
end;

procedure TSynEdit.PasteUpdate(Sender: TObject);
begin
 TAction(Sender).Enabled :=Self.CanPaste;
end;

procedure TSynEdit.RedoExecute(Sender: TObject);
begin
 Self.Redo;
end;

procedure TSynEdit.RedoUpdate(Sender: TObject);
begin
 TAction(Sender).Enabled :=Self.CanRedo;
end;

procedure TSynEdit.SelectAllExecute(Sender: TObject);
begin
 Self.SelectAll;
end;

procedure TSynEdit.SelectAllUpdate(Sender: TObject);
begin
 TAction(Sender).Enabled :=Self.Lines.Text<>'';
end;

procedure TSynEdit.UndoExecute(Sender: TObject);
begin
 Self.Undo;
end;

procedure TSynEdit.UndoUpdate(Sender: TObject);
begin
 TAction(Sender).Enabled :=Self.CanUndo;
end;

constructor TSynEdit.Create(AOwner: TComponent);
begin
  inherited;
  FActnList:=TActionList.Create(Self);
  FPopupMenu:=TPopupMenu.Create(Self);
  FPopupMenu.Name:=MenuName;
  CreateActns;
  FillPopupMenu(FPopupMenu);
  PopupMenu:=FPopupMenu;
end;

procedure TSynEdit.CreateActns;

 procedure AddActItem(const AText:string;AShortCut : TShortCut;AEnabled:Boolean;OnExecute,OnUpdate:TNotifyEvent);
 Var
    ActionItem  : TAction;
  begin
    ActionItem:=TAction.Create(FActnList);
    ActionItem.ActionList:=FActnList;
    ActionItem.Caption:=AText;
    ActionItem.ShortCut:=AShortCut;
    ActionItem.Enabled :=AEnabled;
    ActionItem.OnExecute :=OnExecute;
    ActionItem.OnUpdate  :=OnUpdate;
  end;

begin
  AddActItem('&Undo',Menus.ShortCut(Word('Z'), [ssCtrl]),False,UndoExecute, UndoUpdate);
  AddActItem('&Redo',Menus.ShortCut(Word('Z'), [ssCtrl,ssShift]),False,RedoExecute, RedoUpdate);
  AddActItem('-',0,False,nil,nil);
  AddActItem('Cu&t',Menus.ShortCut(Word('X'), [ssCtrl]),False,CutExecute, CutUpdate);
  AddActItem('&Copy',Menus.ShortCut(Word('C'), [ssCtrl]),False,CopyExecute, CopyUpdate);
  AddActItem('&Paste',Menus.ShortCut(Word('V'), [ssCtrl]),False,PasteExecute, PasteUpdate);
  AddActItem('De&lete',0,False,DeleteExecute, DeleteUpdate);
  AddActItem('-',0,False,nil,nil);
  AddActItem('Select &All',Menus.ShortCut(Word('A'), [ssCtrl]),False,SelectAllExecute, SelectAllUpdate);
end;

procedure TSynEdit.SetPopupMenu_(const Value: TPopupMenu);
Var
  MenuItem : TMenuItem;
begin
  SynEdit.TSynEdit(Self).PopupMenu:=Value;
  if CompareText(MenuName,Value.Name)<>0 then
  begin
   MenuItem:=TMenuItem.Create(Value);
   MenuItem.Caption:='-';
   Value.Items.Add(MenuItem);
   FillPopupMenu(Value);
  end;
end;

function TSynEdit.GetPopupMenu_: TPopupMenu;
begin
  Result:=SynEdit.TSynEdit(Self).PopupMenu;
end;

destructor TSynEdit.Destroy;
begin
  FPopupMenu.Free;
  FActnList.Free;
  inherited;
end;

procedure TSynEdit.FillPopupMenu(APopupMenu : TPopupMenu);
var
  i        : integer;
  MenuItem : TMenuItem;
begin
  if Assigned(FActnList) then
  for i := 0 to FActnList.ActionCount-1 do
  begin
    MenuItem:=TMenuItem.Create(APopupMenu);
    MenuItem.Action  :=FActnList.Actions[i];
    APopupMenu.Items.Add(MenuItem);
  end;
end;

end.

And this is the final result.

Categories: Delphi

Fixing a VCL Style bug in the TPageControl and TTabControl components

November 28, 2011 Rodrigo 1 comment

The BUG

Yesterday while I’ve working migrating a personal project to Delphi XE2, I found a bug(QC #101346) in the TPageControl and TTabControl components. The issue is related to the images (icons) which are drawn in the tab controls when an ImageList is associated to the component. check the next sample image

In the above image, the form contains two components a TPageControl and a TTabControl, and both has an imagelist associated. Now if you change the VCL style of this form you will get this result.

As you can see when the Vcl Style is applied the images associated to the tabs are changed. So after a few minutes debugging the source code of the VCL when the Style is enabled, I found the issue in the DrawTab method of the TTabControlStyleHook class. This class is the responsible of call the drawing functions (of the TTabControl and TCustomTabControl) associated to a particular VCL style when and Style is enabled.

The main problem is in this line

procedure TTabControlStyleHook.DrawTab(Canvas: TCanvas; Index: Integer);
..
..
..
..
    if StyleServices.Available then
      StyleServices.DrawIcon(Canvas.Handle, Details, GlyphR, Images.Handle, Index);
..
..

As are you noted the problem is which the DrawIcon method is called passing the Index of the tab and not the index of image associated (imageindex) to the tab.

The Fix

So what I can do now?, First I report the issue to the Quality Central, and the I begin to work in a temporal solution until this problem was fixed by embarcadero. The Fix was create a new Style Hook class and register this class to be used by the style manager when a TPageControl or TTabControl are painted.

This is the source code of the style hook class

uses
  Vcl.Graphics,
  Winapi.Windows,
  Vcl.ComCtrls;

type
  TMyTabControlStyleHook = class(TTabControlStyleHook)
  strict private
    procedure AngleTextOut(Canvas: TCanvas; Angle: Integer; X, Y: Integer; const Text: string);//need to implemented because this method is strict private and can't be accessed directly
    function GetImageIndex(TabIndex: Integer): Integer;//helper class to retrieve the "real imageindex"
  strict protected
    procedure DrawTab(Canvas: TCanvas; Index: Integer); override;//a new implementation of the DrawTab method
  end;

implementation

Uses
  Vcl.Themes,
  System.Classes;

type
  THackCustomTabControl  =class (TCustomTabControl);

{ TMyTabControlStyleHook }

procedure TMyTabControlStyleHook.AngleTextOut(Canvas: TCanvas; Angle, X,
  Y: Integer; const Text: string);
var
  NewFontHandle, OldFontHandle: hFont;
  LogRec: TLogFont;
begin
  GetObject(Canvas.Font.Handle, SizeOf(LogRec), Addr(LogRec));
  LogRec.lfEscapement := Angle * 10;
  LogRec.lfOrientation := LogRec.lfEscapement;
  NewFontHandle := CreateFontIndirect(LogRec);
  OldFontHandle := SelectObject(Canvas.Handle, NewFontHandle);
  SetBkMode(Canvas.Handle, TRANSPARENT);
  Canvas.TextOut(X, Y, Text);
  NewFontHandle := SelectObject(Canvas.Handle, OldFontHandle);
  DeleteObject(NewFontHandle);
end;

//this function retrieve the "real" image index of a tab based on the tab index.
function TMyTabControlStyleHook.GetImageIndex(TabIndex: Integer): Integer;
begin
  Result:=-1;
  if (Control <> nil) and (Control is TCustomTabControl) then
   Result:=THackCustomTabControl(Control).GetImageIndex(TabIndex);
end;

//Patch to the DrawTab method
procedure TMyTabControlStyleHook.DrawTab(Canvas: TCanvas; Index: Integer);
var
  R, LayoutR, GlyphR: TRect;
  ImageWidth, ImageHeight, ImageStep, TX, TY: Integer;
  DrawState: TThemedTab;
  Details: TThemedElementDetails;
  ThemeTextColor: TColor;
  ImageIndex:Integer;
begin
  ImageIndex:=GetImageIndex(Index); //get the real image index

  if (Images <> nil) and (ImageIndex < Images.Count) then
  begin
    ImageWidth := Images.Width;
    ImageHeight := Images.Height;
    ImageStep := 3;
  end
  else
  begin
    ImageWidth := 0;
    ImageHeight := 0;
    ImageStep := 0;
  end;

  R := TabRect[Index];
  if R.Left < 0 then Exit;

  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(THackCustomTabControl(Control).Font);//access the original protected font property using a helper hack class
  LayoutR := R;
  DrawState := ttTabDontCare;
  case TabPosition of
    tpTop:
      begin
        if Index = TabIndex then
          DrawState := ttTabItemSelected
        else if (Index = HotTabIndex) and MouseInControl then
          DrawState := ttTabItemHot
        else
          DrawState := ttTabItemNormal;
      end;
    tpLeft:
      begin
        if Index = TabIndex then
          DrawState := ttTabItemLeftEdgeSelected
        else if (Index = HotTabIndex) and MouseInControl then
          DrawState := ttTabItemLeftEdgeHot
        else
          DrawState := ttTabItemLeftEdgeNormal;
      end;
    tpBottom:
      begin
        if Index = TabIndex then
          DrawState := ttTabItemBothEdgeSelected
        else if (Index = HotTabIndex) and MouseInControl then
          DrawState := ttTabItemBothEdgeHot
        else
          DrawState := ttTabItemBothEdgeNormal;
      end;
    tpRight:
      begin
        if Index = TabIndex then
          DrawState := ttTabItemRightEdgeSelected
        else if (Index = HotTabIndex) and MouseInControl then
          DrawState := ttTabItemRightEdgeHot
        else
          DrawState := ttTabItemRightEdgeNormal;
      end;
  end;

  if StyleServices.Available then
  begin
    Details := StyleServices.GetElementDetails(DrawState);
    StyleServices.DrawElement(Canvas.Handle, Details, R);
  end;

  if (Images <> nil) and (ImageIndex < Images.Count) then//check the bounds of the image index to draw
  begin
    GlyphR := LayoutR;
    case TabPosition of
      tpTop, tpBottom:
        begin
          GlyphR.Left := GlyphR.Left + ImageStep;
          GlyphR.Right := GlyphR.Left + ImageWidth;
          LayoutR.Left := GlyphR.Right;
          GlyphR.Top := GlyphR.Top + (GlyphR.Bottom - GlyphR.Top) div 2 - ImageHeight div 2;
          if (TabPosition = tpTop) and (Index = TabIndex) then
            OffsetRect(GlyphR, 0, -1)
          else if (TabPosition = tpBottom) and (Index = TabIndex) then
            OffsetRect(GlyphR, 0, 1);
        end;
      tpLeft:
        begin
          GlyphR.Bottom := GlyphR.Bottom - ImageStep;
          GlyphR.Top := GlyphR.Bottom - ImageHeight;
          LayoutR.Bottom := GlyphR.Top;
          GlyphR.Left := GlyphR.Left + (GlyphR.Right - GlyphR.Left) div 2 - ImageWidth div 2;
        end;
      tpRight:
        begin
          GlyphR.Top := GlyphR.Top + ImageStep;
          GlyphR.Bottom := GlyphR.Top + ImageHeight;
          LayoutR.Top := GlyphR.Bottom;
          GlyphR.Left := GlyphR.Left + (GlyphR.Right - GlyphR.Left) div 2 - ImageWidth div 2;
        end;
    end;
    if StyleServices.Available then
      StyleServices.DrawIcon(Canvas.Handle, Details, GlyphR, Images.Handle, ImageIndex);//Here the Magic is made using the "real" imageindex of the tab
  end;

  if StyleServices.Available then
  begin
    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
      TX := LayoutR.Left + (LayoutR.Right - LayoutR.Left) div 2 -
        Canvas.TextHeight(Tabs[Index]) div 2;
      TY := LayoutR.Top + (LayoutR.Bottom - LayoutR.Top) div 2 +
        Canvas.TextWidth(Tabs[Index]) div 2;
     if StyleServices.GetElementColor(Details, ecTextColor, ThemeTextColor) then
       Canvas.Font.Color := ThemeTextColor;
      AngleTextOut(Canvas, 90, TX, TY, Tabs[Index]);
    end
    else if TabPosition = tpRight then
    begin
      TX := LayoutR.Left + (LayoutR.Right - LayoutR.Left) div 2 +
        Canvas.TextHeight(Tabs[Index]) div 2;
      TY := LayoutR.Top + (LayoutR.Bottom - LayoutR.Top) div 2 -
        Canvas.TextWidth(Tabs[Index]) div 2;
      if StyleServices.GetElementColor(Details, ecTextColor, ThemeTextColor)
      then
        Canvas.Font.Color := ThemeTextColor;
      AngleTextOut(Canvas, -90, TX, TY, Tabs[Index]);
    end
    else
      DrawControlText(Canvas, Details, Tabs[Index], LayoutR, DT_VCENTER or DT_CENTER or DT_SINGLELINE  or DT_NOCLIP);
  end;
end;



end.

Now before to use this new class in our code we need to unregister the original style hook class and then register the new one, using the UnRegisterStyleHook and RegisterStyleHook methods, check this code.

   TStyleManager.Engine.UnRegisterStyleHook(TCustomTabControl, TTabControlStyleHook);//unregister the original style hook for the TCustomTabControl components
   TStyleManager.Engine.RegisterStyleHook(TCustomTabControl, TMyTabControlStyleHook);//register the new style hook class
   TStyleManager.Engine.UnRegisterStyleHook(TTabControl, TTabControlStyleHook);//unregister the original style hook for the TTabControl components
   TStyleManager.Engine.RegisterStyleHook(TTabControl, TMyTabControlStyleHook);//register the new style hook class

And this is the final result (Now the tabs show the correct image)

I hope which this short article was useful for you, and you see one of the uses which you can made of the RegisterStyleHook and UnRegisterStyleHook methods ;).

Download the sample project with the patch class from here.

Categories: Delphi, Delphi XE2, VCL Styles

WMI Tasks using Delphi – Services

November 16, 2011 Rodrigo 5 comments

How do I determine which services are running and which ones are not?

Use the Win32_Service class to check the state of all of the services. The state property lets you know if a service is stopped or running.

const
  wbemFlagForwardOnly = $00000020;
var
  FSWbemLocator : OLEVariant;
  FWMIService   : OLEVariant;
  FWbemObjectSet: OLEVariant;
  FWbemObject   : OLEVariant;
  oEnum         : IEnumvariant;
  iValue        : LongWord;
begin;
  FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
  FWMIService   := FSWbemLocator.ConnectServer('localhost', 'root\CIMV2', '', '');
  FWbemObjectSet:= FWMIService.ExecQuery('SELECT Name, State FROM Win32_Service','WQL',wbemFlagForwardOnly);
  oEnum         := IUnknown(FWbemObjectSet._NewEnum) as IEnumVariant;
  while oEnum.Next(1, FWbemObject, iValue) = 0 do
  begin
    Writeln(Format('Name     %s',[String(FWbemObject.Name)]));// String
    Writeln(Format('State    %s',[String(FWbemObject.State)]));// String
    Writeln;
    FWbemObject:=Unassigned;
  end;
end;

How do I stop Power Users from starting certain services?

Use the Win32_Service class and the ChangeStartMode method to set the StartMode property to Disabled. Disabled services cannot be started, and, by default, Power Users cannot change the start mode of a service.

const
  wbemFlagForwardOnly = $00000020;
var
  FSWbemLocator : OLEVariant;
  FWMIService   : OLEVariant;
  FWbemObjectSet: OLEVariant;
  FWbemObject   : OLEVariant;
  oEnum         : IEnumvariant;
  iValue        : LongWord;
begin;
  FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
  FWMIService   := FSWbemLocator.ConnectServer('localhost', 'root\CIMV2', '', '');
  FWbemObjectSet:= FWMIService.ExecQuery('SELECT * FROM Win32_Service where StartMode = "Manual"','WQL',wbemFlagForwardOnly);
  oEnum         := IUnknown(FWbemObjectSet._NewEnum) as IEnumVariant;
  while oEnum.Next(1, FWbemObject, iValue) = 0 do
  begin
    FWbemObject.Change( varEmpty, varEmpty, varEmpty, varEmpty, 'Disabled');
    FWbemObject:=Unassigned;
  end;
end;

How do I start and stop services?

Use the Win32_Service class and the StopService and StartService methods.

const
  wbemFlagForwardOnly = $00000020;
var
  FSWbemLocator : OLEVariant;
  FWMIService   : OLEVariant;
  FWbemObjectSet: OLEVariant;
  FWbemObject   : OLEVariant;
  oEnum         : IEnumvariant;
  iValue        : LongWord;
begin;
  FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
  FWMIService   := FSWbemLocator.ConnectServer('localhost', 'root\CIMV2', '', '');
  FWbemObjectSet:= FWMIService.ExecQuery('SELECT * FROM Win32_Service where Name  = "Alerter"','WQL',wbemFlagForwardOnly);
  oEnum         := IUnknown(FWbemObjectSet._NewEnum) as IEnumVariant;
  if oEnum.Next(1, FWbemObject, iValue) = 0 then
    FWbemObject.StartService();
end;

How do I change service account passwords?

Use the Win32_Service class and the Change method.

const
  wbemFlagForwardOnly = $00000020;
var
  FSWbemLocator : OLEVariant;
  FWMIService   : OLEVariant;
  FWbemObjectSet: OLEVariant;
  FWbemObject   : OLEVariant;
  oEnum         : IEnumvariant;
  iValue        : LongWord;
begin;
  FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
  FWMIService   := FSWbemLocator.ConnectServer('localhost', 'root\CIMV2', '', '');
  FWbemObjectSet:= FWMIService.ExecQuery('SELECT * FROM Win32_Service where StartName = ".\netsvc"','WQL',wbemFlagForwardOnly);
  oEnum         := IUnknown(FWbemObjectSet._NewEnum) as IEnumVariant;
  if oEnum.Next(1, FWbemObject, iValue) = 0 then
    FWbemObject.Change( varEmpty, varEmpty, varEmpty, varEmpty, varEmpty, varEmpty, varEmpty, 'password');
end;

How do I determine which services I can stop?

Use the Win32_Service class, and check the value of the AcceptStop property.

const
  wbemFlagForwardOnly = $00000020;
var
  FSWbemLocator : OLEVariant;
  FWMIService   : OLEVariant;
  FWbemObjectSet: OLEVariant;
  FWbemObject   : OLEVariant;
  oEnum         : IEnumvariant;
  iValue        : LongWord;
begin;
  FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
  FWMIService   := FSWbemLocator.ConnectServer('localhost', 'root\CIMV2', '', '');
  FWbemObjectSet:= FWMIService.ExecQuery('SELECT * FROM Win32_Service where AcceptStop = True','WQL',wbemFlagForwardOnly);
  oEnum         := IUnknown(FWbemObjectSet._NewEnum) as IEnumVariant;
  while oEnum.Next(1, FWbemObject, iValue) = 0 do
  begin
    Writeln(Format('Name     %s',[String(FWbemObject.Name)]));// String
    FWbemObject:=Unassigned;
  end;
end;

How do I find the services that must be running before I can start the DHCP service?

Query for ASSOCIATORS OF the Win32_Service class named “DHCP” that are in the Win32_DependentService class and have “Dependent” in the Role property. Role means the role of the rasman service: in this case, it is antecedent to—must be started before—the dependent services.

const
  wbemFlagForwardOnly = $00000020;
var
  FSWbemLocator : OLEVariant;
  FWMIService   : OLEVariant;
  FWbemObjectSet: OLEVariant;
  FWbemObject   : OLEVariant;
  oEnum         : IEnumvariant;
  iValue        : LongWord;
begin;
  FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
  FWMIService   := FSWbemLocator.ConnectServer('localhost', 'root\CIMV2', '', '');
  FWbemObjectSet:= FWMIService.ExecQuery('Associators Of {Win32_Service.Name="dhcp"} Where AssocClass=Win32_DependentService Role=Dependent','WQL',wbemFlagForwardOnly);
  oEnum         := IUnknown(FWbemObjectSet._NewEnum) as IEnumVariant;
  while oEnum.Next(1, FWbemObject, iValue) = 0 do
  begin
    Writeln(Format('%s  - %s',[String(FWbemObject.Name),String(FWbemObject.DisplayName)]));// String
    FWbemObject:=Unassigned;
  end;
end;

How do I find the services that require the WMI service (Winmgmt) service to be running before they can start?

Query for ASSOCIATORS OF the Win32_Service class named “winmgmt” that are in the Win32_DependentService class and have “Antecendent” in the Role property. Role means the role of the rasman service: in this case, it is antecedent to—must be started before—the dependent services.

const
  wbemFlagForwardOnly = $00000020;
var
  FSWbemLocator : OLEVariant;
  FWMIService   : OLEVariant;
  FWbemObjectSet: OLEVariant;
  FWbemObject   : OLEVariant;
  oEnum         : IEnumvariant;
  iValue        : LongWord;
begin;
  FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
  FWMIService   := FSWbemLocator.ConnectServer('localhost', 'root\CIMV2', '', '');
  FWbemObjectSet:= FWMIService.ExecQuery('Associators of {Win32_Service.Name="winmgmt"} Where AssocClass=Win32_DependentService Role=Antecedent','WQL',wbemFlagForwardOnly);
  oEnum         := IUnknown(FWbemObjectSet._NewEnum) as IEnumVariant;
  while oEnum.Next(1, FWbemObject, iValue) = 0 do
  begin
    Writeln(Format('%s  - %s',[String(FWbemObject.Name),String(FWbemObject.DisplayName)]));// String
    FWbemObject:=Unassigned;
  end;
end;

This post is based in the MSDN Entry WMI Tasks: Services

Categories: Delphi, WMI Tags: Delphi, WMI

WMI Tasks using Delphi – Registry

November 7, 2011 Rodrigo Leave a comment

How do I read registry key values using WMI?

Use the StdRegProv class, located in root\default (for Windows Server 2003, Windows XP, Windows 2000, Windows NT 4.0) and root\cimv2 namespace for newers versions of Windows . You cannot get any instances of this class because the System Registry Provider is a method and event provider only. However, you can get registry data through methods such as EnumKey or EnumValue. The Win32_Registry, located in root\cimv2 namespace, gets data about the registry as a whole, such as how large it is.

var
  FSWbemLocator   : OLEVariant;
  FWMIService     : OLEVariant;
  FWbemObjectSet  : OLEVariant;
  FInParams       : OLEVariant;
  FOutParams      : OLEVariant;
begin
  FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
  //http://msdn.microsoft.com/en-us/library/aa393664%28v=vs.85%29.aspx
  //StdRegProv is preinstalled in the WMI namespaces root\default and root\cimv2.
  //Windows Server 2003, Windows XP, Windows 2000, Windows NT 4.0, and Windows Me/98/95:  StdRegProv is available only in root\default namespace.
  FWMIService   := FSWbemLocator.ConnectServer('localhost', 'root\default', '', '');
  //For Windows Vista or Windows 7 you must use the  root\CIMV2 namespace
  //FWMIService   := FSWbemLocator.ConnectServer('localhost', 'root\CIMV2', '', '');
  FWbemObjectSet:= FWMIService.Get('StdRegProv');
  FInParams     := FWbemObjectSet.Methods_.Item('GetDWORDValue').InParameters.SpawnInstance_();
  FInParams.hDefKey:=HKEY_LOCAL_MACHINE;
  FInParams.sSubKeyName:='SOFTWARE\Microsoft\Windows\CurrentVersion\BITS';
  FInParams.sValueName:='LogFileMinMemory';
  FOutParams    := FWMIService.ExecMethod('StdRegProv', 'GetDWORDValue', FInParams);
  Writeln(Format('sValue                %d',[Integer(FOutParams.uValue)]));
  Writeln(Format('ReturnValue           %d',[Integer(FOutParams.ReturnValue)]));
end;

How do I create a new registry key?

Use the StdRegProv class, located in root\default namespace, and the CreateKey method.

var
  FSWbemLocator   : OLEVariant;
  FWMIService     : OLEVariant;
  FWbemObjectSet  : OLEVariant;
  FInParams       : OLEVariant;
  FOutParams      : OLEVariant;
begin
  FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
  //http://msdn.microsoft.com/en-us/library/aa393664%28v=vs.85%29.aspx
  //StdRegProv is preinstalled in the WMI namespaces root\default and root\cimv2.
  //Windows Server 2003, Windows XP, Windows 2000, Windows NT 4.0, and Windows Me/98/95:  StdRegProv is available only in root\default namespace.
  FWMIService   := FSWbemLocator.ConnectServer('localhost', 'root\default', '', '');
  //For Windows Vista or Windows 7 you must use the  root\CIMV2 namespace
  //FWMIService   := FSWbemLocator.ConnectServer('localhost', 'root\CIMV2', '', '');
  FWbemObjectSet:= FWMIService.Get('StdRegProv');
  FInParams     := FWbemObjectSet.Methods_.Item('CreateKey').InParameters.SpawnInstance_();
  FInParams.hDefKey:=HKEY_LOCAL_MACHINE;
  FInParams.sSubKeyName:='SOFTWARE\NewKey';
  FOutParams    := FWMIService.ExecMethod('StdRegProv', 'CreateKey', FInParams);
  Writeln(Format('ReturnValue           %d',[Integer(FOutParams.ReturnValue)]));
end;

How do I create a new registry value under a key?

Use the StdRegProv class, located in the root\default namespace, and the CreateKey method. Then use one of the Set methods, depending on what registry datatype the value is, such as the SetDWORDValue. The Set methods create a value if it does not already exist. For more information, see Mapping a Registry Data Type to a WMI Data Type.

var
  FSWbemLocator   : OLEVariant;
  FWMIService     : OLEVariant;
  FWbemObjectSet  : OLEVariant;
  FInParams       : OLEVariant;
  FOutParams      : OLEVariant;
begin
  FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
  //http://msdn.microsoft.com/en-us/library/aa393664%28v=vs.85%29.aspx
  //StdRegProv is preinstalled in the WMI namespaces root\default and root\cimv2.
  //Windows Server 2003, Windows XP, Windows 2000, Windows NT 4.0, and Windows Me/98/95:  StdRegProv is available only in root\default namespace.
  FWMIService   := FSWbemLocator.ConnectServer('localhost', 'root\default', '', '');
  //For Windows Vista or Windows 7 you must use the  root\CIMV2 namespace
  //FWMIService   := FSWbemLocator.ConnectServer('localhost', 'root\CIMV2', '', '');
  FWbemObjectSet:= FWMIService.Get('StdRegProv');
  FInParams     := FWbemObjectSet.Methods_.Item('SetExpandedStringValue').InParameters.SpawnInstance_();
  FInParams.hDefKey:=HKEY_LOCAL_MACHINE;
  FInParams.sSubKeyName:='SOFTWARE\NewKey';
  FInParams.sValueName :='Example_Expanded_String_Value';
  FInParams.sValue     :='%PATHEXT%';
  FOutParams    := FWMIService.ExecMethod('StdRegProv', 'SetExpandedStringValue', FInParams);
  Writeln(Format('ReturnValue           %d',[Integer(FOutParams.ReturnValue)]));
end;

How do I check security on a specific registry key?

Use the StdRegProv class, located in root\default namespace and the CheckAccess method. You can only check the access rights for the current user that is running the script or application. You cannot check the access rights for another specified user.

var
  FSWbemLocator   : OLEVariant;
  FWMIService     : OLEVariant;
  FWbemObjectSet  : OLEVariant;
  FInParams       : OLEVariant;
  FOutParams      : OLEVariant;
begin
  FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
  //http://msdn.microsoft.com/en-us/library/aa393664%28v=vs.85%29.aspx
  //StdRegProv is preinstalled in the WMI namespaces root\default and root\cimv2.
  //Windows Server 2003, Windows XP, Windows 2000, Windows NT 4.0, and Windows Me/98/95:  StdRegProv is available only in root\default namespace.
  FWMIService   := FSWbemLocator.ConnectServer('localhost', 'root\default', '', '');
  //For Windows Vista or Windows 7 you must use the  root\CIMV2 namespace
  //FWMIService   := FSWbemLocator.ConnectServer(Server, 'root\CIMV2', User, Pass);
  FWbemObjectSet:= FWMIService.Get('StdRegProv');
  FInParams     := FWbemObjectSet.Methods_.Item('CheckAccess').InParameters.SpawnInstance_();
  FInParams.hDefKey:=HKEY_LOCAL_MACHINE;
  FInParams.sSubKeyName:='SYSTEM\CurrentControlSet';
  FInParams.uRequired:=KEY_QUERY_VALUE;
  FOutParams    := FWMIService.ExecMethod('StdRegProv', 'CheckAccess', FInParams);
  Writeln(Format('Granted     %s',[booltoStr(Boolean(FOutParams.bGranted),True)]));
  Writeln(Format('ReturnValue %d',[Integer(FOutParams.ReturnValue)]));
end;

How do I read and write binary registry values?

Use the StdRegProv class, located in root\default namespace and the GetBinaryValue and SetBinaryValue methods. Registry values that appear in the regedt32 utility as a series of byte hexadecimal values are in the REG_BINARY data format. For more information, see Mapping a Registry Data Type to a WMI Data Type. The following code example creates a new key with a binary value. The binary value is supplied in the iValues byte array specified in Hex.

var
  FSWbemLocator   : OLEVariant;
  FWMIService     : OLEVariant;
  FWbemObjectSet  : OLEVariant;
  FInParams       : OLEVariant;
  FOutParams      : OLEVariant;
  i               : Integer;

    function ArrayToVarArray(Arr : Array Of Word):OleVariant;
    var
     i : integer;
    begin
        Result   :=VarArrayCreate([0, High(Arr)], varVariant);
        for i:=Low(Arr) to High(Arr) do
         Result[i]:=Arr[i];
    end;

begin
  FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
  //http://msdn.microsoft.com/en-us/library/aa393664%28v=vs.85%29.aspx
  //StdRegProv is preinstalled in the WMI namespaces root\default and root\cimv2.
  //Windows Server 2003, Windows XP, Windows 2000, Windows NT 4.0, and Windows Me/98/95:  StdRegProv is available only in root\default namespace.
  FWMIService   := FSWbemLocator.ConnectServer('localhost', 'root\default', '', '');
  //For Windows Vista or Windows 7 you must use the  root\CIMV2 namespace
  //FWMIService   := FSWbemLocator.ConnectServer('localhost', 'root\CIMV2', '', '');
  FWbemObjectSet:= FWMIService.Get('StdRegProv');

  //Write the binary value
  FInParams     := FWbemObjectSet.Methods_.Item('SetBinaryValue').InParameters.SpawnInstance_();
  FInParams.hDefKey:=HKEY_LOCAL_MACHINE;
  FInParams.sSubKeyName:='SOFTWARE\NewKey';
  FInParams.sValueName :='Example Binary Value';
  FInParams.uValue     :=ArrayToVarArray([1,2,3,4,5,6,7,8]);
  FOutParams    := FWMIService.ExecMethod('StdRegProv', 'SetBinaryValue', FInParams);
  Writeln(Format('ReturnValue           %d',[Integer(FOutParams.ReturnValue)]));

  //Read the binary value
  FInParams     := FWbemObjectSet.Methods_.Item('GetBinaryValue').InParameters.SpawnInstance_();
  FInParams.hDefKey:=HKEY_LOCAL_MACHINE;
  FInParams.sSubKeyName:='SOFTWARE\NewKey';
  FInParams.sValueName :='Example Binary Value';

  FOutParams    := FWMIService.ExecMethod('StdRegProv', 'GetBinaryValue', FInParams);
   for i := VarArrayLowBound(FOutParams.uValue, 1) to VarArrayHighBound(FOutParams.uValue, 1) do
    Write(Format('%d,',[Integer(FOutParams.uValue[i])]));

  Writeln;
  Writeln(Format('ReturnValue           %d',[Integer(FOutParams.ReturnValue)]));

end;

How do I read and write registry values that contain multiple strings?

Use the StdRegProv class, located in root\default namespace and the GetMultiStringValue and SetMultiStringValue methods. Registry keys that appear in the regedt32 utility as a series of strings separated by spaces are in the REG_MULTI_SZ data format. For more information, see Mapping a Registry Data Type to a WMI Data Type. The following code example creates a new key and a new multistring value.

var
  FSWbemLocator   : OLEVariant;
  FWMIService     : OLEVariant;
  FWbemObjectSet  : OLEVariant;
  FInParams       : OLEVariant;
  FOutParams      : OLEVariant;
  i               : Integer;

    function ArrayToVarArray(Arr : Array Of String):OleVariant;
    var
     i : integer;
    begin
        Result   :=VarArrayCreate([0, High(Arr)], varVariant);
        for i:=Low(Arr) to High(Arr) do
         Result[i]:=Arr[i];
    end;

begin
  FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
  //http://msdn.microsoft.com/en-us/library/aa393664%28v=vs.85%29.aspx
  //StdRegProv is preinstalled in the WMI namespaces root\default and root\cimv2.
  //Windows Server 2003, Windows XP, Windows 2000, Windows NT 4.0, and Windows Me/98/95:  StdRegProv is available only in root\default namespace.
  FWMIService   := FSWbemLocator.ConnectServer('localhost', 'root\default', '', '');
  //For Windows Vista or Windows 7 you must use the  root\CIMV2 namespace
  //FWMIService   := FSWbemLocator.ConnectServer('localhost', 'root\CIMV2', '', '');
  FWbemObjectSet:= FWMIService.Get('StdRegProv');

  //Write the Multi String Value
  FInParams     := FWbemObjectSet.Methods_.Item('SetMultiStringValue').InParameters.SpawnInstance_();
  FInParams.hDefKey:=HKEY_LOCAL_MACHINE;
  FInParams.sSubKeyName:='SOFTWARE\NewKey';
  FInParams.sValueName :='Example Multistring Value';
  FInParams.sValue     :=ArrayToVarArray(['String 1','String 2','String 3','String 4','String 5','String 6','String 7','String 8']);
  FOutParams    := FWMIService.ExecMethod('StdRegProv', 'SetMultiStringValue', FInParams);
  Writeln(Format('ReturnValue %d',[Integer(FOutParams.ReturnValue)]));


  //Read the Multi String Value
  FInParams     := FWbemObjectSet.Methods_.Item('GetMultiStringValue').InParameters.SpawnInstance_();
  FInParams.hDefKey:=HKEY_LOCAL_MACHINE;
  FInParams.sSubKeyName:='SOFTWARE\NewKey';
  FInParams.sValueName :='Example Multistring Value';

  FOutParams    := FWMIService.ExecMethod('StdRegProv', 'GetMultiStringValue', FInParams);
   for i := VarArrayLowBound(FOutParams.sValue, 1) to VarArrayHighBound(FOutParams.sValue, 1) do
    Writeln(Format('%s',[String(FOutParams.sValue[i])]));

  Writeln;
  Writeln(Format('ReturnValue           %d',[Integer(FOutParams.ReturnValue)]));
end;

This article is based in the MSDN Entry WMI Tasks: Registry

Categories: Delphi, WMI Tags: Delphi, WMI

WMI Tasks using Delphi – Processes

November 6, 2011 Rodrigo Leave a comment

How do I run an application in a hidden window?

Call the application from an app that uses the Win32_Process and Win32_ProcessStartup classes.

const
  wbemFlagForwardOnly = $00000020;
  HIDDEN_WINDOW       = 0;
var
  FSWbemLocator : OLEVariant;
  FWMIService   : OLEVariant;
  FWbemObject   : OLEVariant;
  objProcess    : OLEVariant;
  objConfig     : OLEVariant;
  ProcessID     : Integer;
begin;
  FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
  FWMIService   := FSWbemLocator.ConnectServer('localhost', 'root\CIMV2', '', '');
  FWbemObject   := FWMIService.Get('Win32_ProcessStartup');
  objConfig     := FWbemObject.SpawnInstance_;
  objConfig.ShowWindow := HIDDEN_WINDOW;
  objProcess    := FWMIService.Get('Win32_Process');
  objProcess.Create('Notepad.exe', null, objConfig, ProcessID);
  Writeln(Format('Pid %d',[ProcessID]));
end;

How do I determine which scripts are running on the local computer?

Use the Win32_Process class and return all processes with the name Cscript.exe or Wscript.exe. To determine the individual scripts running in these processes, check the value of the CommandLine property.

const
  wbemFlagForwardOnly = $00000020;
var
  FSWbemLocator : OLEVariant;
  FWMIService   : OLEVariant;
  FWbemObjectSet: OLEVariant;
  FWbemObject   : OLEVariant;
  oEnum         : IEnumvariant;
  iValue        : LongWord;
begin;
  FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
  FWMIService   := FSWbemLocator.ConnectServer('localhost', 'root\CIMV2', '', '');
  FWbemObjectSet:= FWMIService.ExecQuery(Format('SELECT Name, CommandLine FROM Win32_Process Where Name="%s" or Name="%s"',['cscript.exe','wscript.exe']),'WQL',wbemFlagForwardOnly);
  oEnum         := IUnknown(FWbemObjectSet._NewEnum) as IEnumVariant;
  while oEnum.Next(1, FWbemObject, iValue) = 0 do
  begin
    Writeln(Format('Name         %s',[String(FWbemObject.Name)]));
    Writeln(Format('Command Line %s',[String(FWbemObject.CommandLine)]));
    FWbemObject:=Unassigned;
  end;
end;

How do I find out the account name under which a process is running?

Use the Win32_Process class and the GetOwner method.

const
  wbemFlagForwardOnly = $00000020;
var
  FSWbemLocator : OLEVariant;
  FWMIService   : OLEVariant;
  FWbemObjectSet: OLEVariant;
  FWbemObject   : OLEVariant;
  oEnum         : IEnumvariant;
  iValue        : LongWord;
  NameOfUser    : OleVariant;
  UserDomain    : OleVariant;
begin;
  FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
  FWMIService   := FSWbemLocator.ConnectServer('localhost', 'root\CIMV2', '', '');
  FWbemObjectSet:= FWMIService.ExecQuery('SELECT * FROM Win32_Process','WQL',wbemFlagForwardOnly);
  oEnum         := IUnknown(FWbemObjectSet._NewEnum) as IEnumVariant;
  while oEnum.Next(1, FWbemObject, iValue) = 0 do
  begin
    FWbemObject.GetOwner(NameOfUser, UserDomain);
    Writeln(Format('Process  %s is owned by %s\%s',[String(FWbemObject.Name),String(NameOfUser), String(UserDomain)]));
    FWbemObject:=Unassigned;
  end;
end;

How do I change the priority of a running process?

Use the Win32_Process class and the SetPriority method.

const
  wbemFlagForwardOnly = $00000020;
  ABOVE_NORMAL = 32768;
var
  FSWbemLocator : OLEVariant;
  FWMIService   : OLEVariant;
  FWbemObjectSet: OLEVariant;
  FWbemObject   : OLEVariant;
  oEnum         : IEnumvariant;
  iValue        : LongWord;
  Value         : OleVariant;
begin;
  FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
  FWMIService   := FSWbemLocator.ConnectServer('localhost', 'root\CIMV2', '', '');
  FWbemObjectSet:= FWMIService.ExecQuery('SELECT * FROM Win32_Process Where Name="Notepad.exe"','WQL',wbemFlagForwardOnly);
  oEnum         := IUnknown(FWbemObjectSet._NewEnum) as IEnumVariant;
  while oEnum.Next(1, FWbemObject, iValue) = 0 do
  begin
    Value:=ABOVE_NORMAL;
    FWbemObject.SetPriority(Value);
    FWbemObject:=Unassigned;
  end;
end;

How do I terminate a process?

Use the Win32_Process class and the Terminate method.

const
  wbemFlagForwardOnly = $00000020;
var
  FSWbemLocator : OLEVariant;
  FWMIService   : OLEVariant;
  FWbemObjectSet: OLEVariant;
  FWbemObject   : OLEVariant;
  oEnum         : IEnumvariant;
  iValue        : LongWord;
begin;
  FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
  FWMIService   := FSWbemLocator.ConnectServer('localhost', 'root\CIMV2', '', '');
  FWbemObjectSet:= FWMIService.ExecQuery('SELECT * FROM Win32_Process Where Name="Notepad.exe"','WQL',wbemFlagForwardOnly);
  oEnum         := IUnknown(FWbemObjectSet._NewEnum) as IEnumVariant;
  while oEnum.Next(1, FWbemObject, iValue) = 0 do
  begin
    FWbemObject.Terminate();
    FWbemObject:=Unassigned;
  end;
end;

How do I determine how much processor time and memory each process is using?

Use the Win32_Process class and properties such as KernelModeTime, WorkingSetSize, PageFileUsage, and PageFaults.

const
  wbemFlagForwardOnly = $00000020;
var
  FSWbemLocator : OLEVariant;
  FWMIService   : OLEVariant;
  FWbemObjectSet: OLEVariant;
  FWbemObject   : OLEVariant;
  oEnum         : IEnumvariant;
  iValue        : LongWord;
  sngProcessTime: Double;
begin;
  FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
  FWMIService   := FSWbemLocator.ConnectServer('localhost', 'root\CIMV2', '', '');
  FWbemObjectSet:= FWMIService.ExecQuery('SELECT * FROM Win32_Process','WQL',wbemFlagForwardOnly);
  oEnum         := IUnknown(FWbemObjectSet._NewEnum) as IEnumVariant;
  while oEnum.Next(1, FWbemObject, iValue) = 0 do
  begin
    Writeln(Format('Process          %s',[String(FWbemObject.Name)]));
    sngProcessTime := (Int64(FWbemObject.KernelModeTime) +  Int64(FWbemObject.UserModeTime)) / 10000000.0;
    Writeln(Format('Processor Time   %n',[sngProcessTime]));
    Writeln(Format('Process Id       %d',[Integer(FWbemObject.ProcessID)]));
    Writeln(Format('Working SetSize  %d',[Int64(FWbemObject.WorkingSetSize)]));
    Writeln(Format('Page File Usage  %d',[Int64(FWbemObject.PageFileUsage)]));
    Writeln(Format('Page Faults      %d',[Int64(FWbemObject.PageFaults)]));
    FWbemObject:=Unassigned;
  end;
end;

This article is based in the MSDN entry WMI Tasks: Processes

Categories: Delphi, WMI Tags: Delphi, WMI

Older Entries

Introduction

The internals

Note : The StyleUtils.inc and StyleAPI.inc files contains code that originally was part of the SkineEngine library of Eugene A. Kryukov (Yeah Eugene is the original author of the DXScene the antecesor of FireMonkey).

Accesing the TSourceInfo

Writting a TCustomStyle

Creating the preview

The library and the demo application of the above image is available in the code google site.

The TStyleHook Class

A Real World Sample

A Little of hack

Download a sample application with the full sourcecode from here.

The BUG

The Fix

Download the sample project with the patch class from here.

How do I determine which services are running and which ones are not?

How do I stop Power Users from starting certain services?

How do I start and stop services?

How do I change service account passwords?

How do I determine which services I can stop?

How do I find the services that must be running before I can start the DHCP service?

How do I find the services that require the WMI service (Winmgmt) service to be running before they can start?

How do I read registry key values using WMI?

How do I create a new registry key?

How do I create a new registry value under a key?

How do I check security on a specific registry key?

How do I read and write binary registry values?

How do I read and write registry values that contain multiple strings?

How do I run an application in a hidden window?

How do I determine which scripts are running on the local computer?

How do I find out the account name under which a process is running?

How do I change the priority of a running process?

How do I terminate a process?

How do I determine how much processor time and memory each process is using?

Recent Posts

Archives

Blogroll

Categories

Visitors to this site

Top Clicks

Follow “The Road to Delphi - a Blog about programming”