The Road to Delphi

Delphi – Free Pascal – Oxygene


5 Comments

Delphi Dev. Shell Tools – New features 3

Features added to the new version of the Delphi Dev. Shell Tools.

  • Full refactoring of the code related to drawing the items bitmaps and icons, now only 32 bpp bmp (Windows 8/7/Vista) and 32-bit with alpha channel icons (Windows XP) are used.
  • Added support for Delphi XE5. Now you can build your Delphi Android projects with a single click without open the Delphi IDE.

dproj_menu_new

  • Added feature to extended the Shell extension with custom scripts (.bat). This new option allows create a script and associate a set of extensions.

This is a preview of the window to register the scripts.

Custom_Tools

You can setup the Sub-Menu (Group) where the new option will be displayed, the label and image for the menu entry, the extensions associated, set an option to run the script as Administrator and use a small set of macros.

The tool includes as set of predefined scripts for FPC and Delphi which you can use as example to register you own most used Apps.

FPC & Lazarus

  • h2pas is a small command-line utility that can be used to translate C header files to pascal units. The Free Pascal team uses it to make import units for important C libraries such as GTK or MySQL.
  • ppdep is a small utility that scans a program or unit and creates a depend file that can be used for inclusion by make. It understands conditional symbols and interdependency of units.
  • ptop is a configurable source formatter. It pretty-prints your pascal code, much like indent does for C code.
  • ppudump dumps the contents of a unit in human-readable format. It understands older versions of units and gracefully handles unknown (future) versions.

For more info check the Tools that come with Free Pascal page.

Delphi

For more info check the RAD Studio Command-Line Utilities page

External Tools

  • Regsvr32, This command-line tool registers .dll and ocx files as command components in the registry.


17 Comments

Delphi Dev. Shell Tools – New features 2

I just added a set of new features to the Delphi Dev. Shell Tools

Settings options, Checksum calculation (CRC32, MD4, MD5, SHA1, SHA256, SHA384, SHA512), ,menu customization, copy the content of the selected file to the clipboard, enable/disable check for updates, support for more file extensions (.lpr, .lfm, .proj).

Check the next images.

Support for add custom extensions in some tasks

New option to show in the main menu or a sub menu the available tasks

Checksum calculation CRC32, MD4, MD5, SHA1, SHA256, SHA384, SHA512



11 Comments

Delphi Dev. Shell Tools – New features

I just added a set of new features to the Delphi Dev. Shell Tools like support for Lazarus, a new owner draw panel to the shell menu that shows information about the selected Delphi project file (.dpr, .dproj) like target platforms, framework (FMX, VCL), current configuration (debug, release) and Application Type (library, package, application)

Check the next screenshots



Remember that you can check for new versions of the tool using the check for updates button en the About option.


11 Comments

Introducing The Delphi Dev. Shell Tools

LogofUpdate : This project now is hosted on Github.


 

I just started a new  Delphi Project called  Delphi Dev. Shell Tools the aim of this shell extension is facilitate some common tasks like open, build and edit a Delphi project , as always the project is hosted in the Code Google site and you can checkout the full source code using any Subversion client. Let me know any comment or suggestion via this blog,  to report any issue or suggest a new feature please use the issue page of the project.

Installer

Download the installer from here

Common Tasks for .pas, .dpr, .inc, .pp, .dpk, . dproj, .frm, .fmx, .rc extensions

  • Copy file path to the clipboard : Copy the path of the selected file to the clipboard.
  • Copy full file-name to the clipboard : Copy the full file-name (Path + Name) of the selected file to the clipboard.
  • Open In Notepad : Open the selected file in the notepad editor.
  • Open In associated text editor : Open the selected file in the associated text editor.
  • Open cmd here : Open the cmd.exe application in the folder of the selected file
  • Open RAD Studio Command prompt here : Open the RAD Studio Command prompt (of any installed Delphi version) in the folder of the selected file

  • Format Source Code : Format the source code using the formatter.exe tool (included since Delphi 2010)
  • Run Touch : Executes the touch.exe tool
  • Open with Delphi(N) : Open the selected file with any version of Delphi or Rad Studio installed

  • Compile resource file : Compile the selected file (.rc) with BRCC32.exe tool

Specific Tasks for .dpr, .dproj files (Rad Studio Projects), .groupproj (Group Projects)

  • Run MSBuild (Default Settings) : Execute MSBuild using the default settings of the selected .dproj file
  • Run MSBuild With .. : Execute MSBuild using any of the platforms and targets detected in the selected .dproj file
  • MSBuild: Allow to select and execute the MSBuild tool (associated to any version of the RAD Studio installed) using the default configuration of the project


8 Comments

Listing the running user applications under osx using Delphi

The NSWorkspace class provides a set of methods and properties which allow open and manipulate files, applications and others useful tasks. One of these properties can be used to list the running applications. The property is runningApplications , this will return an array of NSRunningApplication elements representing the running applications. Unfortunately the definition of this interface (NSRunningApplication) in the Macapi.AppKit is incomplete.

  NSRunningApplication = interface(NSObject)
    ['{96F4D9CA-0732-4557-BA1F-177958903B8F}']
    function activateWithOptions(options: NSApplicationActivationOptions): Boolean; cdecl;
    function activationPolicy: NSApplicationActivationPolicy; cdecl;
    function executableArchitecture: NSInteger; cdecl;
    function forceTerminate: Boolean; cdecl;
    function hide: Boolean; cdecl;
    function isActive: Boolean; cdecl;
    function isFinishedLaunching: Boolean; cdecl;
    function isHidden: Boolean; cdecl;
    function isTerminated: Boolean; cdecl;
    function processIdentifier: Integer; cdecl;
    function terminate: Boolean; cdecl;
    function unhide: Boolean; cdecl;
  end;

As you can see in the above definition there is not a property to retrieve the application name or path. So the first task in order to retrieve the list of the running applications is add the missing properties like so.

  NSRunningApplicationEx = interface(NSObject)
    ['{96F4D9CA-0732-4557-BA1F-177958903B8F}']
    function activateWithOptions(options: NSApplicationActivationOptions): Boolean; cdecl;
    function activationPolicy: NSApplicationActivationPolicy; cdecl;
    function executableArchitecture: NSInteger; cdecl;
    function forceTerminate: Boolean; cdecl;
    function hide: Boolean; cdecl;
    function isActive: Boolean; cdecl;
    function isFinishedLaunching: Boolean; cdecl;
    function isHidden: Boolean; cdecl;
    function isTerminated: Boolean; cdecl;
    function processIdentifier: Integer; cdecl;
    function terminate: Boolean; cdecl;
    function unhide: Boolean; cdecl;

    //Added functions(properties)
    //Indicates the URL to the application's executable.
    function executableURL : NSURL; cdecl;//@property (readonly) NSURL *executableURL;
    //Indicates the name of the application.  This is dependent on the current localization of the referenced app, and is suitable for presentation to the user.
    function localizedName : NSString; cdecl;//@property (readonly) NSString *localizedName;
    //Indicates the URL to the application's bundle, or nil if the application does not have a bundle.
    function bundleURL : NSURL; cdecl;//@property (readonly) NSURL *bundleURL;
    //Indicates the CFBundleIdentifier of the application, or nil if the application does not have an Info.plist.
    function bundleIdentifier : NSString; cdecl;//@property (readonly) NSString *bundleIdentifier;
    //Indicates the date when the application was launched.  This property is not available for all applications.  Specifically, it is not available for applications that were launched without going through LaunchServices.   */
    function launchDate : NSDate;cdecl;//@property (readonly) NSDate *launchDate;
    //Returns the icon of the application.
    function icon : NSImage;cdecl;//@property (readonly) NSImage *icon;
  end;
  TNSRunningApplicationEx = class(TOCGenericImport<NSRunningApplicationClass, NSRunningApplicationEx>)  end;

Now using a TStringGrid we can list all the user applications running

var
  LWorkSpace : NSWorkspace;
  LApp       : NSRunningApplicationEx;
  LFormatter : NSDateFormatter;
  i : integer;
  LArray     : NSArray;
begin
  LWorkSpace:=TNSWorkspace.create;//or TNsWorkspace.Wrap(TNsWorkSpace.OCClass.sharedWorkspace);
  LArray:=LWorkSpace.runningApplications;
  //NSDateFormatter Class Reference
  //https://developer.apple.com/library/mac/#documentation/Cocoa/Reference/Foundation/Classes/NSDateFormatter_Class/Reference/Reference.html
  TNSDateFormatter.OCClass.setDefaultFormatterBehavior(NSDateFormatterBehavior10_4);
  LFormatter:=TNSDateFormatter.Create;
  LFormatter.setDateFormat(NSSTR('HH:mm:ss YYYY/MM/dd'));
  if LArray<>nil then
  begin
    StringGrid1.RowCount:=LArray.count;
   for i := 0 to LArray.count-1 do
   begin
     LApp:= TNSRunningApplicationEx.Wrap(LArray.objectAtIndex(i));
     StringGrid1.Cells[0,i]:=LApp.processIdentifier.ToString();
     if LApp.launchDate<>nil then
     StringGrid1.Cells[1,i]:=string(LFormatter.stringFromDate(LApp.launchDate).UTF8String);
     StringGrid1.Cells[2,i]:=string(LApp.localizedName.UTF8String);
     StringGrid1.Cells[3,i]:=string(LApp.executableURL.path.UTF8String);

     if LApp.bundleIdentifier<>nil then
       StringGrid1.Cells[4,i]:=string(LApp.bundleIdentifier.UTF8String);

     if LApp.bundleURL<>nil then
       StringGrid1.Cells[5,i]:=string(LApp.bundleURL.path.UTF8String);

      case LApp.executableArchitecture of
        NSBundleExecutableArchitectureI386  :   StringGrid1.Cells[6,i]:='I386';
        NSBundleExecutableArchitecturePPC   :   StringGrid1.Cells[6,i]:='PPC';
        NSBundleExecutableArchitecturePPC64 :   StringGrid1.Cells[6,i]:='PPC64';
        NSBundleExecutableArchitectureX86_64:   StringGrid1.Cells[6,i]:='X86_64';
      end;
   end;
  end;
end;

And this is the final result.

Mac OS X Lion

Note : The runningApplications property only list the user applications and does not provide information about every process on the system. In order to access to all the process you can use the sysctl function with the CTL_KERN, KERN_PROC, KERN_PROC_ALL values.

Download the sample Firemonkey project from Github.


Leave a comment

Getting System information in OSX and iOS using Delphi (XE2, XE3, XE4) Part 2

This is the continuation of the Getting System information in OSX and iOS using Delphi (XE2, XE3, XE4) Part 1 article.

Inside of the Posix.SysSysctl unit (which is the translation for the sysctl.h file) you can find a set of arrays (CTL_NAMES, CTL_KERN_NAMES, CTL_HW_NAMES, CTL_USER_NAMES, CTL_VM_NAMES) which contains the alias names for the system information elements, so using the items of these arrays you can build the name parameter for the SysCtlByName method.

For example if you want to access the kernel version you can build the alias like so

  Name:=PAnsiChar(CTL_NAMES[CTL_KERN].ctl_name+'.'+CTL_KERN_NAMES[KERN_VERSION].ctl_name);//kern.version

And then using the SysCtlByName method

function KernelVersion: AnsiString;
var
  res : Integer;
  len : size_t;
  p, Name: PAnsiChar;
begin
  len := SizeOf(Result);
  Name:=PAnsiChar(CTL_NAMES[CTL_KERN].ctl_name+'.'+CTL_KERN_NAMES[KERN_VERSION].ctl_name);
  res:=SysCtlByName(Name, nil, @len, nil, 0);
   if (len>0) and (res=0)  then
   begin
     GetMem(p, len);
     try
       res:=SysCtlByName(Name, p, @len, nil, 0);
       if res=0 then
        Result:=p;
     finally
       FreeMem(p);
     end;
   end;
end;

Another option is use these definitions for build a set of methods to retrieve all the system info included in these structs.

Try the next sample project.

{$APPTYPE CONSOLE}

{$R *.res}

uses
  System.Classes,
  System.Types,
  Posix.Errno,
  Posix.SysTypes,
  Posix.SysSysctl,
  System.SysUtils;

function GetsysctlIntValue(mib: TIntegerDynArray) : integer;
var
  len : size_t;
  res : integer;
begin
   len := sizeof(Result);
   res:=sysctl(@mib[0], 2, @Result, @len, nil, 0);
   if res<>0 then
    Result:=-1;// RaiseLastOSError;
end;

function GetsysctlInt64Value(mib: TIntegerDynArray) : Int64;
var
  len : size_t;
  res : integer;
begin
   len := sizeof(Result);
   res:=sysctl(@mib[0], 2, @Result, @len, nil, 0);
   if res<>0 then
     Result:=-1; //RaiseLastOSError;
end;

function GetsysctlStrValue(mib: TIntegerDynArray) : AnsiString;
var
  len : size_t;
  p   : PAnsiChar;
  res : integer;
begin
   Result:='';
   res:=sysctl(@mib[0], 2, nil, @len, nil, 0);
   if (len>0) and (res=0)  then
   begin
     GetMem(p, len);
     try
       res:=sysctl(@mib[0], 2, p, @len, nil, 0);
       if res=0 then
        Result:=p;
     finally
       FreeMem(p);
     end;
   end;
end;

procedure  ListKernelValues;
var
  mib : TIntegerDynArray;
  i   : Integer;
begin
 Writeln('High kernel limits');
 Writeln('------------------');
 for i:=0 to KERN_MAXID-1 do
 begin
    mib:=TIntegerDynArray.Create(CTL_KERN, i);
    case CTL_KERN_NAMES[i].ctl_type of
     CTLTYPE_NODE  :  Writeln(Format('%s.%-18s %s',[CTL_NAMES[CTL_KERN].ctl_name, CTL_KERN_NAMES[i].ctl_name, '[node]']));
     CTLTYPE_OPAQUE:  Writeln(Format('%s.%-18s %s',[CTL_NAMES[CTL_KERN].ctl_name, CTL_KERN_NAMES[i].ctl_name, '[structure]']));
     CTLTYPE_INT   :  Writeln(Format('%s.%-18s %d',[CTL_NAMES[CTL_KERN].ctl_name, CTL_KERN_NAMES[i].ctl_name, GetsysctlIntValue(mib)]));
     CTLTYPE_QUAD  :  Writeln(Format('%s.%-18s %d',[CTL_NAMES[CTL_KERN].ctl_name, CTL_KERN_NAMES[i].ctl_name, GetsysctlInt64Value(mib)]));
     CTLTYPE_STRING : Writeln(Format('%s.%-18s %s',[CTL_NAMES[CTL_KERN].ctl_name, CTL_KERN_NAMES[i].ctl_name, GetsysctlStrValue(mib)]));
    end;
 end;
 Writeln;
end;

procedure  ListGenericCPU_IO_Values;
var
  mib : TIntegerDynArray;
  i   : Integer;
begin
 Writeln('Generic CPU, I/O');
 Writeln('-----------------');
 for i:=0 to HW_MAXID-1 do
 begin
    mib:=TIntegerDynArray.Create(CTL_HW, i);
    case CTL_HW_NAMES[i].ctl_type of
     CTLTYPE_NODE  :  Writeln(Format('%s.%-18s %s',[CTL_NAMES[CTL_HW].ctl_name, CTL_HW_NAMES[i].ctl_name, '[node]']));
     CTLTYPE_OPAQUE:  Writeln(Format('%s.%-18s %s',[CTL_NAMES[CTL_HW].ctl_name, CTL_HW_NAMES[i].ctl_name, '[structure]']));
     CTLTYPE_INT   :  Writeln(Format('%s.%-18s %d',[CTL_NAMES[CTL_HW].ctl_name, CTL_HW_NAMES[i].ctl_name, GetsysctlIntValue(mib)]));
     CTLTYPE_QUAD  :  Writeln(Format('%s.%-18s %d',[CTL_NAMES[CTL_HW].ctl_name, CTL_HW_NAMES[i].ctl_name, GetsysctlInt64Value(mib)]));
     CTLTYPE_STRING : Writeln(Format('%s.%-18s %s',[CTL_NAMES[CTL_HW].ctl_name, CTL_HW_NAMES[i].ctl_name, GetsysctlStrValue(mib)]));
    end;
 end;
 Writeln;
end;

procedure  ListUserLevelValues;
var
  mib : TIntegerDynArray;
  i   : Integer;
begin
 mib:=TIntegerDynArray.Create(CTL_USER, 0);
 Writeln('User-level');
 Writeln('----------');
 for i:=0 to USER_MAXID-1 do
 begin
    mib[1]:=i;
    case CTL_USER_NAMES[i].ctl_type of
     CTLTYPE_NODE  :  Writeln(Format('%s.%-18s %s',[CTL_NAMES[CTL_USER].ctl_name, CTL_USER_NAMES[i].ctl_name, '[node]']));
     CTLTYPE_OPAQUE:  Writeln(Format('%s.%-18s %s',[CTL_NAMES[CTL_USER].ctl_name, CTL_USER_NAMES[i].ctl_name, '[structure]']));
     CTLTYPE_INT   :  Writeln(Format('%s.%-18s %d',[CTL_NAMES[CTL_USER].ctl_name, CTL_USER_NAMES[i].ctl_name, GetsysctlIntValue(mib)]));
     CTLTYPE_QUAD  :  Writeln(Format('%s.%-18s %d',[CTL_NAMES[CTL_USER].ctl_name, CTL_USER_NAMES[i].ctl_name, GetsysctlInt64Value(mib)]));
     CTLTYPE_STRING : Writeln(Format('%s.%-18s %s',[CTL_NAMES[CTL_USER].ctl_name, CTL_USER_NAMES[i].ctl_name, GetsysctlStrValue(mib)]));
    end;
 end;
 Writeln;
end;

procedure  ListVMValues;
var
  mib : TIntegerDynArray;
  i   : Integer;
begin
 Writeln('Virtual memory');
 Writeln('-------------');
 for i:=0 to VM_MAXID-1 do
 begin
    mib:=TIntegerDynArray.Create(CTL_VM, i);
    case CTL_VM_NAMES[i].ctl_type of
     CTLTYPE_NODE  :  Writeln(Format('%s.%-18s %s',[CTL_NAMES[CTL_VM].ctl_name, CTL_VM_NAMES[i].ctl_name, '[node]']));
     CTLTYPE_OPAQUE:  Writeln(Format('%s.%-18s %s',[CTL_NAMES[CTL_VM].ctl_name, CTL_VM_NAMES[i].ctl_name, '[structure]']));
     CTLTYPE_INT   :  Writeln(Format('%s.%-18s %d',[CTL_NAMES[CTL_VM].ctl_name, CTL_VM_NAMES[i].ctl_name, GetsysctlIntValue(mib)]));
     CTLTYPE_QUAD  :  Writeln(Format('%s.%-18s %d',[CTL_NAMES[CTL_VM].ctl_name, CTL_VM_NAMES[i].ctl_name, GetsysctlInt64Value(mib)]));
     CTLTYPE_STRING : Writeln(Format('%s.%-18s %s',[CTL_NAMES[CTL_VM].ctl_name, CTL_VM_NAMES[i].ctl_name, GetsysctlStrValue(mib)]));
    end;
 end;
 Writeln;
end;

begin
  try
    ListKernelValues;
    ListGenericCPU_IO_Values;
    ListUserLevelValues;
    ListVMValues;
  except
    on E: Exception do
      Writeln(E.ClassName, ': ', E.Message);
  end;
end.


3 Comments

Getting System information in OSX and iOS using Delphi (XE2, XE3, XE4) Part 1

In the following article you can learn how to use the sysctl, sysctlbyname and sysctlnametomib functions to get system information (kernel values, hardware, networking, file system, machine specific and user related data) under the OSX and iOS systems.

sysctl

int sysctl(int *name, u_int namelen, void *oldp, size_t *oldlenp, void *newp, size_t newlen);

The sysctl allows you retrieves and set system information, the data returned from the sysctl() function consists of integers (int32, int64), strings(AnsiStrings) and structs (records). this function is defined in the Posix.SysSysctl (SysSysctlAPI.inc) unit

Note : The Posix.SysSysctl unit is a partial translation the sysctl.h file.

function sysctl(name: PInteger; namelen: cardinal; oldp: Pointer; oldlen: Psize_t; newp: Pointer; newlen: size_t): Integer; cdecl; external libc name _PU + 'sysctl';

name : This parameter receive a pointer to a Management Information Base (MIB) style value, which is only a array of integers. Each element of this array must be filled with the values related to the info to read or write.

The number of elements of this array, depends of the data to be obtained or modified, most of times only we need to pass and fill a mib with 2 elements (integer values). The first element indicates the level(location) of the info and the second element indicates the value to retrieve.

These are the possible values for the first element of the mib.

           Name           Value            Description
           CTL_DEBUG      $00000005        Debugging
           CTL_VFS        $00000003        File system
           CTL_HW         $00000006        Generic CPU, I/O
           CTL_KERN       $00000001        High kernel limits
           CTL_MACHDEP    $00000007        Machine dependent
           CTL_NET        $00000004        Networking
           CTL_USER       $00000008        User-level
           CTL_VM         $00000002        Virtual memory 

Note: All these values are already defined in the Posix.SysSysctl unit.

So if we want access to the kernel related values we must fill the mib like so

var
  mib : array[0..1] of Integer;
...
...
 mib[0] := CTL_KERN;

The second element value is related to the first level and the possible values are defined in the Posix.SysSysctl unit as well, for example to get the max processes supported by the system we must use the KERN_MAXPROC($00000006) value.

var
  mib : array[0..1] of Integer;
...
...
 mib[0] := CTL_KERN;
 mib[1] := KERN_MAXPROC;

namelen : This parameter is the length of the mib structure.
oldp: Must be filled with a pointer to the buffer to receive. The info which can be a integer, int64, a AnsiString(MarshaledAString) or a record.
oldlen: Indicates the size of the oldp parameter.
newp: This parameter must be filled with a pointer to the buffer to with the info to set up, when you don’t modify the data you must pass a nil value.
newlen: Indicates the size of the newp parameter.

So with all the above info now you can write a function to retrieve the max processes supported, check this sample code which retrieves a integer value.

function MaxProcesses : Integer;
var
  mib : array[0..1] of Integer;
  res : Integer;
  len : size_t;
begin

 mib[0] := CTL_KERN;
 mib[1] := KERN_MAXPROC;

 len := sizeof(Result);
 res:=sysctl(@mib, Length(mib), @Result, @len, nil, 0);
 if res<>0 then
  RaiseLastOSError;
end;

To get a Int64 value the code is very similar, check this sample which get the size of the memory installed on the system using the CTL_HW level and the HW_MEMSIZE value.

function MemSize : Int64;
var
  mib : array[0..1] of Integer;
  res : Integer;
  len : size_t;
begin
 mib[0] := CTL_HW;
 mib[1] := HW_MEMSIZE;

 len := sizeof(Result);
 res := sysctl(@mib, Length(mib), @Result, @len, nil, 0);
 if res<>0 then
  RaiseLastOSError;
end;

If you want retrieve a string value, you must get the length of the value before to allocate the buffer, to do this you must pass a nil value in the oldp parameter like so.

sysctl(@mib, Length(mib), nil, @len, nil, 0)

The next code shows how to get a string(ascii) type using the sysctl function.

function KernelVersion : AnsiString;
var
  mib : array[0..1] of Integer;
  res : Integer;
  len : size_t;
  p   : MarshaledAString;//in XE2 you can use the PAnsiChar type
begin
 mib[0] := CTL_KERN;
 mib[1] := KERN_VERSION;
 //get the length of the buffer 
 res := sysctl(@mib, Length(mib), nil, @len, nil, 0);
 if res<>0 then
   RaiseLastOSError;
 //allocates the buffer
 GetMem(p, len);
 try
   res := sysctl(@mib, Length(mib), p, @len, nil, 0);
   if res<>0 then
     RaiseLastOSError;
   Result:=p;
 finally
   FreeMem(p);
 end;
end;

Finally we can use the sysctl function to retrieve complex structures(records) passing a pointer to the record to hold the data.

Try this sample which get the clock rate values from the kernel.

procedure GetClockInfo;
type
 clockinfo = record
	hz      : Integer;
	tick    : Integer;
	tickadj : Integer;
	stathz  : Integer;
	profhz  : Integer;
  end;

(*
struct clockinfo {
	int	hz;	   	/* clock frequency */
	int	tick;		/* micro-seconds per hz tick */
	int	tickadj;/* clock skew rate for adjtime() */
	int	stathz;		/* statistics clock frequency */
	int	profhz;		/* profiling clock frequency */
};
*)

var
  mib : array[0..1] of Integer;
  res : Integer;
  len : size_t;
  clock : clockinfo;
begin
 FillChar(clock, sizeof(clock), 0);
 mib[0] := CTL_KERN;
 mib[1] := KERN_CLOCKRATE;
 len := sizeof(clock);
 res:=sysctl(@mib, Length(mib), @clock, @len, nil, 0);
 if res<>0 then
   RaiseLastOSError;

 Writeln(Format('clock frequency             %d',[clock.hz]));
 Writeln(Format('micro-seconds per hz tick   %d',[clock.tick]));
 Writeln(Format('clock skew rate for adjtime %d',[clock.tickadj]));
 Writeln(Format('statistics clock frequency  %d',[clock.stathz]));
 Writeln(Format('profiling clock frequency   %d',[clock.profhz]));
end;

sysctlbyname

int sysctlbyname(const char *name, void *oldp, size_t *oldlenp, void *newp, size_t newlen);

The sysctlbyname works in the same way which the sysctl, the only difference is which the values are accessed using a alias string. because that you don’t need pass a mib structure and length to this function.

function sysctlbyname(Name: MarshaledAString; oldp: Pointer; oldlen: Psize_t; newp: Pointer; newlen: size_t): Integer; cdecl; external libc name _PU + 'sysctlbyname';

name: this parameter is the alias for the info to access and is composed by the level splus the string representation of the value to get, because that you don’t need pass a mib structure.

These are the possible values for the first level element

           Name           string 
           CTL_DEBUG      debug
           CTL_VFS        vfs
           CTL_HW         hw
           CTL_KERN       kern
           CTL_MACHDEP    machdep
           CTL_NET        net
           CTL_USER       user
           CTL_VM         vm

This is a sample list of some of the values which you can use in the name parameter of the sysctlbyname function.

     Name                            Type           
     kern.ostype                     string       
     kern.osrelease                  string       
     kern.osrevision                 integer      
     kern.version                    string       
     kern.maxvnodes                  integer       
     kern.maxproc                    integer       
     kern.maxfiles                   integer       
     kern.argmax                     integer      
     kern.securelevel                integer       
     kern.hostname                   string        
     kern.hostid                     integer       
     kern.clockrate                  struct       
     kern.posix1version              integer      
     kern.ngroups                    integer      
     kern.job_control                integer      
     kern.saved_ids                  integer      
     kern.link_max                   integer      
     kern.max_canon                  integer      
     kern.max_input                  integer      
     kern.name_max                   integer      
     kern.path_max                   integer      
     kern.pipe_buf                   integer      
     kern.chown_restricted           integer      
     kern.no_trunc                   integer      
     kern.vdisable                   integer      
     kern.boottime                   struct       
     vm.loadavg                      struct       
     vm.swapusage                    struct       
     machdep.console_device          dev_t        
     net.inet.ip.forwarding          integer       
     net.inet.ip.redirect            integer       
     net.inet.ip.ttl                 integer       
     net.inet.icmp.maskrepl          integer      
     net.inet.udp.checksum           integer       
     hw.machine                      string       
     hw.model                        string       
     hw.ncpu                         integer      
     hw.byteorder                    integer      
     hw.physmem                      integer      
     hw.usermem                      integer      
     hw.memsize                      integer      
     hw.pagesize                     integer      
     user.cs_path                    string       
     user.bc_base_max                integer      
     user.bc_dim_max                 integer      
     user.bc_scale_max               integer      
     user.bc_string_max              integer      
     user.coll_weights_max           integer      
     user.expr_nest_max              integer      
     user.line_max                   integer      
     user.re_dup_max                 integer      
     user.posix2_version             integer      
     user.posix2_c_bind              integer      
     user.posix2_c_dev               integer      
     user.posix2_char_term           integer      
     user.posix2_fort_dev            integer      
     user.posix2_fort_run            integer      
     user.posix2_localedef           integer      
     user.posix2_sw_dev              integer      
     user.posix2_upe                 integer      

Note : You can get a full list of the supported values running the sysctl -A command from a Terminal.

Finally this code shows how use the SysCtlByName function to retrieve the number of cpus installed.

function NumberOfCPU: Integer;
var
  res : Integer;
  len : size_t;
begin
  len := SizeOf(Result);
  res:=SysCtlByName('hw.ncpu', @Result, @len, nil, 0);
  if res<>0 then
    RaiseLastOSError;
end;

Note : The sysctl function runs in about a third the time as the same request made via the sysctlbyname, so when is possible uses sysctl instead.

sysctlnametomib

int sysctlnametomib(const char *name, int *mibp, size_t *sizep);

The sysctlnametomib function fill a mib structure using a alias a string. this function is intended for use by apps that want to repeatedly use the same variable.

function sysctlnametomib(name: MarshaledAString; mibp: PInteger; sizep: Psize_t): Integer; cdecl; external libc name _PU + 'sysctlnametomib';

name: ASCII representation of the value to retrieve.
mibp: pointer to the mib structure to fill.
sizep: pointer to the length of the mib structure to fill.

var
  mib : array[0..1] of Integer;
  res : Integer;
  len : size_t;
begin
  len := Length(mib);
  sysctlnametomib('hw.physicalcpu', @mib, @len);
  //now the mib structure is filled with the proper values to call the sysctl function. 

Error Handling

All the above functions returns a 0 values when the execution was succefull, otherwise an error code is returned, this code can be obtained using the errno (Posix.Errno) or the GetLastError function.

The following errors may be reported (theses values and meanings are defined in the osx/ErrnoTypes.inc file)

     [EFAULT]           The buffer name, oldp, newp, or length pointer oldlenp contains an invalid address.
     [EINVAL]           The name array is less than two or greater than CTL_MAXNAME.
     [EINVAL]           A non-null newp is given and its specified length in newlen is too large or too
                        small.
     [ENOMEM]           The length pointed to by oldlenp is too short to hold the requested value.
     [ENOMEM]           The smaller of either the length pointed to by oldlenp or the estimated size of the
                        returned data exceeds the system limit on locked memory.
     [ENOMEM]           Locking the buffer oldp, or a portion of the buffer if the estimated size of the
                        data to be returned is smaller, would cause the process to exceed its per-process
                        locked memory limit.
     [ENOTDIR]          The name array specifies an intermediate rather than terminal name.
     [EISDIR]           The name array specifies a terminal name, but the actual name is not terminal.
     [ENOENT]           The name array specifies a value that is unknown.
     [EPERM]            An attempt is made to set a read-only value.
     [EPERM]            A process without appropriate privilege attempts to set a value.

This a full sample console app which summarizes this article.

{$APPTYPE CONSOLE}

uses
  //System.Classes,
  //System.Types,
  //Posix.Errno,
  Posix.SysTypes,
  Posix.SysSysctl,
  System.SysUtils;

//https://developer.apple.com/library/mac/#documentation/Darwin/Reference/ManPages/man3/sysctl.3.html
//https://developer.apple.com/library/mac/documentation/Darwin/Reference/ManPages/man8/sysctl.8.html


function NumberOfCPU: Integer;
var
  res : Integer;
  len : size_t;
begin
  len := SizeOf(Result);
  res:=SysCtlByName('hw.ncpu', @Result, @len, nil, 0);
  if res<>0 then
    RaiseLastOSError;
end;


function MaxProcesses : Integer;
var
  mib : array[0..1] of Integer;
  res : Integer;
  len : size_t;
begin

 mib[0] := CTL_KERN;
 mib[1] := KERN_MAXPROC;

 len := sizeof(Result);
 res:=sysctl(@mib, Length(mib), @Result, @len, nil, 0);
 if res<>0 then
  RaiseLastOSError;
end;

function MemSize : Int64;
var
  mib : array[0..1] of Integer;
  res : Integer;
  len : size_t;
begin
 mib[0] := CTL_HW;
 mib[1] := HW_MEMSIZE;

 len := sizeof(Result);
 res := sysctl(@mib, Length(mib), @Result, @len, nil, 0);
 if res<>0 then
  RaiseLastOSError;
end;


function KernelVersion : AnsiString;
var
  mib : array[0..1] of Integer;
  res : Integer;
  len : size_t;
  p   : MarshaledAString;//in XE2 use  PAnsiChar
begin
 mib[0] := CTL_KERN;
 mib[1] := KERN_VERSION;
 res := sysctl(@mib, Length(mib), nil, @len, nil, 0);
 if res<>0 then
   RaiseLastOSError;
 GetMem(p, len);
 try
   res := sysctl(@mib, Length(mib), p, @len, nil, 0);
   if res<>0 then
     RaiseLastOSError;
   Result:=p;
 finally
   FreeMem(p);
 end;
end;


procedure GetClockInfo;
type
 clockinfo = record
	hz      : Integer;
	tick    : Integer;
	tickadj : Integer;
	stathz  : Integer;
	profhz  : Integer;
  end;

(*
struct clockinfo {
	int	hz;	   	/* clock frequency */
	int	tick;		/* micro-seconds per hz tick */
	int	tickadj;/* clock skew rate for adjtime() */
	int	stathz;		/* statistics clock frequency */
	int	profhz;		/* profiling clock frequency */
};
*)

var
  mib : array[0..1] of Integer;
  res : Integer;
  len : size_t;
  clock : clockinfo;
begin
 FillChar(clock, sizeof(clock), 0);
 mib[0] := CTL_KERN;
 mib[1] := KERN_CLOCKRATE;
 len := sizeof(clock);
 res:=sysctl(@mib, Length(mib), @clock, @len, nil, 0);
 if res<>0 then
   RaiseLastOSError;

 Writeln(Format('clock frequency             %d',[clock.hz]));
 Writeln(Format('micro-seconds per hz tick   %d',[clock.tick]));
 Writeln(Format('clock skew rate for adjtime %d',[clock.tickadj]));
 Writeln(Format('statistics clock frequency  %d',[clock.stathz]));
 Writeln(Format('profiling clock frequency   %d',[clock.profhz]));
end;

begin
  try
    Writeln(Format('max processes     %d',[MaxProcesses]));
    Writeln(Format('number of cpus    %d',[NumberOfCPU]));
    Writeln(Format('physical ram size %s',[FormatFloat('#,', MemSize)]));
    Writeln(Format('Kernel Version    %s',[KernelVersion]));
    GetClockInfo;
  except
    on E: Exception do
      Writeln(E.ClassName, ': ', E.Message);
  end;
end.


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.