The Road to Delphi

Delphi – Free Pascal – Oxygene


3 Comments

Determine Genuine Windows Installation using Delphi

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.


5 Comments

Two ways to get the command line of another process using delphi

Note : for a updated version of the code check the Github repo.


Today I will show you how you can retrieve the Command line parameters of an external application from Delphi using the WinApi and the WMI. In order to understand how the Command line parameters are stored and treated by the system, I recommend which you read this article from  Raymond Chen .

The WinApi way

In order to get the command line from an external process using the WinAPI, you must access to the PEB (Process Environment Block) of the application. To get the PEB you can use the NtQueryInformationProcess function

NTSTATUS WINAPI NtQueryInformationProcess(
  __in       HANDLE ProcessHandle,
  __in       PROCESSINFOCLASS ProcessInformationClass,
  __out      PVOID ProcessInformation,
  __in       ULONG ProcessInformationLength,
  __out_opt  PULONG ReturnLength
);

 

function  NtQueryInformationProcess(
  ProcessHandle : THandle;
  ProcessInformationClass : DWORD;
  ProcessInformation : Pointer;
  ProcessInformationLength : ULONG;
  ReturnLength : PULONG
 ): LongInt; stdcall; external 'ntdll.dll';

Passing the ProcessBasicInformation value in the ProcessInformationClass parameter and a buffer to hold the PROCESS_BASIC_INFORMATION returned in the ProcessInformation.

This is the official (MSDN) definition for the PROCESS_BASIC_INFORMATION structure

typedef struct _PROCESS_BASIC_INFORMATION {
    PVOID Reserved1;
    PPEB PebBaseAddress;
    PVOID Reserved2[2];
    ULONG_PTR UniqueProcessId;
    PVOID Reserved3;
} PROCESS_BASIC_INFORMATION;

And this a more friendly delphi translation of this structure using the NTinterlnals.net site

  PROCESS_BASIC_INFORMATION = packed record
    ExitStatus: DWORD;
    PebBaseAddress: Pointer;
    AffinityMask: DWORD;
    BasePriority: DWORD;
    UniqueProcessId: DWORD;
    InheritedUniquePID:DWORD;
  end;

The key field in this structure is PebBaseAddress, which stores the address of the PEB. from this point now you must digging inside of the PEB structure again

typedef struct _PEB {
  BYTE                          Reserved1[2];
  BYTE                          BeingDebugged;
  BYTE                          Reserved2[1];
  PVOID                         Reserved3[2];
  PPEB_LDR_DATA                 Ldr;
  PRTL_USER_PROCESS_PARAMETERS  ProcessParameters;
  BYTE                          Reserved4[104];
  PVOID                         Reserved5[52];
  PPS_POST_PROCESS_INIT_ROUTINE PostProcessInitRoutine;
  BYTE                          Reserved6[128];
  PVOID                         Reserved7[1];
  ULONG                         SessionId;
} PEB, *PPEB;

and retrieve the value of the ProcessParameters field which is a pointer to a RTL_USER_PROCESS_PARAMETERS structure

typedef struct _RTL_USER_PROCESS_PARAMETERS {
  BYTE           Reserved1[16];
  PVOID          Reserved2[10];
  UNICODE_STRING ImagePathName;
  UNICODE_STRING CommandLine;
} RTL_USER_PROCESS_PARAMETERS, *PRTL_USER_PROCESS_PARAMETERS;

Finally you can note which the CommandLine field stores the info which are looking for.

The WinAPI Delphi Code

This is the Delphi source which retrieves the Command line parameters from an external application
Notes :

  1. the next code uses hard-coded offsets to read specific locations of the PEB to avoid the declaration the full structures required (feel free to declare these structures and avoid the offsets).
  2. this code only works for 32 bits process because the structure of the PEB differs from 32 to 64 processes.
  3. to gain access to the processes owned by the system the code set the  SeDebugPrivilege token before to use the OpenProcess function.
//Author Rodrigo Ruz V.
//2011-07-20
{$APPTYPE CONSOLE}
uses
  SysUtils,
  Windows;

type
  _UNICODE_STRING = record
    Length: Word;
    MaximumLength: Word;
    Buffer: LPWSTR;
  end;
  UNICODE_STRING = _UNICODE_STRING;

  PROCESS_BASIC_INFORMATION = packed record
    ExitStatus: DWORD;
    PebBaseAddress: Pointer;
    AffinityMask: DWORD;
    BasePriority: DWORD;
    UniqueProcessId: DWORD;
    InheritedUniquePID:DWORD;
  end;

  function  NtQueryInformationProcess(ProcessHandle : THandle; ProcessInformationClass : DWORD; ProcessInformation : Pointer; ProcessInformationLength : ULONG; ReturnLength : PULONG ): LongInt; stdcall; external 'ntdll.dll';

function GetCommandLineFromPid(PID: THandle): string;
const
  STATUS_SUCCESS             = $00000000;
  SE_DEBUG_NAME              = 'SeDebugPrivilege';
  OffsetProcessParametersx32 = $10;//16
  OffsetCommandLinex32       = $40;//64
var
  ProcessHandle        : THandle;
  rtlUserProcAddress   : Pointer;
  CommandLine          : UNICODE_STRING;
  CommandLineContents  : WideString;
  ProcessBasicInfo     : PROCESS_BASIC_INFORMATION;
  ReturnLength         : Cardinal;
  TokenHandle          : THandle;
  lpLuid               : TOKEN_PRIVILEGES;
  OldlpLuid            : TOKEN_PRIVILEGES;
begin
  Result:='';
  if OpenProcessToken(GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, TokenHandle) then
  begin
    try

      if not LookupPrivilegeValue(nil, SE_DEBUG_NAME, lpLuid.Privileges[0].Luid) then
        RaiseLastOSError
      else
      begin
        lpLuid.PrivilegeCount := 1;
        lpLuid.Privileges[0].Attributes  := SE_PRIVILEGE_ENABLED;
        ReturnLength := 0;
        OldlpLuid    := lpLuid;
        //Set the SeDebugPrivilege privilege
        if not AdjustTokenPrivileges(TokenHandle, False, lpLuid, SizeOf(OldlpLuid), OldlpLuid, ReturnLength) then RaiseLastOSError;
      end;

      ProcessHandle := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, false, PID);
      if ProcessHandle=0 then RaiseLastOSError
      else
      try
        // get the PROCESS_BASIC_INFORMATION to access to the PEB Address
        if (NtQueryInformationProcess(ProcessHandle,0{=>ProcessBasicInformation},@ProcessBasicInfo, sizeof(ProcessBasicInfo), @ReturnLength)=STATUS_SUCCESS) and (ReturnLength=SizeOf(ProcessBasicInfo)) then
        begin
          //get the address of the RTL_USER_PROCESS_PARAMETERS struture
          if not ReadProcessMemory(ProcessHandle, Pointer(Longint(ProcessBasicInfo.PEBBaseAddress) + OffsetProcessParametersx32), @rtlUserProcAddress, sizeof(Pointer), ReturnLength) then
            RaiseLastOSError
          else
          if ReadProcessMemory(ProcessHandle, Pointer(Longint(rtlUserProcAddress) + OffsetCommandLinex32), @CommandLine, sizeof(CommandLine), ReturnLength) then
          begin
            SetLength(CommandLineContents, CommandLine.length);
            //get the CommandLine field
            if ReadProcessMemory(ProcessHandle, CommandLine.Buffer, @CommandLineContents[1], CommandLine.Length, ReturnLength) then
             Result := WideCharLenToString(PWideChar(CommandLineContents), CommandLine.length div 2)
            else
            RaiseLastOSError;
          end;
        end
        else
        RaiseLastOSError;
      finally
        CloseHandle(ProcessHandle);
      end;
    finally
      CloseHandle(TokenHandle);
    end;
  end
  else
  RaiseLastOSError;
end;

begin
 try
   Writeln(GetCommandLineFromPid(5440));
 except
    on E:Exception do
        Writeln(E.Classname, ':', E.Message);
 end;
 Readln;
end.

The WMI way

The WMI provides a very reliable and easy way to access the Command line parameters from an external process, all you must to do is use the Win32_Process wmi class and look in the CommandLine property.

The WMI Delphi Code

Notes

  1. The next code can retrieve the command line for 32 and 64 bits processes.
  2. The code uses Late binding to access the WMI, if you want use another way to access the WMI from Delphi (like direct COM access or importing th e Microsoft scripting library) take a look to the Delphi WMI Code creator.
  3. You can change the credentials of the ConnectServer function to access to the command line parameters of a remote machine process.
{$APPTYPE CONSOLE}

uses
  Windows,
  SysUtils,
  ActiveX,
  Variants,
  ComObj;

function  GetCommandLineFromPid(ProcessId:DWORD): string;
var
  FSWbemLocator : OLEVariant;
  FWMIService   : OLEVariant;
  FWbemObjectSet: OLEVariant;
begin;
  Result:='';
  FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
  FWMIService   := FSWbemLocator.ConnectServer('localhost', 'root\CIMV2', '', '');
  //if the pid not exist a EOleException exception will be raised with the code $80041002 - Object Not Found
  FWbemObjectSet:= FWMIService.Get(Format('Win32_Process.Handle="%d"',[ProcessId]));
  Result:=FWbemObjectSet.CommandLine;
end;

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


6 Comments

Changing the glass composition color (DWM) using delphi

Before to read this post you must be aware which the material exposed  make uses of undocumented windows functions, so you must know the risks involved in using them.   If you are not comfortably with that please  skip this post.

Some days ago  reading this article,  I found a very nice application called Aura (Written in C#), which  calculates average color of  the desktop background image or the active window icon and sets it as Aero Glass color.

Check this demo video of Aura

After of that, I check the Desktop Window Manager (DWM) reference to find the functions which allow change the color of the  glass in Windows Vista/7,  but I can’t found any documented function to do this. Finally digging in the source code of the Aura application I found two undocumented functions called DwmGetColorizationParameters and DwmSetColorizationParameter which makes this task. Then I check the parameters, the call conventions and finally I took the dwmapi.dll file and after of analyze using IDA and the Microsoft public symbol server, I found a lot of undocumented functions.

At this point originally I was going to include the details of the disassembled code, but to avoid legal problems I just going to include the dump of the exported functions

This is the dump of the exported functions of this library (dwmapi.dll) , as you can see exist a lot of undocumented functions.

dwmapi.1; Index 100;undocumented
dwmapi.2; Index 101;undocumented
DwmEnableComposition; Index 102;
dwmapi.4; Index 103;undocumented
dwmapi.5; Index 104;undocumented
dwmapi.6; Index 105;undocumented
dwmapi.7; Index 106;undocumented
dwmapi.8; Index 107;undocumented
dwmapi.9; Index 108;undocumented
dwmapi.10; Index 109;undocumented
dwmapi.11; Index 110;undocumented
DwmAttachMilContent; Index 111;
dwmapi.13; Index 112;undocumented
dwmapi.14; Index 113;undocumented
dwmapi.15; Index 114;undocumented
dwmapi.16; Index 115;undocumented
DwmDefWindowProc; Index 116;
DwmDetachMilContent; Index 117;
dwmapi.19; Index 118;undocumented
dwmapi.20; Index 119;undocumented
dwmapi.21; Index 120;undocumented
dwmapi.22; Index 121;undocumented
DwmEnableBlurBehindWindow; Index 122;
DwmEnableMMCSS; Index 123;
dwmapi.25; Index 124;undocumented
dwmapi.26; Index 125;undocumented
dwmapi.27; Index 126;undocumented
dwmapi.28; Index 127;undocumented
dwmapi.29; Index 128;undocumented
dwmapi.30; Index 129;undocumented
dwmapi.31; Index 130;undocumented
dwmapi.32; Index 131;undocumented
dwmapi.33; Index 132;undocumented
dwmapi.34; Index 133;undocumented
dwmapi.35; Index 134;undocumented
DwmExtendFrameIntoClientArea; Index 135;
DwmFlush; Index 136;
DwmGetColorizationColor; Index 137;
DwmGetCompositionTimingInfo; Index 138;
DwmGetGraphicsStreamClient; Index 139;
DwmGetGraphicsStreamTransformHint; Index 140;
DwmGetTransportAttributes; Index 141;
DwmGetWindowAttribute; Index 142;
DwmInvalidateIconicBitmaps; Index 143;
DwmIsCompositionEnabled; Index 144;
DwmModifyPreviousDxFrameDuration; Index 145;
DwmQueryThumbnailSourceSize; Index 146;
DwmRegisterThumbnail; Index 147;
DwmSetDxFrameDuration; Index 148;
DwmSetIconicLivePreviewBitmap; Index 149;
DwmSetIconicThumbnail; Index 150;
DwmSetPresentParameters; Index 151;
DwmSetWindowAttribute; Index 152;
DwmUnregisterThumbnail; Index 153;
DwmUpdateThumbnailProperties; Index 154;

Now using the Microsoft public symbol server we can obtain the undocumented functions names.

dwmapi.1; Index 100;_DwmpDxGetWindowSharedSurface
dwmapi.2; Index 101;_DwmpDxUpdateWindowSharedSurface
DwmEnableComposition; Index 102;
dwmapi.4; Index 103;_DwmpRestartComposition
dwmapi.5; Index 104;_DwmpSetColorizationColor
dwmapi.6; Index 105;_DwmpStartOrStopFlip3D
dwmapi.7; Index 106;_DwmpIsCompositionCapable
dwmapi.8; Index 107;_DwmpGetGlobalState
dwmapi.9; Index 108;_DwmpEnableRedirection
dwmapi.10; Index 109;_DwmGetGraphicsStreamTransformHint
dwmapi.11; Index 110;_DwmpCloseGraphicsStream
DwmAttachMilContent; Index 111;
dwmapi.13; Index 112;_DwmpSetGraphicsStreamTransformHint
dwmapi.14; Index 113;_DwmpActivateLivePreview
dwmapi.15; Index 114;_DwmpQueryThumbnailType
dwmapi.16; Index 115;_DwmpStartupViaUserInit
DwmDefWindowProc; Index 116;
DwmDetachMilContent; Index 117;
dwmapi.19; Index 118;_DwmpGetAssessment
dwmapi.20; Index 119;_DwmpGetAssessmentUsage
dwmapi.21; Index 120;_DwmpSetAssessmentUsage
dwmapi.22; Index 121;_DwmpIsSessionDWM
DwmEnableBlurBehindWindow; Index 122;
DwmEnableMMCSS; Index 123;
dwmapi.25; Index 124;_DwmpRegisterThumbnail
dwmapi.26; Index 125;_DwmpDxBindSwapChain
dwmapi.27; Index 126;_DwmpDxUnbindSwapChain
dwmapi.28; Index 127;_DwmGetColorizationParameters
dwmapi.29; Index 128;_DwmpDxgiIsThreadDesktopComposited
dwmapi.30; Index 129;_DwmpDxgiDisableRedirection
dwmapi.31; Index 130;_DwmpDxgiEnableRedirection
dwmapi.32; Index 131;_DwmSetColorizationParameters
dwmapi.33; Index 132;_DwmpGetCompositionTimingInfoEx
dwmapi.34; Index 133;_DwmpDxUpdateWindowRedirectionBltSurface
dwmapi.35; Index 134;_DwmpDxSetContentHostingInformation
DwmExtendFrameIntoClientArea; Index 135;
DwmFlush; Index 136;
DwmGetColorizationColor; Index 137;
DwmGetCompositionTimingInfo; Index 138;
DwmGetGraphicsStreamClient; Index 139;
DwmGetGraphicsStreamTransformHint; Index 140;
DwmGetTransportAttributes; Index 141;
DwmGetWindowAttribute; Index 142;
DwmInvalidateIconicBitmaps; Index 143;
DwmIsCompositionEnabled; Index 144;
DwmModifyPreviousDxFrameDuration; Index 145;
DwmQueryThumbnailSourceSize; Index 146;
DwmRegisterThumbnail; Index 147;
DwmSetDxFrameDuration; Index 148;
DwmSetIconicLivePreviewBitmap; Index 149;
DwmSetIconicThumbnail; Index 150;
DwmSetPresentParameters; Index 151;
DwmSetWindowAttribute; Index 152;
DwmUnregisterThumbnail; Index 153;
DwmUpdateThumbnailProperties; Index 154;

In this article only we use the DwmGetColorizationParameters and DwmSetColorizationParameter functions,  the declaration of these in Delphi is

type
tagCOLORIZATIONPARAMS = record
clrColor        : COLORREF;  //ColorizationColor
clrAftGlow      : COLORREF;  //ColorizationAfterglow
nIntensity      : UINT;      //ColorizationColorBalance -> 0-100
clrAftGlowBal   : UINT;      //ColorizationAfterglowBalance
clrBlurBal      : UINT;      //ColorizationBlurBalance
clrGlassReflInt : UINT;      //ColorizationGlassReflectionIntensity
fOpaque         : BOOL;
end;

COLORIZATIONPARAMS=tagCOLORIZATIONPARAMS;
TColorizationParams=COLORIZATIONPARAMS;
PColorizationParams=^TColorizationParams;

TDwmGetColorizationParameters = procedure(out parameters :TColorizationParams); stdcall;
TDwmSetColorizationParameters = procedure(parameters :PColorizationParams;unknown:BOOL); stdcall;

To check the current values of the tagCOLORIZATIONPARAMS  structure  used by the DwmGetColorizationParameters and DwmSetColorizationParameters  functions, you can see the windows registry key HKEY_CURRENT_USER\Software\Microsoft\Windows\DWM

Now in order to change the colorization color of the glass from Delphi you must call these functions in this way

Procedure SetCompositionColor(AColor:TColor);
var
  Params : TColorizationParams;
begin
   //Convert the TColor to a valid color RGB -> BGR
   AColor:=RGB(GetBValue(AColor),GetGValue(AColor),GetRValue(AColor));
   ZeroMemory(@Params,SizeOf(Params));
   //Get the current values
   DwmGetColorizationParameters(Params);
   //Set the New Color
   Params.clrColor  :=AColor;
   //Call the function to set the new color
   DwmSetColorizationParameters(@Params,Bool(0));
end;

Check this delphi console application which change the color of the glass

program DwmDelphiDemo;

{$APPTYPE CONSOLE}
//Author  : Rodrigo Ruz V.
//2011-05-05

uses
  Graphics,
  Windows,
  SysUtils;

type
 tagCOLORIZATIONPARAMS = record
	clrColor        : COLORREF;  //ColorizationColor
        clrAftGlow      : COLORREF;  //ColorizationAfterglow
        nIntensity      : UINT;      //ColorizationColorBalance -> 0-100
	clrAftGlowBal   : UINT;      //ColorizationAfterglowBalance
	clrBlurBal      : UINT;      //ColorizationBlurBalance
	clrGlassReflInt : UINT;      //ColorizationGlassReflectionIntensity
	fOpaque         : BOOL;
end;

 COLORIZATIONPARAMS=tagCOLORIZATIONPARAMS;
 TColorizationParams=COLORIZATIONPARAMS;
 PColorizationParams=^TColorizationParams;

 TDwmGetColorizationParameters = procedure(out parameters :TColorizationParams); stdcall;
 TDwmSetColorizationParameters = procedure(parameters :PColorizationParams;unknown:BOOL); stdcall;
 TDwmIsCompositionEnabled      = function(out pfEnabled : BOOL): HRESULT; stdcall;

var
 DwmGetColorizationParameters : TDwmGetColorizationParameters;
 DwmSetColorizationParameters : TDwmSetColorizationParameters;
 DwmIsCompositionEnabled      : TDwmIsCompositionEnabled;
 hdwmapi                      : Cardinal;

function  IsAeroEnabled: Boolean;
var
  pfEnabled : BOOL;
begin
 Result:=False;
 if Assigned(DwmIsCompositionEnabled) and (DwmIsCompositionEnabled(pfEnabled)=S_OK) then
  Result:=pfEnabled;
end;

Procedure SetCompositionColor(AColor:TColor);
var
  Params : TColorizationParams;
begin
   //convert the TColor to a valid color RGB -> BGR
   AColor:=RGB(GetBValue(AColor),GetGValue(AColor),GetRValue(AColor));
   ZeroMemory(@Params,SizeOf(Params));
   //Get the current values
   DwmGetColorizationParameters(Params);
   //Set the New Color
   Params.clrColor  :=AColor;
   //Call the function to set the new color
   DwmSetColorizationParameters(@Params,Bool(0));
   //get the colorization parameters and show the details
   DwmGetColorizationParameters(Params);
   Writeln(format('Intensity %d - Colorization Color %.8x - Colorization Afterglow Color 2 %.8x',[Params.nIntensity,Params.clrColor,Params.clrAftGlow]));
end;

//load the functions to use
function Init_Dwm: Boolean;
begin
 Result:=False;
  hdwmapi := LoadLibrary('dwmapi.dll');
  if (hdwmapi <> 0) then
  begin
    @DwmIsCompositionEnabled      := GetProcAddress(hdwmapi, 'DwmIsCompositionEnabled');
    //load the DwmGetColorizationParameters  function from the 127 index
    @DwmGetColorizationParameters := GetProcAddress(hdwmapi, LPCSTR(127));
    //load the DwmSetColorizationParameters function from the 131 index
    @DwmSetColorizationParameters := GetProcAddress(hdwmapi, LPCSTR(131));
    Result:=(Assigned(DwmGetColorizationParameters)) and (Assigned(DwmSetColorizationParameters)) and IsAeroEnabled;
  end;
end;

procedure Done_Dwm;
begin
  if (hdwmapi <> 0) then
   FreeLibrary(hdwmapi);
end;

const
  MaxColors =10;
  Colors    : Array [0..MaxColors-1] of TColor =
  (clRed,clBlack,clBlue,clGreen,clYellow,clAqua,clFuchsia,clLime,clPurple,clDkGray);
var
   Params     : TColorizationParams;
   DwmActive  : Boolean;
   i          : Integer;
begin
  try
    DwmActive:=Init_Dwm;
    try
      if DwmActive then
      begin
        //Get the current settings
        DwmGetColorizationParameters(Params);
        Writeln('Current Values');
        Writeln(format('Intensity %d - Colorization Color  %.8x - Colorization Afterglow Color %.8x %d %d %d',[Params.nIntensity,Params.clrColor,Params.clrAftGlow,Params.clrAftGlowBal,Params.clrBlurBal,Params.clrGlassReflInt]));
        try

          for i:= low(Colors) to high(Colors) do
          begin
            SetCompositionColor(Colors[i]);
            Writeln('Press enter to continue');
            Readln;
          end;

        finally
        //Restore the original settings
            DwmSetColorizationParameters(@Params,Bool(0));
        end;
      end
      else
      Writeln('Glass is not active');
    finally
      Done_Dwm;
    end;
  except
    on E: Exception do
      Writeln(E.ClassName, ': ', E.Message);
  end;
  Readln;
end.

and this is the result

Finally just for fun I wrote a similar application to Aura using delphi (just in 240 lines of code ;P and without Net framework) and this is the result.

You can check the source code of this application on Github.


2 Comments

Changing Screen Orientation Programmatically using Delphi

On this post I will show you, how you can change the screen orientation using Delphi. To do this task you must use 2 Winapi functions EnumDisplaySettings and ChangeDisplaySettings.

EnumDisplaySettings: this function retrieves information about the graphics modes supported by the display device.

for example to obtain the current display settings we must call this function in this way:

var
  dm      : TDeviceMode;

  ZeroMemory(@dm, sizeof(dm));
  dm.dmSize   := sizeof(dm);
  if EnumDisplaySettings(nil, DWORD(ENUM_CURRENT_SETTINGS), dm) then
  begin
   //some code
  end;

Now , to use the ChangeDisplaySettings function to change the Screen Orientation we need to pass a valid DEVMODE structure, setting the value of the dmDisplayOrientation field, unfortunately the declaration in the Windows.pas for this record does not include this field.

this is the declaration for the DEVMODE structure in the Windows unit.

  _devicemodeA = record
    dmDeviceName: array[0..CCHDEVICENAME - 1] of AnsiChar;
    dmSpecVersion: Word;
    dmDriverVersion: Word;
    dmSize: Word;
    dmDriverExtra: Word;
    dmFields: DWORD;
    dmOrientation: SHORT;
    dmPaperSize: SHORT;
    dmPaperLength: SHORT;
    dmPaperWidth: SHORT;
    dmScale: SHORT;
    dmCopies: SHORT;
    dmDefaultSource: SHORT;
    dmPrintQuality: SHORT;
    dmColor: SHORT;
    dmDuplex: SHORT;
    dmYResolution: SHORT;
    dmTTOption: SHORT;
    dmCollate: SHORT;
    dmFormName: array[0..CCHFORMNAME - 1] of AnsiChar;
    dmLogPixels: Word;
    dmBitsPerPel: DWORD;
    dmPelsWidth: DWORD;
    dmPelsHeight: DWORD;
    dmDisplayFlags: DWORD;
    dmDisplayFrequency: DWORD;
    dmICMMethod: DWORD;
    dmICMIntent: DWORD;
    dmMediaType: DWORD;
    dmDitherType: DWORD;
    dmICCManufacturer: DWORD;
    dmICCModel: DWORD;
    dmPanningWidth: DWORD;
    dmPanningHeight: DWORD;
  end;

and this is the full declaration including the dmDisplayOrientation field

typedef struct _devicemode {
  TCHAR dmDeviceName[CCHDEVICENAME];
  WORD  dmSpecVersion;
  WORD  dmDriverVersion;
  WORD  dmSize;
  WORD  dmDriverExtra;
  DWORD dmFields;
  union {
    struct {
      short dmOrientation;
      short dmPaperSize;
      short dmPaperLength;
      short dmPaperWidth;
      short dmScale;
      short dmCopies;
      short dmDefaultSource;
      short dmPrintQuality;
    };
    struct {
      POINTL dmPosition;
      DWORD  dmDisplayOrientation;
      DWORD  dmDisplayFixedOutput;
    };
  };
  short dmColor;
  short dmDuplex;
  short dmYResolution;
  short dmTTOption;
  short dmCollate;
  TCHAR dmFormName[CCHFORMNAME];
  WORD  dmLogPixels;
  DWORD dmBitsPerPel;
  DWORD dmPelsWidth;
  DWORD dmPelsHeight;
  union {
    DWORD dmDisplayFlags;
    DWORD dmNup;
  };
  DWORD dmDisplayFrequency;
#if (WINVER >= 0x0400)
  DWORD dmICMMethod;
  DWORD dmICMIntent;
  DWORD dmMediaType;
  DWORD dmDitherType;
  DWORD dmReserved1;
  DWORD dmReserved2;
#if (WINVER >= 0x0500) || (_WIN32_WINNT >= 0x0400)
  DWORD dmPanningWidth;
  DWORD dmPanningHeight;
#endif
#endif
} DEVMODE, *PDEVMODE, *LPDEVMODE;

As you can see the missing fields are dmPosition, dmDisplayOrientation and dmDisplayFixedOutput. to handle this situation we can declare a new devicemode record including these fields or another option is determine the offset of the missing fields in the _devicemode record an then use the Move procedure to Get a Set the desired value.

If we choose create a new record including the missing fields, the new devicemode record will look like this.

type
  _devicemode = record
    dmDeviceName: array [0..CCHDEVICENAME - 1] of {$IFDEF UNICODE} WideChar {$ELSE} AnsiChar {$ENDIF};
    dmSpecVersion: WORD;
    dmDriverVersion: WORD;
    dmSize: WORD;
    dmDriverExtra: WORD;
    dmFields: DWORD;
    union1: record
    case Integer of
      0: (
        dmOrientation: Smallint;
        dmPaperSize: Smallint;
        dmPaperLength: Smallint;
        dmPaperWidth: Smallint;
        dmScale: Smallint;
        dmCopies: Smallint;
        dmDefaultSource: Smallint;
        dmPrintQuality: Smallint);
      1: (
        dmPosition: TPointL;
        dmDisplayOrientation: DWORD;
        dmDisplayFixedOutput: DWORD);
    end;
    dmColor: Shortint;
    dmDuplex: Shortint;
    dmYResolution: Shortint;
    dmTTOption: Shortint;
    dmCollate: Shortint;
    dmFormName: array [0..CCHFORMNAME - 1] of {$IFDEF UNICODE} WideChar {$ELSE} AnsiChar {$ENDIF};
    dmLogPixels: WORD;
    dmBitsPerPel: DWORD;
    dmPelsWidth: DWORD;
    dmPelsHeight: DWORD;
    dmDiusplayFlags: DWORD;
    dmDisplayFrequency: DWORD;
    dmICMMethod: DWORD;
    dmICMIntent: DWORD;
    dmMediaType: DWORD;
    dmDitherType: DWORD;
    dmReserved1: DWORD;
    dmReserved2: DWORD;
    dmPanningWidth: DWORD;
    dmPanningHeight: DWORD;
  end;
  devicemode  = _devicemode;
  Pdevicemode = ^devicemode;

Now we can write our function to change the display orientation.

Option 1) using the the new version of the devicemode record.

procedure ChangeOrientation(NewOrientation:DWORD);
type
  _devicemode = record
    dmDeviceName: array [0..CCHDEVICENAME - 1] of {$IFDEF UNICODE} WideChar {$ELSE} AnsiChar {$ENDIF};
    dmSpecVersion: WORD;
    dmDriverVersion: WORD;
    dmSize: WORD;
    dmDriverExtra: WORD;
    dmFields: DWORD;
    union1: record
    case Integer of
      // printer only fields
      0: (
        dmOrientation: Smallint;
        dmPaperSize: Smallint;
        dmPaperLength: Smallint;
        dmPaperWidth: Smallint;
        dmScale: Smallint;
        dmCopies: Smallint;
        dmDefaultSource: Smallint;
        dmPrintQuality: Smallint);
      // display only fields
      1: (
        dmPosition: TPointL;
        dmDisplayOrientation: DWORD;
        dmDisplayFixedOutput: DWORD);
    end;
    dmColor: Shortint;
    dmDuplex: Shortint;
    dmYResolution: Shortint;
    dmTTOption: Shortint;
    dmCollate: Shortint;
    dmFormName: array [0..CCHFORMNAME - 1] of {$IFDEF UNICODE} WideChar {$ELSE} AnsiChar {$ENDIF};
    dmLogPixels: WORD;
    dmBitsPerPel: DWORD;
    dmPelsWidth: DWORD;
    dmPelsHeight: DWORD;
    dmDiusplayFlags: DWORD;
    dmDisplayFrequency: DWORD;
    dmICMMethod: DWORD;
    dmICMIntent: DWORD;
    dmMediaType: DWORD;
    dmDitherType: DWORD;
    dmReserved1: DWORD;
    dmReserved2: DWORD;
    dmPanningWidth: DWORD;
    dmPanningHeight: DWORD;
  end;
  devicemode  = _devicemode;
  Pdevicemode = ^devicemode;
var
  dm       : TDeviceMode;
  dwTemp  : DWORD;
begin
   ZeroMemory(@dm, sizeof(dm));
   dm.dmSize := sizeof(dm);
   //get the current settings
   if EnumDisplaySettings(nil, DWORD(ENUM_CURRENT_SETTINGS), dm) then
   begin
      //Now this part is very important :
      //when we change the orientation also we are changing resolution of the screen
      //example : if the current orientation is 1024x768x0 (0 is the default orientation) and we need set the orientation to 90 degrees we must swap the values of the width and height , so the new
      //resolution will be (768x1024x90)
      //the next lines makes this trick using the values of the current and new orientation
      if Odd(Pdevicemode(@dm)^.union1.dmDisplayOrientation)<>Odd(NewOrientation) then
      begin
       dwTemp := dm.dmPelsHeight;
       dm.dmPelsHeight:= dm.dmPelsWidth;
       dm.dmPelsWidth := dwTemp;
      end;

      //Now casting the Windows.TDeviceMode record with our devicemode record
      if Pdevicemode(@dm)^.union1.dmDisplayOrientation<>NewOrientation then
      begin
        //casting again to set the new orientation
        Pdevicemode(@dm)^.union1.dmDisplayOrientation := NewOrientation;
        //setting the new orientation
        if (ChangeDisplaySettings(dm, 0)<>DISP_CHANGE_SUCCESSFUL) then
         RaiseLastOSError;
      end;
   end;
end;

Option 2) using the offset of the fields of the TDeviceMode record

procedure ChangeOrientation(NewOrientation:DWORD);
var
 dm      : TDeviceMode;
 dwTemp  : DWORD;
 dmDisplayOrientation : DWORD;
begin
 ZeroMemory(@dm, sizeof(dm));
 dm.dmSize   := sizeof(dm);
 if EnumDisplaySettings(nil, DWORD(ENUM_CURRENT_SETTINGS), dm) then
 begin
 //In the TDevMode record the offset of the dmScale field is equal to the position of the dmDisplayOrientation field
 //so using the move procedure we can get the value of the dmDisplayOrientation field
 Move(dm.dmScale,dmDisplayOrientation,SizeOf(dmDisplayOrientation));
 //See the coments in the pprevious method
 // swap width and height
 if Odd(dmDisplayOrientation)<>Odd(NewOrientation) then
 begin
 dwTemp := dm.dmPelsHeight;
 dm.dmPelsHeight:= dm.dmPelsWidth;
 dm.dmPelsWidth := dwTemp;
 end;

 if dmDisplayOrientation<>NewOrientation then
 begin
 //set the value of the   dmDisplayOrientation
 Move(NewOrientation,dm.dmScale,SizeOf(NewOrientation));
 if (ChangeDisplaySettings(dm, 0)<>DISP_CHANGE_SUCCESSFUL) then
 RaiseLastOSError;
 end;
 end;
end;

finally this is a sample console application to test the previous method

this code will only work if your device supports the respective display settings.

program AppChangeOrientation;

{$APPTYPE CONSOLE}

uses
  Windows,
  SysUtils;

const
  DM_DISPLAYORIENTATION = $00800000;
  ENUM_CURRENT_SETTINGS =-1;
  DMDO_DEFAULT : DWORD  = 0;
  DMDO_90      : DWORD  = 1;
  DMDO_180     : DWORD  = 2;
  DMDO_270     : DWORD  = 3;

procedure ChangeOrientation(NewOrientation:DWORD);
var
  dm      : TDeviceMode;
  dwTemp  : DWORD;
  dmDisplayOrientation : DWORD;
begin
   ZeroMemory(@dm, sizeof(dm));
   dm.dmSize   := sizeof(dm);
   if EnumDisplaySettings(nil, DWORD(ENUM_CURRENT_SETTINGS), dm) then
   begin
      Move(dm.dmScale,dmDisplayOrientation,SizeOf(dmDisplayOrientation));
      // swap width and height
      if Odd(dmDisplayOrientation)<>Odd(NewOrientation) then
      begin
       dwTemp := dm.dmPelsHeight;
       dm.dmPelsHeight:= dm.dmPelsWidth;
       dm.dmPelsWidth := dwTemp;
      end;

      if dmDisplayOrientation<>NewOrientation then
      begin
        Move(NewOrientation,dm.dmScale,SizeOf(NewOrientation));
        if (ChangeDisplaySettings(dm, 0)<>DISP_CHANGE_SUCCESSFUL) then
         RaiseLastOSError;
      end;
   end;
end;

begin
  try
    ChangeOrientation(DMDO_180);
    Writeln('Changed to 180');
    Readln;

    ChangeOrientation(DMDO_270);
    Writeln('Changed to 270');
    Readln;

    ChangeOrientation(DMDO_90);
    Writeln('Changed to 90');
    Readln;

    ChangeOrientation(DMDO_DEFAULT);
    Writeln('Default Orientation restored');
    Readln;
  except
    on E: Exception do
      Writeln(E.ClassName, ': ', E.Message);
  end;
     readln;
end.


2 Comments

Determine when Windows is a Desktop or Server edition using Delphi

Sometimes we need determine when a windows version is a server edition (2000, 2003 or 2008) or a Desktop edition. to do this we can use the VerifyVersionInfo function. this function compares a set of operating system version requirements to the corresponding values for the currently running version of the system.

but exist a problem, the version of this function declared in the Windows unit uses a OSVERSIONINFO parameter.

function VerifyVersionInfo(var lpVersionInformation: TOSVersionInfo;
  dwTypeMask: DWORD; dwlConditionMask: DWORDLONG): BOOL; stdcall; 

And in this case we need pass a OSVERSIONINFOEX Structure, so we must re-declare this function in this way.

{$IFDEF UNICODE}
function VerifyVersionInfo(var LPOSVERSIONINFOEX : OSVERSIONINFOEX;dwTypeMask: DWORD;dwlConditionMask: int64): BOOL; stdcall; external kernel32 name 'VerifyVersionInfoW';
{$ELSE}
function VerifyVersionInfo(var LPOSVERSIONINFOEX : OSVERSIONINFOEX;dwTypeMask: DWORD;dwlConditionMask: int64): BOOL; stdcall; external kernel32 name 'VerifyVersionInfoA';
{$ENDIF}

Now to work with the VerifyVersionInfo function we need establish the requirements to check .


   ZeroMemory(@osvi, sizeof(OSVERSIONINFOEX));
   osvi.dwOSVersionInfoSize := sizeof(OSVERSIONINFOEX);
   osvi.dwMajorVersion := 5; //at least windows 2000
   osvi.dwMinorVersion := 0;
   osvi.wServicePackMajor := 0;
   osvi.wServicePackMinor := 0;
   osvi.wProductType := VER_NT_SERVER; // Check windows server edition

then we need set the flags to interrogate the VerifyVersionInfo function using the VerSetConditionMask function

   op:=VER_GREATER_EQUAL;
   dwlConditionMask:=VerSetConditionMask( dwlConditionMask, VER_MAJORVERSION, op );
   dwlConditionMask:=VerSetConditionMask( dwlConditionMask, VER_MINORVERSION, op );
   dwlConditionMask:=VerSetConditionMask( dwlConditionMask, VER_SERVICEPACKMAJOR, op );
   dwlConditionMask:=VerSetConditionMask( dwlConditionMask, VER_SERVICEPACKMINOR, op );
   dwlConditionMask:=VerSetConditionMask( dwlConditionMask, VER_PRODUCT_TYPE, VER_EQUAL );

and finally call the function in this way

   VerifyVersionInfo(osvi,VER_MAJORVERSION OR VER_MINORVERSION OR
      VER_SERVICEPACKMAJOR OR VER_SERVICEPACKMINOR OR VER_PRODUCT_TYPE, dwlConditionMask);

This is the source code of the demo console application.

program ISWindowsServer;

{$APPTYPE CONSOLE}

uses
  Windows,
  SysUtils;

{$IFDEF UNICODE}
function VerifyVersionInfo(var LPOSVERSIONINFOEX : OSVERSIONINFOEX;dwTypeMask: DWORD;dwlConditionMask: int64): BOOL; stdcall; external kernel32 name 'VerifyVersionInfoW';
{$ELSE}
function VerifyVersionInfo(var LPOSVERSIONINFOEX : OSVERSIONINFOEX;dwTypeMask: DWORD;dwlConditionMask: int64): BOOL; stdcall; external kernel32 name 'VerifyVersionInfoA';
{$ENDIF}
function VerSetConditionMask(dwlConditionMask: int64;dwTypeBitMask: DWORD; dwConditionMask: Byte): int64; stdcall; external kernel32;

function IsWinServer : Boolean;
const
   VER_NT_SERVER      = $0000003;
   VER_EQUAL          = 1;
   VER_GREATER_EQUAL  = 3;
var
   osvi             : OSVERSIONINFOEX;
   dwlConditionMask : DWORDLONG;
   op               : Integer;
begin
   dwlConditionMask := 0;
   op:=VER_GREATER_EQUAL;

   ZeroMemory(@osvi, sizeof(OSVERSIONINFOEX));
   osvi.dwOSVersionInfoSize := sizeof(OSVERSIONINFOEX);
   osvi.dwMajorVersion := 5;
   osvi.dwMinorVersion := 0;
   osvi.wServicePackMajor := 0;
   osvi.wServicePackMinor := 0;
   osvi.wProductType := VER_NT_SERVER;

   dwlConditionMask:=VerSetConditionMask( dwlConditionMask, VER_MAJORVERSION, op );
   dwlConditionMask:=VerSetConditionMask( dwlConditionMask, VER_MINORVERSION, op );
   dwlConditionMask:=VerSetConditionMask( dwlConditionMask, VER_SERVICEPACKMAJOR, op );
   dwlConditionMask:=VerSetConditionMask( dwlConditionMask, VER_SERVICEPACKMINOR, op );
   dwlConditionMask:=VerSetConditionMask( dwlConditionMask, VER_PRODUCT_TYPE, VER_EQUAL );

   Result:=VerifyVersionInfo(osvi,VER_MAJORVERSION OR VER_MINORVERSION OR
      VER_SERVICEPACKMAJOR OR VER_SERVICEPACKMINOR OR VER_PRODUCT_TYPE, dwlConditionMask);
end;

const
WindowsEditionStr : array [boolean] of string = ('Desktop','Server');

begin
  try
    Writeln( Format('Running in Windows %s edition',[WindowsEditionStr[IsWinServer]]));
  except
    on E: Exception do
      Writeln(E.ClassName, ': ', E.Message);
  end;
  readln;
end.


4 Comments

Delphi : Enumerating Remote Desktop Servers in a network domain

Using the WinApi WTSEnumerateServers function you can get a list of all Remote Desktop Servers in a network domain.

Check this code. Tested on Delphi 2007, Delphi 2010, Delphi XE – (Windows XP/7/2008 Server)

program GetRemoteDesktops;

{$APPTYPE CONSOLE}

type
PWTS_SERVER_INFO = ^WTS_SERVER_INFO;
_WTS_SERVER_INFO = packed record
pServerName:LPTSTR;
end;
WTS_SERVER_INFO = _WTS_SERVER_INFO;
WTS_SERVER_INFO_Array  = Array [0..0] of WTS_SERVER_INFO;
PWTS_SERVER_INFO_Array =^WTS_SERVER_INFO_Array;

{$IFDEF UNICODE}
function WTSEnumerateServers( pDomainName: LPTSTR; Reserved: DWORD; Version: DWORD; ppServerInfo: PWTS_SERVER_INFO; pCount: PDWORD):BOOLEAN; stdcall; external 'wtsapi32.dll'  name 'WTSEnumerateServersW';
{$ELSE}
function WTSEnumerateServers( pDomainName: LPTSTR; Reserved: DWORD; Version: DWORD; ppServerInfo: PWTS_SERVER_INFO; pCount: PDWORD):BOOLEAN; stdcall; external 'wtsapi32.dll'  name 'WTSEnumerateServersA';
{$ENDIF}
procedure WTSFreeMemory(pMemory:Pointer);stdcall; external 'wtsapi32.dll' name 'WTSFreeMemory';

procedure GetRemoteDesktopsList(const Domain:PChar;const Servers:TStrings);
var
ppServerInfo : PWTS_SERVER_INFO_Array;//PWTS_SERVER_INFO;
pCount       : DWORD;
i            : integer;
begin
  Servers.Clear;
  ppServerInfo:=nil;
  try
    if WTSEnumerateServers(Domain,0,1,PWTS_SERVER_INFO(@ppServerInfo),@pCount) then
      for i := 0 to pCount - 1 do
        Servers.Add(ppServerInfo^[i].pServerName)
    else
    Raise Exception.Create(SysErrorMessage(GetLastError));
  finally
    if ppServerInfo<>nil then
    WTSFreeMemory(ppServerInfo);
  end;
end;


2 Comments

Getting the parent process filename of a PID, using Delphi.

The next code shows how get the parent process filename of a PID, using Delphi.

uses
  Psapi,
  Windows,
  tlhelp32,
  SysUtils;

function GetParentProcessFileName(PID : DWORD): String;
var                               
  HandleSnapShot      : THandle;
  EntryParentProc     : TProcessEntry32;
  HandleParentProc    : THandle;
  ParentPID           : DWORD;
  ParentProcessFound  : Boolean;
  ParentProcPath      : PChar;
begin
  ParentProcessFound := False;
  HandleSnapShot     := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
  GetMem(ParentProcPath, MAX_PATH);
  try
    if HandleSnapShot <> INVALID_HANDLE_VALUE then
    begin
      EntryParentProc.dwSize := SizeOf(EntryParentProc);
      if Process32First(HandleSnapShot, EntryParentProc) then
      begin
        repeat
          if EntryParentProc.th32ProcessID = PID then
          begin
            ParentPID  := EntryParentProc.th32ParentProcessID;
            HandleParentProc  := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, False, ParentPID);
            ParentProcessFound:= HandleParentProc <> 0;
            if ParentProcessFound then
            begin
                GetModuleFileNameEx(HandleParentProc, 0, PChar(ParentProcPath), MAX_PATH);
                ParentProcPath := PChar(ParentProcPath);
                CloseHandle(HandleParentProc);
            end;
            break;
          end;
        until not Process32Next(HandleSnapShot, EntryParentProc);
      end;
      CloseHandle(HandleSnapShot);
    end;

    if ParentProcessFound then
      Result := ParentProcPath
    else
      Result := '';
  finally
      FreeMem(ParentProcPath);
  end;
end;