Delphi – VCL – VCL Styles – UxTheme – WinAPI


2 Comments

Enabling XPath (selectNode, selectNodes) methods in Vcl and FireMonkey Apps

The TXMLDocument class allow you to manipulate XML files in VCL and FireMonkey Apps, but this class doesn’t implements a direct way to call the XPath related methods (selectNode, selectNodes) , so you must write a set of helper functions to call these methods.

Normally you can write something like so

 
function selectSingleNode(ADOMDocument: IDOMDocument; const nodePath: WideString): IDOMNode;
var
  LDomNodeSelect : IDomNodeSelect;
begin
  if not Assigned(ADOMDocument) or not Supports(ADOMDocument.documentElement, IDomNodeSelect, LDomNodeSelect) then
   Exit;
  //or just LDomNodeSelect:= (ADOMDocument.documentElement as IDOMNodeSelect);
  Result:=LDomNodeSelect.selectNode(nodePath);
end;

 
function SelectNodes(ADOMDocument: IDOMDocument; const nodePath: WideString): IDOMNodeList;
var
  LDomNodeSelect : IDomNodeSelect;
begin
  if not Assigned(ADOMDocument) or not Supports(ADOMDocument.documentElement, IDomNodeSelect, LDomNodeSelect) then
   Exit;
  //or just LDomNodeSelect:= (ADOMDocument.documentElement as IDOMNodeSelect);
  Result:=LDomNodeSelect.selectNodes(nodePath);
end;

And use like so.

 
var
  XmlDoc: IXMLDocument;
  LNode : IDOMNode;
  i : Integer;
begin
  XmlDoc := TXMLDocument.Create(nil);
  XmlDoc.Active := True;
  XmlDoc.Options := XmlDoc.Options + [doNodeAutoIndent];
  XmlDoc.Version := '1.0';
  ...
  ...
  LNode:=selectSingleNode(XmlDoc.DOMDocument,XPathExpr);

The above code will works fine under Windows using the MSXML provider as Default DOM Vendor, but in a FireMonkey Application which must run in OSX and Windows you must set the Default DOM Vendor to ADOM (OpenXML).

 
 DefaultDOMVendor := OpenXML4Factory.Description;

Now if you try to use the above functions (selectSingleNode, SelectNodes) under the ADOM vendor you will get an awfull exception

 
EOleException Catastrophic failure 8000FFFF

The root of this issue is located in the Tox4DOMNode.selectNode and Tox4DOMNode.selectNodes implementation of these methods, check the next code.

 
function Tox4DOMNode.selectNode(const nodePath: WideString): IDOMNode;
var
  xpath: TXpathExpression;
  xdomText: TDomText;
begin
  Result := nil;
  if not Assigned(WrapperDocument) or not Assigned(WrapperDocument.WrapperDOMImpl) then
    Exit;

  xpath := WrapperDocument.WrapperDOMImpl.FXpath; //here the xpath is set with a nil value because the FXpath was no initialized  
  xpath.ContextNode := NativeNode; //Here the App crash because xpath is nil

The FXpath field is initialized in the Tox4DOMImplementation.InitParserAgent method which is never call at least which you uses the Tox4DOMImplementation.loadFromStream or Tox4DOMImplementation.loadxml methods. So to fix this issue you must call the Tox4DOMImplementation.InitParserAgent function before to call the selectNode and selectNodes methods.

 
function selectSingleNode(ADOMDocument: IDOMDocument; const nodePath: WideString): IDOMNode;
var
  LDomNodeSelect : IDomNodeSelect;
begin
  if not Assigned(ADOMDocument) or not Supports(ADOMDocument.documentElement, IDomNodeSelect, LDomNodeSelect) then
   Exit;
  //or just LDomNodeSelect:= (ADOMDocument.documentElement as IDOMNodeSelect);
  if (DefaultDOMVendor = OpenXML4Factory.Description) then
    Tox4DOMNode(LDomNodeSelect).WrapperDocument.WrapperDOMImpl.InitParserAgent;
  Result:=LDomNodeSelect.selectNode(nodePath);
end;
 
function SelectNodes(ADOMDocument: IDOMDocument; const nodePath: WideString): IDOMNodeList;
var
  LDomNodeSelect : IDomNodeSelect;
begin
  if not Assigned(ADOMDocument) or not Supports(ADOMDocument.documentElement, IDomNodeSelect, LDomNodeSelect) then
   Exit;
  //or just LDomNodeSelect:= (ADOMDocument.documentElement as IDOMNodeSelect);
  if (DefaultDOMVendor = OpenXML4Factory.Description) then
    Tox4DOMNode(LDomNodeSelect).WrapperDocument.WrapperDOMImpl.InitParserAgent;
  Result:=LDomNodeSelect.selectNodes(nodePath);
end;

Now with these changes you will able to evaluate XPath expressions in VCL and FireMonkey Apps using the ADOM vendor.

This is a demo console App tested in Windows and OSX (XE2 and XE4)

 
{$APPTYPE CONSOLE}

uses
  {$IFDEF MSWINDOWS}
  System.Win.ComObj,
  Winapi.ActiveX,
  {$ENDIF}
  System.SysUtils,
  Xml.XMLIntf,
  Xml.adomxmldom,
  Xml.XMLDom,
  Xml.XMLDoc;

function selectSingleNode(ADOMDocument: IDOMDocument; const nodePath: WideString): IDOMNode;
var
  LDomNodeSelect : IDomNodeSelect;
begin
  if not Assigned(ADOMDocument) or not Supports(ADOMDocument.documentElement, IDomNodeSelect, LDomNodeSelect) then
   Exit;
  //or just LDomNodeSelect:= (ADOMDocument.documentElement as IDOMNodeSelect);
  if (DefaultDOMVendor = OpenXML4Factory.Description) then
    Tox4DOMNode(LDomNodeSelect).WrapperDocument.WrapperDOMImpl.InitParserAgent;
  Result:=LDomNodeSelect.selectNode(nodePath);
end;

function SelectNodes(ADOMDocument: IDOMDocument; const nodePath: WideString): IDOMNodeList;
var
  LDomNodeSelect : IDomNodeSelect;
begin
  if not Assigned(ADOMDocument) or not Supports(ADOMDocument.documentElement, IDomNodeSelect, LDomNodeSelect) then
   Exit;
  //or just LDomNodeSelect:= (ADOMDocument.documentElement as IDOMNodeSelect);
  if (DefaultDOMVendor = OpenXML4Factory.Description) then
    Tox4DOMNode(LDomNodeSelect).WrapperDocument.WrapperDOMImpl.InitParserAgent;
  Result:=LDomNodeSelect.selectNodes(nodePath);
end;

procedure  TestXPath;
var
  XmlDoc: IXMLDocument;
  Root, Book, Author, Publisher : IXMLNode;
  LNodeList : IDOMNodeList;
  LNode : IDOMNode;
  i : Integer;
begin
  XmlDoc := TXMLDocument.Create(nil);
  XmlDoc.Active := True;
  XmlDoc.Options := XmlDoc.Options + [doNodeAutoIndent];
  XmlDoc.Version := '1.0';

  Root := XmlDoc.CreateNode('BookStore');
  Root.Attributes['url'] := 'http://www.amazon.com';
  XmlDoc.DocumentElement := Root;

  Book := XmlDoc.CreateNode('Book');
  Book.Attributes['Name'] := 'Steve Jobs';
  Author := XmlDoc.CreateNode('Author');
  Author.Text := 'Walter Isaacson';
  Publisher := XmlDoc.CreateNode('Publisher');
  Publisher.Text := 'Simon Schuster (October 24, 2011)';
  Root.ChildNodes.Add(Book);
  Book.ChildNodes.Add(Author);
  Book.ChildNodes.Add(Publisher);

  Book := XmlDoc.CreateNode('Book');
  Book.Attributes['Name'] := 'Clean Code: A Handbook of Agile Software Craftsmanship';
  Author := XmlDoc.CreateNode('Author');
  Author.Text := 'Robert C. Martin';
  Publisher := XmlDoc.CreateNode('Publisher');
  Publisher.Text := 'Prentice Hall; 1 edition (August 11, 2008)';
  Root.ChildNodes.Add(Book);
  Book.ChildNodes.Add(Author);
  Book.ChildNodes.Add(Publisher);

  Book := XmlDoc.CreateNode('Book');
  Book.Attributes['Name'] := 'Paradox Lost';
  Author := XmlDoc.CreateNode('Author');
  Author.Text := 'Kress, Peter';
  Publisher := XmlDoc.CreateNode('Publisher');
  Publisher.Text := 'Prentice Hall; 1 edition (February 2, 2000)';
  Root.ChildNodes.Add(Book);
  Book.ChildNodes.Add(Author);
  Book.ChildNodes.Add(Publisher);

  Writeln(XmlDoc.XML.Text);

  Writeln('selectSingleNode');
  LNode:=selectSingleNode(XmlDoc.DOMDocument,'/BookStore/Book[2]/Author["Robert C. Martin"]');
  if LNode<>nil then
   Writeln(LNode.firstChild.nodeValue);

  Writeln;

  Writeln('SelectNodes');
  LNodeList:=SelectNodes(XmlDoc.DOMDocument,'//BookStore/Book/Author');
  if LNodeList<>nil then
    for i := 0 to LNodeList.length-1 do
      Writeln(LNodeList[i].firstChild.nodeValue);
end;

begin
 try
    ReportMemoryLeaksOnShutdown:=True;
    DefaultDOMVendor := OpenXML4Factory.Description;
    {$IFDEF MSWINDOWS}CoInitialize(nil);{$ENDIF}
    try
      TestXPath;
    finally
    {$IFDEF MSWINDOWS}CoUninitialize;{$ENDIF}
    end;
 except
    {$IFDEF MSWINDOWS}
    on E:EOleException do
        Writeln(Format('EOleException %s %x', [E.Message,E.ErrorCode]));
    {$ENDIF}
    on E:Exception do
        Writeln(E.Classname, ':', E.Message);
 end;
 Writeln;
 Writeln('Press Enter to exit');
 Readln;
end.

OSXXPATH


47 Comments

Hosting Preview Handlers in Delphi VCL Applications

In this post i will show you, how you can host an existing Preview Handler in your Delphi VCL App. Preview handlers are a lightweight and read-only preview of a file contents that are bound to a the preview pane window of the explorer or a another window, all this is done without launching the file’s associated application.

The Preview Handlers was introduced in Windows Vista and are used mainly by the Windows Explorer and other applications like MS Outlook. Hosting an existing preview handler in your application will able to display a preview of most major office document formats, media files, CAD files and so on.

To host a preview handler, first we need find the CLSID of the preview associated to a file extension, this info is located in the windows registry, the default value of the {8895b1c6-b41f-4c1c-a562-0d564250836f} subkey is the class identifier (CLSID) of the handler. An example of the extfile ProgID subkey is shown here, associating a handler of CLSID {11111111-2222-3333-4444-555555555555}.

HKEY_CLASSES_ROOT
   extfile
      shellex
         {8895b1c6-b41f-4c1c-a562-0d564250836f}
            (Default) = [REG_SZ] {11111111-2222-3333-4444-555555555555}

So you can wrote a method like this to get the CLSID of the preview handler associated to a file.

function GetPreviewHandlerCLSID(const AFileName: string): string;
var
  LRegistry: TRegistry;
  LKey: String;
begin
  LRegistry := TRegistry.Create();
  try
    LRegistry.RootKey := HKEY_CLASSES_ROOT;
    LKey := ExtractFileExt(AFileName) + '\shellex\{8895b1c6-b41f-4c1c-a562-0d564250836f}';
    if LRegistry.KeyExists(LKey) then
    begin
      LRegistry.OpenKeyReadOnly(LKey);
      Result:=LRegistry.ReadString('');
      LRegistry.CloseKey;
    end
    else
      Result := '';
  finally
    LRegistry.Free;
  end;
end;

Now with the proper CLSID we can create an instance the IPreviewHandler interface

var
    FPreviewHandler : IPreviewHandler;
begin
  ...
  ...
  FPreviewHandler := CreateComObject(LPreviewGUID) As IPreviewHandler;

The next step is determine how the preview handler was implemented using a IInitializeWithStream.Initialize, IInitializeWithFile, or IInitializeWithItem interface and then call the proper Initialize method.

  if FPreviewHandler.QueryInterface(IInitializeWithFile, LInitializeWithFile) = S_OK then
    LInitializeWithFile.Initialize(StringToOleStr(FFileName), STGM_READ)
  else
  if FPreviewHandler.QueryInterface(IInitializeWithStream, LInitializeWithStream) = S_OK then
  begin
    LFileStream := TFileStream.Create(FFileName, fmOpenRead);
    LIStream := TStreamAdapter.Create(LFileStream, soOwned) as IStream;
    LInitializeWithStream.Initialize(LIStream, STGM_READ);
  end
  else
  if FPreviewHandler.QueryInterface(IInitializeWithItem, LInitializeWithItem) = S_OK then
  begin
    SHCreateItemFromParsingName(PChar(FileName), nil, StringToGUID(GUID_ISHELLITEM), LShellItem);
    LInitializeWithItem.Initialize(LShellItem, 0);
  end;

Finally we need to call the SetWindow (passing the proper host window handle and TRect) and the DoPreview methods of the IPreviewHandler interface.

I encapsulate all the above code in a component called THostPreviewHandler and this is the source code.

{**************************************************************************************************}
{                                                                                                  }
{ Unit uHostPreview                                                                                }
{ component for host preview handlers                                                              }
{                                                                                                  }
{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License"); }
{ you may not use this file except in compliance with the License. You may obtain a copy of the    }
{ License at http://www.mozilla.org/MPL/                                                           }
{                                                                                                  }
{ Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF   }
{ ANY KIND, either express or implied. See the License for the specific language governing rights  }
{ and limitations under the License.                                                               }
{                                                                                                  }
{ The Original Code is uHostPreview.pas.                                                           }
{                                                                                                  }
{ The Initial Developer of the Original Code is Rodrigo Ruz V.   Copyright (C) 2013.               }
{ All Rights Reserved.                                                                             }
{                                                                                                  }
{**************************************************************************************************}

unit uHostPreview;

interface

uses
  ShlObj,
  Classes,
  Messages,
  Controls;

type
  THostPreviewHandler = class(TCustomControl)
  private
    FFileStream     : TFileStream;
    FPreviewGUIDStr : string;
    FFileName: string;
    FLoaded :Boolean;
    FPreviewHandler : IPreviewHandler;
    procedure SetFileName(const Value: string);
    procedure LoadPreviewHandler;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
  protected
    procedure Paint; override;
  public
    property FileName: string read FFileName write SetFileName;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  end;


implementation

uses
 SysUtils,
 Windows,
 Graphics,
 ComObj,
 ActiveX,
 Registry,
 PropSys;

constructor THostPreviewHandler.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FPreviewHandler:=nil;
  FPreviewGUIDStr:='';
  FFileStream:=nil;
end;

procedure THostPreviewHandler.Paint;
const
  Msg = 'No preview available.';
var
  lpRect: TRect;
begin
 if (FPreviewGUIDStr<>'') and (FPreviewHandler<>nil) and not FLoaded then
 begin
  FLoaded:=True;
  FPreviewHandler.DoPreview;
  FPreviewHandler.SetFocus;
 end
 else
 if FPreviewGUIDStr='' then
 begin
   lpRect:=Rect(0, 0, Self.Width, Self.Height);
   Canvas.Brush.Style :=bsClear;
   Canvas.Font.Color  :=clWindowText;
   DrawText(Canvas.Handle, PChar(Msg) ,Length(Msg), lpRect, DT_VCENTER or DT_CENTER or DT_SINGLELINE);
 end;
end;

destructor THostPreviewHandler.Destroy;
begin
  if (FPreviewHandler<>nil) then
    FPreviewHandler.Unload;

  if FFileStream<>nil then
    FFileStream.Free;

  inherited;
end;

function GetPreviewHandlerCLSID(const AFileName: string): string;
var
  LRegistry: TRegistry;
  LKey: String;
begin
  LRegistry := TRegistry.Create();
  try
    LRegistry.RootKey := HKEY_CLASSES_ROOT;
    LKey := ExtractFileExt(AFileName) + '\shellex\{8895b1c6-b41f-4c1c-a562-0d564250836f}';
    if LRegistry.KeyExists(LKey) then
    begin
      LRegistry.OpenKeyReadOnly(LKey);
      Result:=LRegistry.ReadString('');
      LRegistry.CloseKey;
    end
    else
      Result := '';
  finally
    LRegistry.Free;
  end;
end;

procedure THostPreviewHandler.LoadPreviewHandler;
const
  GUID_ISHELLITEM = '{43826d1e-e718-42ee-bc55-a1e261c37bfe}';
var
  prc                   : TRect;
  LPreviewGUID          : TGUID;
  LInitializeWithFile   : IInitializeWithFile;
  LInitializeWithStream : IInitializeWithStream;
  LInitializeWithItem   : IInitializeWithItem;
  LIStream              : IStream;
  LShellItem            : IShellItem;
begin

  FLoaded:=False;
  FPreviewGUIDStr:=GetPreviewHandlerCLSID(FFileName);
  if FPreviewGUIDStr='' then exit;

  if FFileStream<>nil then
    FFileStream.Free;

  LPreviewGUID:= StringToGUID(FPreviewGUIDStr);

  FPreviewHandler := CreateComObject(LPreviewGUID) As IPreviewHandler;
  if (FPreviewHandler = nil) then
    exit;

  if FPreviewHandler.QueryInterface(IInitializeWithFile, LInitializeWithFile) = S_OK then
    LInitializeWithFile.Initialize(StringToOleStr(FFileName), STGM_READ)
  else
  if FPreviewHandler.QueryInterface(IInitializeWithStream, LInitializeWithStream) = S_OK then
  begin
      FFileStream := TFileStream.Create(FFileName, fmOpenRead or fmShareDenyNone);
      LIStream := TStreamAdapter.Create(FFileStream, soOwned) as IStream;
      LInitializeWithStream.Initialize(LIStream, STGM_READ);
  end
  else
  if FPreviewHandler.QueryInterface(IInitializeWithItem, LInitializeWithItem) = S_OK then
  begin
    SHCreateItemFromParsingName(PChar(FileName), nil, StringToGUID(GUID_ISHELLITEM), LShellItem);
    LInitializeWithItem.Initialize(LShellItem, 0);
  end
  else
  begin
    FPreviewHandler.Unload;
    FPreviewHandler:=nil;
    exit;
  end;

  prc := ClientRect;
  FPreviewHandler.SetWindow(Self.Handle, prc);
end;

procedure THostPreviewHandler.SetFileName(const Value: string);
begin
  FFileName := Value;
  HandleNeeded;
  LoadPreviewHandler;
end;

procedure THostPreviewHandler.WMSize(var Message: TWMSize);
var
  prc  : TRect;
begin
  inherited;
  if FPreviewHandler<>nil then
  begin
    prc := ClientRect;
    FPreviewHandler.SetRect(prc);
  end;
end;

end.

And you can use it in this way

  FPreview := THostPreviewHandler.Create(Self);
  FPreview.Top := 0;
  FPreview.Left := 0;
  FPreview.Width  := Panel1.ClientWidth;
  FPreview.Height := Panel1.ClientHeight;
  FPreview.Parent := Panel1;
  FPreview.Align  := alClient;
  FPreview.FileName:=FileName;

This is a sample image of a preview handler hosted in a VCL Application.

previewhost


Check the source code on Github.


2 Comments

Added support to TSMBIOS for SMBIOS 2.8 spec.

A few weeks ago (3 Apr 2013) a new update to the System Management BIOS (SMBIOS) Reference Specification was introduced by the DMTF. So the TSMBIOS project was updated to support the SMBIOS 2.8.

The following changes was added to the 2.8 version:

  • Processor Information (Type 4):
  1. SMBIOSCR00106: processor family name correction (48h)
  2. SMBIOSCR00107: new processor family types
  3. SMBIOSCR00108: new processor family type
  4. SMBIOSCR00110: correct typo in table 24 (processor upgrade)
  5. SMBIOSCR00118: new processor family types
  6. SMBIOSCR00121: new processor family type
  7. SMBIOSCR00122: new processor upgrade type
  8. SMBIOSCR00125: add new Intel socket type
  • Memory Device (Type 17):
  1. SMBIOSCR00109: add minimum, maximum and configured voltages
  2. SMBIOSCR00114: add LRDIMM to memory device list
  • Other:
  1. SMBIOSCR00116: correct/clarify structure length fields
  2. SMBIOSCR00120: add new supported processor architectures
  3. SMBIOSCR00123: update referenced specifications
  4. Wording updates for clarity and consistency


12 Comments

Getting Processor Info using Object Pascal (Delphi / FPC) and the TSMBIOS

New_Core_I7 The SMBIOS expose the info about the installed processors in the table type 4. Check the next snippet that shows how obtain such data using the TSMBIOS (remember, if you are using FPC, you can use this library in Windows and Linux).

{$IFDEF FPC}{$mode objfpc}{$H+}
{$ELSE}
{$APPTYPE CONSOLE}
{$ENDIF}

uses
  Classes,
  TypInfo,
  SysUtils,
  uSMBIOS;

function SetToString(Info: PTypeInfo; const Value): String;
var
  LTypeInfo  : PTypeInfo;
  LIntegerSet: TIntegerSet;
  I: Integer;

begin
  Result := '';

    Integer(LIntegerSet) := 0;
    case GetTypeData(Info)^.OrdType of
      otSByte, otUByte: Integer(LIntegerSet)  := Byte(Value);
      otSWord, otUWord: Integer(LIntegerSet)  := Word(Value);
      otSLong, otULong: Integer(LIntegerSet)  := Integer(Value);
    end;

  LTypeInfo  := GetTypeData(Info)^.CompType{$IFNDEF FPC}^{$ENDIF};
  for I := 0 to SizeOf(Integer) * 8 - 1 do
    if I in LIntegerSet then
    begin
      if Result <> '' then Result := Result + ',';
      Result := Result + GetEnumName(LTypeInfo, I);
    end;
end;


procedure GetProcessorInfo;
Var
  SMBios             : TSMBios;
  LProcessorInfo     : TProcessorInformation;
  LSRAMTypes         : TCacheSRAMTypes;
begin
  SMBios:=TSMBios.Create;
  try
      WriteLn('Processor Information');
      if SMBios.HasProcessorInfo then
      for LProcessorInfo in SMBios.ProcessorInfo do
      begin
        WriteLn('Manufacturer       '+LProcessorInfo.ProcessorManufacturerStr);
        WriteLn('Socket Designation '+LProcessorInfo.SocketDesignationStr);
        WriteLn('Type               '+LProcessorInfo.ProcessorTypeStr);
        WriteLn('Familiy            '+LProcessorInfo.ProcessorFamilyStr);
        WriteLn('Version            '+LProcessorInfo.ProcessorVersionStr);
        WriteLn(Format('Processor ID       %x',[LProcessorInfo.RAWProcessorInformation^.ProcessorID]));
        WriteLn(Format('Voltaje            %n',[LProcessorInfo.GetProcessorVoltaje]));
        WriteLn(Format('External Clock     %d  Mhz',[LProcessorInfo.RAWProcessorInformation^.ExternalClock]));
        WriteLn(Format('Maximum processor speed %d  Mhz',[LProcessorInfo.RAWProcessorInformation^.MaxSpeed]));
        WriteLn(Format('Current processor speed %d  Mhz',[LProcessorInfo.RAWProcessorInformation^.CurrentSpeed]));
        WriteLn('Processor Upgrade   '+LProcessorInfo.ProcessorUpgradeStr);
        WriteLn(Format('External Clock     %d  Mhz',[LProcessorInfo.RAWProcessorInformation^.ExternalClock]));

        if SMBios.SmbiosVersion>='2.3' then
        begin
          WriteLn('Serial Number      '+LProcessorInfo.SerialNumberStr);
          WriteLn('Asset Tag          '+LProcessorInfo.AssetTagStr);
          WriteLn('Part Number        '+LProcessorInfo.PartNumberStr);
          if SMBios.SmbiosVersion>='2.5' then
          begin
            WriteLn(Format('Core Count         %d',[LProcessorInfo.RAWProcessorInformation^.CoreCount]));
            WriteLn(Format('Cores Enabled      %d',[LProcessorInfo.RAWProcessorInformation^.CoreEnabled]));
            WriteLn(Format('Threads Count      %d',[LProcessorInfo.RAWProcessorInformation^.ThreadCount]));
            WriteLn(Format('Processor Characteristics %.4x',[LProcessorInfo.RAWProcessorInformation^.ProcessorCharacteristics]));
          end;
        end;
        Writeln;

        if (LProcessorInfo.RAWProcessorInformation^.L1CacheHandle>0) and (LProcessorInfo.L2Chache<>nil)  then
        begin
          WriteLn('L1 Cache Handle Info');
          WriteLn('--------------------');
          WriteLn('  Socket Designation    '+LProcessorInfo.L1Chache.SocketDesignationStr);
          WriteLn(Format('  Cache Configuration   %.4x',[LProcessorInfo.L1Chache.RAWCacheInformation^.CacheConfiguration]));
          WriteLn(Format('  Maximum Cache Size    %d Kb',[LProcessorInfo.L1Chache.GetMaximumCacheSize]));
          WriteLn(Format('  Installed Cache Size  %d Kb',[LProcessorInfo.L1Chache.GetInstalledCacheSize]));
          LSRAMTypes:=LProcessorInfo.L1Chache.GetSupportedSRAMType;
          WriteLn(Format('  Supported SRAM Type   [%s]',[SetToString(TypeInfo(TCacheSRAMTypes), LSRAMTypes)]));
          LSRAMTypes:=LProcessorInfo.L1Chache.GetCurrentSRAMType;
          WriteLn(Format('  Current SRAM Type     [%s]',[SetToString(TypeInfo(TCacheSRAMTypes), LSRAMTypes)]));

          WriteLn(Format('  Error Correction Type %s',[ErrorCorrectionTypeStr[LProcessorInfo.L1Chache.GetErrorCorrectionType]]));
          WriteLn(Format('  System Cache Type     %s',[SystemCacheTypeStr[LProcessorInfo.L1Chache.GetSystemCacheType]]));
          WriteLn(Format('  Associativity         %s',[LProcessorInfo.L1Chache.AssociativityStr]));
        end;

        if (LProcessorInfo.RAWProcessorInformation^.L2CacheHandle>0)  and (LProcessorInfo.L2Chache<>nil)  then
        begin
          WriteLn('L2 Cache Handle Info');
          WriteLn('--------------------');
          WriteLn('  Socket Designation    '+LProcessorInfo.L2Chache.SocketDesignationStr);
          WriteLn(Format('  Cache Configuration   %.4x',[LProcessorInfo.L2Chache.RAWCacheInformation^.CacheConfiguration]));
          WriteLn(Format('  Maximum Cache Size    %d Kb',[LProcessorInfo.L2Chache.GetMaximumCacheSize]));
          WriteLn(Format('  Installed Cache Size  %d Kb',[LProcessorInfo.L2Chache.GetInstalledCacheSize]));
          LSRAMTypes:=LProcessorInfo.L2Chache.GetSupportedSRAMType;
          WriteLn(Format('  Supported SRAM Type   [%s]',[SetToString(TypeInfo(TCacheSRAMTypes), LSRAMTypes)]));
          LSRAMTypes:=LProcessorInfo.L2Chache.GetCurrentSRAMType;
          WriteLn(Format('  Current SRAM Type     [%s]',[SetToString(TypeInfo(TCacheSRAMTypes), LSRAMTypes)]));

          WriteLn(Format('  Error Correction Type %s',[ErrorCorrectionTypeStr[LProcessorInfo.L2Chache.GetErrorCorrectionType]]));
          WriteLn(Format('  System Cache Type     %s',[SystemCacheTypeStr[LProcessorInfo.L2Chache.GetSystemCacheType]]));
          WriteLn(Format('  Associativity         %s',[LProcessorInfo.L2Chache.AssociativityStr]));
        end;

        if (LProcessorInfo.RAWProcessorInformation^.L3CacheHandle>0) and (LProcessorInfo.L3Chache<>nil) then
        begin
          WriteLn('L3 Cache Handle Info');
          WriteLn('--------------------');
          WriteLn('  Socket Designation    '+LProcessorInfo.L3Chache.SocketDesignationStr);
          WriteLn(Format('  Cache Configuration   %.4x',[LProcessorInfo.L3Chache.RAWCacheInformation^.CacheConfiguration]));
          WriteLn(Format('  Maximum Cache Size    %d Kb',[LProcessorInfo.L3Chache.GetMaximumCacheSize]));
          WriteLn(Format('  Installed Cache Size  %d Kb',[LProcessorInfo.L3Chache.GetInstalledCacheSize]));
          LSRAMTypes:=LProcessorInfo.L3Chache.GetSupportedSRAMType;
          WriteLn(Format('  Supported SRAM Type   [%s]',[SetToString(TypeInfo(TCacheSRAMTypes), LSRAMTypes)]));
          LSRAMTypes:=LProcessorInfo.L3Chache.GetCurrentSRAMType;
          WriteLn(Format('  Current SRAM Type     [%s]',[SetToString(TypeInfo(TCacheSRAMTypes), LSRAMTypes)]));

          WriteLn(Format('  Error Correction Type %s',[ErrorCorrectionTypeStr[LProcessorInfo.L3Chache.GetErrorCorrectionType]]));
          WriteLn(Format('  System Cache Type     %s',[SystemCacheTypeStr[LProcessorInfo.L3Chache.GetSystemCacheType]]));
          WriteLn(Format('  Associativity         %s',[LProcessorInfo.L3Chache.AssociativityStr]));
        end;

        Readln;
      end
      else
      Writeln('No Processor Info was found');
  finally
   SMBios.Free;
  end;
end;        

ProcessorInfo2


2 Comments

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

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

QC 114032

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

TColorBoxQC

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

TColorBoxFix

QC 114040

The TComboBoxEx control have a similar issue.

TcomboboxExQc

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

TcomboboxExFix

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


6 Comments

Getting Memory Device Info using Object Pascal (Delphi / FPC) and the TSMBIOS

dram-moduleIf you need to know what type of RAM is installed in your system or how is the manufacturer of your memory device, you can try reading the SPD (Serial presence detect) info directly (but not all the memory devices exposes the SPD info and reading the SPD require Kernel Mode access) , use the Win32_PhysicalMemory WMI class (but depending of the manufacturer the WMI fails to get info about some memory properties like the memory type) or using the SMBIOS.

Using the SMBIOS you can get most of the info related to the memory devices installed like manufacturer, type, speed, serial number and so on. The next snippet show how using the TSMBIOS and Delphi (or FPC) you can retrieve such data.

{$IFDEF FPC}{$mode objfpc}{$H+}
{$ELSE}
{$APPTYPE CONSOLE}
{$ENDIF}

uses
  Classes,
  SysUtils,
  uSMBIOS;

procedure GetMemoryDeviceInfo;
Var
  SMBios : TSMBios;
  LMemoryDevice  : TMemoryDeviceInformation;
begin
  SMBios:=TSMBios.Create;
  try
      WriteLn('Memory Device Information');
      WriteLn('-------------------------');

      if SMBios.HasMemoryDeviceInfo then
      for LMemoryDevice in SMBios.MemoryDeviceInformation do
      begin
        WriteLn(Format('Total Width    %d bits',[LMemoryDevice.RAWMemoryDeviceInfo^.TotalWidth]));
        WriteLn(Format('Data Width     %d bits',[LMemoryDevice.RAWMemoryDeviceInfo^.DataWidth]));
        WriteLn(Format('Size           %d Mbytes',[LMemoryDevice.GetSize]));
        WriteLn(Format('Form Factor    %s',[LMemoryDevice.GetFormFactor]));
        WriteLn(Format('Device Locator %s',[LMemoryDevice.GetDeviceLocatorStr]));
        WriteLn(Format('Bank Locator   %s',[LMemoryDevice.GetBankLocatorStr]));
        WriteLn(Format('Memory Type    %s',[LMemoryDevice.GetMemoryTypeStr]));
        WriteLn(Format('Speed          %d MHz',[LMemoryDevice.RAWMemoryDeviceInfo^.Speed]));
        WriteLn(Format('Manufacturer   %s',[LMemoryDevice.ManufacturerStr]));
        WriteLn(Format('Serial Number  %s',[LMemoryDevice.SerialNumberStr]));
        WriteLn(Format('Asset Tag      %s',[LMemoryDevice.AssetTagStr]));
        WriteLn(Format('Part Number    %s',[LMemoryDevice.PartNumberStr]));

        WriteLn;

        if LMemoryDevice.RAWMemoryDeviceInfo^.PhysicalMemoryArrayHandle>0 then
        begin
          WriteLn('  Physical Memory Array');
          WriteLn('  ---------------------');
          WriteLn('  Location         '+LMemoryDevice.PhysicalMemoryArray.GetLocationStr);
          WriteLn('  Use              '+LMemoryDevice.PhysicalMemoryArray.GetUseStr);
          WriteLn('  Error Correction '+LMemoryDevice.PhysicalMemoryArray.GetErrorCorrectionStr);
          if LMemoryDevice.PhysicalMemoryArray.RAWPhysicalMemoryArrayInformation^.MaximumCapacity<>$80000000 then
            WriteLn(Format('  Maximum Capacity %d Kb',[LMemoryDevice.PhysicalMemoryArray.RAWPhysicalMemoryArrayInformation^.MaximumCapacity]))
          else
            WriteLn(Format('  Maximum Capacity %d bytes',[LMemoryDevice.PhysicalMemoryArray.RAWPhysicalMemoryArrayInformation^.ExtendedMaximumCapacity]));

          WriteLn(Format('  Memory devices   %d',[LMemoryDevice.PhysicalMemoryArray.RAWPhysicalMemoryArrayInformation^.NumberofMemoryDevices]));
        end;
        WriteLn;
      end
      else
      Writeln('No Memory Device Info was found');
  finally
   SMBios.Free;
  end;
end;

begin
 try
    GetMemoryDeviceInfo;
 except
    on E:Exception do
        Writeln(E.Classname, ':', E.Message);
 end;
 Writeln('Press Enter to exit');
 Readln;
end.

memoryInfo

Note: Remember if you uses FPC, you can use this library in linux as well :)


4 Comments

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

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

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

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

LVWindows

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

LVStyles2

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

This is part of the code with the bug

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

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

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

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

LVStylesFix


1 Comment

How distinguish when Windows was installed in Legacy BIOS or UEFI mode using Delphi?

As part of the TSMBIOS project, I needed a method to distinguish when Windows was installed in Legacy BIOS or UEFI mode. The solution was provided by the GetFirmwareEnvironmentVariable function.

The msdn documentation states

Firmware variables are not supported on a legacy BIOS-based system. The GetFirmwareEnvironmentVariable function will always fail on a legacy BIOS-based system, or if Windows was installed using legacy BIOS on a system that supports both legacy BIOS and UEFI. To identify these conditions, call the function with a dummy firmware environment name such as an empty string (“”) for the lpName parameter and a dummy GUID such as “{00000000-0000-0000-0000-000000000000}” for the lpGuid parameter. On a legacy BIOS-based system, or on a system that supports both legacy BIOS and UEFI where Windows was installed using legacy BIOS, the function will fail with ERROR_INVALID_FUNCTION. On a UEFI-based system, the function will fail with an error specific to the firmware, such as ERROR_NOACCESS, to indicate that the dummy GUID namespace does not exist.
.

So the Delphi code to detect such condition will be something like so

{$APPTYPE CONSOLE}

uses
  Windows,
  SysUtils;

function GetFirmwareEnvironmentVariableA(lpName, lpGuid: LPCSTR; pBuffer: Pointer;
  nSize: DWORD): DWORD; stdcall; external kernel32 name 'GetFirmwareEnvironmentVariableA';

begin
  try
    GetFirmwareEnvironmentVariableA('','{00000000-0000-0000-0000-000000000000}', nil,0);
    if (GetLastError = ERROR_INVALID_FUNCTION) then
      Writeln('Legacy BIOS')
    else
      Writeln('UEFI Boot Mode');
  except
    on E: Exception do
      Writeln(E.ClassName, ': ', E.Message);
  end;
  Readln;
end.