The Road to Delphi

Delphi – Free Pascal – Oxygene


3 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;


Leave a comment

Detect If my Delphi application is running under a 64-bit version of Windows.

The next code shows how detect If my Delphi application is running under a 64-bit version of Windows.

uses 
  Windows;

    function IsWow64Process: Boolean;
    type
      TIsWow64Process = function( hProcess: Windows.THandle; var Wow64Process: Windows.BOOL): Windows.BOOL; stdcall;
    var
      IsWow64Process: TIsWow64Process;
      Wow64Process  : Windows.BOOL;
    begin
      Result := False;
      IsWow64Process := GetProcAddress(GetModuleHandle(Windows.kernel32), 'IsWow64Process');
      if Assigned(IsWow64Process) then
      begin
        if not IsWow64Process(GetCurrentProcess, Wow64Process) then
        Raise Exception.Create('Invalid handle');
        Result := Wow64Process;
      end;
    end;