Delphi – VCL – VCL Styles – UxTheme – WinAPI


29 Comments

Changing the UA (User Agent) of a TWebBrowser component

The user agent strings identify what a user is using to access a web resource. some websites may deliver (slightly) different content depending upon what browser is being used. For example, if you use a iPhone user agent to browse to a WordPress site like https://theroadtodelphi.wordpress.com the result will see something like this :

As you can see the content is designed to fit with a mobile device. in this post I will show how you can change the user agent of a TWebBrowser component.

to change the UA of TWebBrowser you must call the OnAmbientPropertyChange event of the IOleControl interface with the DISPID_AMBIENT_USERAGENT flag and in the implementation of the Invoke function for the IDispatch interface set the value for the New User Agent String.

check the next source code using a interposer class of the TWebBrowser which declare a new property called UserAgent in the component.

const
  DISPID_AMBIENT_USERAGENT = -5513;

type
  TWebBrowser = class (SHDocVw.TWebbrowser, IDispatch)
  private
    FUserAgent: string;
    procedure SetUserAgent (const Value: string);
    function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HRESULT; stdcall;
  public
    property UserAgent: string read FUserAgent write SetUserAgent;
    constructor Create(AOwner: TComponent); override;
  end;

and the implementation

constructor TWebBrowser.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FUserAgent:='';
end;

function TWebBrowser.Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HRESULT;
begin
  //check if the DISPID_AMBIENT_USERAGENT flag is being processed and if the User Agent to set is not empty
  if (FUserAgent <> '') and (Flags and DISPATCH_PROPERTYGET <> 0) and Assigned(VarResult) and (DispId=DISPID_AMBIENT_USERAGENT) then
  begin
    //set the user agent
    POleVariant(VarResult)^:= FUserAgent+#13#10;
    Result := S_OK; //return S_OK
  end
  else
  Result := inherited Invoke(DispID, IID, LocaleID, Flags, Params, VarResult, ExcepInfo, ArgErr); //call the default Invoke method
end;

procedure TWebBrowser.SetUserAgent(const Value: string);
var
  Control: IOleControl;
begin
  FUserAgent := Value;
  //the current interface supports IOleControl?
  if DefaultInterface.QueryInterface(IOleControl, Control) = 0 then
    Control.OnAmbientPropertyChange(DISPID_AMBIENT_USERAGENT); //call the OnAmbientPropertyChange event
end;

Now to use the above code your only need to add a TWebBrowser component to your form, then add the declaration of the New TWebBrowser class to begin of your unit and finally you must add the implementation of the methods show in this article.

Now to set the new user agent, you only must set the UserAgent property.

  WebBrowser1.UserAgent:='Mozilla/5.0 (iPhone; U; CPU like Mac OS X; en) AppleWebKit/420+ (KHTML, like Gecko) Version/3.0 Mobile/1A543a Safari/419.3';
  WebBrowser1.Navigate(EditURL.Text);

check the screen-shots for the demo application

For more info about User Agent strings check these links

Understanding User-Agent Strings
RFC 1945 – 10.15 User-Agent


Check the source code on Github.


4 Comments

Compile, Debug and Run your Pascal code online.

Do you want test a short Pascal snippet and you don’t have a compiler? try the site called ideone.

What is ideone?
Ideone is something more than a pastebin; it’s an online compiler and debugging tool which allows
to compile and run code online in more than 40 programming languages.

This site currently supports these two Pascal compilers

fpc (Free Pascal Compiler) 2.2.0 (Target OS: Linux for i386)
gpc (GNU Pascal Compiler) 20070904

for the limitations about the code submitted and others check the FAQ.


8 Comments

search for installed windows updates using Delphi, WMI and WUA

Sometimes we need determine if a particular windows hotfix or update is installed in the system. to do this task you can use two approaches

WMI (Windows Management Instrumentation)

using the Win32_QuickFixEngineering class, you can retrieve a small system-wide update, commonly referred to as a quick-fix engineering (QFE) update.

check this code which list the updates installed in the system

procedure  GetWin32_QuickFixEngineeringInfo;
const
  wbemFlagForwardOnly = $00000020;
var
  FSWbemLocator : OLEVariant;
  FWMIService   : OLEVariant;
  FWbemObjectSet: OLEVariant;
  FWbemObject   : OLEVariant;
  oEnum         : IEnumvariant;
  iValue        : LongWord;
begin;
  FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
  FWMIService   := FSWbemLocator.ConnectServer('localhost', 'root\CIMV2', '', '');
  FWbemObjectSet:= FWMIService.ExecQuery('SELECT * FROM Win32_QuickFixEngineering','WQL',wbemFlagForwardOnly);
  oEnum         := IUnknown(FWbemObjectSet._NewEnum) as IEnumVariant;
  while oEnum.Next(1, FWbemObject, iValue) = 0 do
  begin
    Writeln(Format('Caption                        %s',[FWbemObject.Caption]));// String
    //Writeln(Format('CSName                         %s',[FWbemObject.CSName]));// String
    Writeln(Format('Description                    %s',[FWbemObject.Description]));// String
    Writeln(Format('FixComments                    %s',[FWbemObject.FixComments]));// String
    Writeln(Format('HotFixID                       %s',[FWbemObject.HotFixID]));// String
    Writeln(Format('InstallDate                    %s',[FWbemObject.InstallDate]));// Datetime
    Writeln(Format('InstalledBy                    %s',[FWbemObject.InstalledBy]));// String
    Writeln(Format('InstalledOn                    %s',[FWbemObject.InstalledOn]));// String
    Writeln(Format('Name                           %s',[FWbemObject.Name]));// String
    Writeln(Format('ServicePackInEffect            %s',[FWbemObject.ServicePackInEffect]));// String
    Writeln(Format('Status                         %s',[FWbemObject.Status]));// String
    Writeln('');
    FWbemObject:=Unassigned;
  end;
end;

Now to find if a particular update is installed you can check the HotFixID property value (which is the Unique identifier associated with a particular update) and write a function like this

//use in this way ISHotFixID_Installed('KB982799')
function  ISHotFixID_Installed(const HotFixID : string): Boolean;
const
  wbemFlagForwardOnly = $00000020;
  wbemFlagReturnImmediately = $00000010;
var
  FSWbemLocator : OLEVariant;
  FWMIService   : OLEVariant;
  FWbemObjectSet: OLEVariant;
  FWbemObject   : OLEVariant;
  oEnum         : IEnumvariant;
  iValue        : LongWord;
begin;
  FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
  FWMIService   := FSWbemLocator.ConnectServer('localhost', 'root\CIMV2', '', '');
  FWbemObjectSet:= FWMIService.ExecQuery(Format('SELECT * FROM Win32_QuickFixEngineering Where HotFixID="%s"',[HotFixID]),'WQL',wbemFlagForwardOnly OR wbemFlagReturnImmediately);
  oEnum         := IUnknown(FWbemObjectSet._NewEnum) as IEnumVariant;
  Result:= oEnum.Next(1, FWbemObject, iValue) = 0;
end;

Ok this is fine, but Starting with Windows Vista, the Win32_QuickFixEngineering class returns only the updates supplied by Component Based Servicing (CBS), so some updates are not listed.

WUA (Windows Update Agent)

using the Windows Update Agent API is a best option to retrieve the list of updates, you can access the interfaces and objects from this API from delphi importing the wuapi.dll file or creating a late-binding com object using the Microsoft.Update.Session GUID. the next samples uses the late-binding way.

from the MSDN site :

The Windows Update Agent (WUA) API is a set of COM interfaces that enable system administrators and programmers to access Windows Update and Windows Server Update Services (WSUS). Scripts and programs can be written to examine which updates are currently available for a computer, and then you can install or uninstall updates.

to implement a search of the installed updates we need to use the IUpdateSearcher Interface using the Search method setting the search criteria.

check this sample

  //create the Com object instance
  updateSession:= CreateOleObject('Microsoft.Update.Session');
  updateSearcher    := updateSession.CreateUpdateSearcher;
  //set the search criteria, installed =1 means updates that are installed on the destination computer, Type='Software'  retrieve only applications updates
  updateSearchResult:= updateSearcher.Search(Format('IsInstalled = 1 and Type=%s',[QuotedStr('Software')]));

Now to find if a particular update is installed you can parse the Title property of the IUpdate Interface which contains the name of the update like this Security Update for Windows 7 for x64-based Systems (KB978542)

//use in this way ISHotFixID_Installed('KB982799')
function  ISHotFixID_Installed(const HotFixID : string): Boolean;
var
  updateSession      : OleVariant;
  updateSearcher     : OleVariant;
  updateEntry        : OleVariant;
  updateSearchResult : OleVariant;
  UpdateCollection   : OleVariant;
  oEnum              : IEnumvariant;
  iValue             : LongWord;
begin
 result:=False;
  updateSession:= CreateOleObject('Microsoft.Update.Session');
  updateSearcher    := updateSession.CreateUpdateSearcher;
  //this line improves the performance , the online porperty indicates whether the UpdateSearcher goes online to search for updates. so how we are looking for already installed updates we can set this value to false
  updateSearcher.online:=False;
  updateSearchResult:= updateSearcher.Search(Format('IsInstalled = 1 and Type=%s',[QuotedStr('Software')]));
  UpdateCollection  := updateSearchResult.Updates;
  oEnum         := IUnknown(UpdateCollection._NewEnum) as IEnumVariant;
  while oEnum.Next(1, updateEntry, iValue) = 0 do
  begin
    Result:=Pos(HotFixID,updateEntry.Title)>0;
    updateEntry:=Unassigned;
    if Result then break;
  end;
end;

check these another useful functions

Getting the installed updates list

procedure  GetListInstalledUpdates;
var
  updateSession        : OleVariant;
  updateSearcher       : OleVariant;
  updateSearchResult   : OleVariant;
  updateEntry          : OleVariant;
  UpdateCollection     : OleVariant;
  oEnum                : IEnumvariant;
  iValue               : LongWord;
begin
  updateSession:= CreateOleObject('Microsoft.Update.Session');
  updateSearcher := updateSession.CreateUpdateSearcher;
  Writeln('Searching');
  //IUpdateSearcher::Search Method http://msdn.microsoft.com/en-us/library/aa386526%28v=VS.85%29.aspx
  updateSearcher.online:=False;
  updateSearchResult:= updateSearcher.Search(Format('IsInstalled = 1 and Type=%s',[QuotedStr('Software')]));
  UpdateCollection  := updateSearchResult.Updates;
  oEnum         := IUnknown(UpdateCollection._NewEnum) as IEnumVariant;
  //IUpdate Interface http://msdn.microsoft.com/en-us/library/aa386099%28v=VS.85%29.aspx
  while oEnum.Next(1, updateEntry, iValue) = 0 do
  begin
    Writeln(updateEntry.Title);
    updateEntry:=Unassigned;
  end;
  Writeln('Done');
end;

Getting the not installed updates list (slow because need to check online)

procedure  GetListNotInstalledUpdates;
var
  updateSession        : OleVariant;
  updateSearcher       : OleVariant;
  updateSearchResult   : OleVariant;
  updateEntry          : OleVariant;
  UpdateCollection     : OleVariant;
  oEnum                : IEnumvariant;
  iValue               : LongWord;
begin
  updateSession:= CreateOleObject('Microsoft.Update.Session');
  updateSearcher := updateSession.CreateUpdateSearcher;
  Writeln('Searching');
  updateSearchResult:= updateSearcher.Search(Format('IsInstalled = 0 and Type=%s',[QuotedStr('Software')]));
  UpdateCollection  := updateSearchResult.Updates;
  oEnum         := IUnknown(UpdateCollection._NewEnum) as IEnumVariant;
  while oEnum.Next(1, updateEntry, iValue) = 0 do
  begin
    Writeln(updateEntry.Title);
    updateEntry:=Unassigned;
  end;
  Writeln('Done');
end;

Getting the hidden installed updates list

procedure  GetListInstalledHiddenUpdates;
var
  updateSession        : OleVariant;
  updateSearcher       : OleVariant;
  updateSearchResult   : OleVariant;
  updateEntry          : OleVariant;
  UpdateCollection     : OleVariant;
  oEnum                : IEnumvariant;
  iValue               : LongWord;
begin
  updateSession:= CreateOleObject('Microsoft.Update.Session');
  updateSearcher := updateSession.CreateUpdateSearcher;
  Writeln('Searching');
  updateSearcher.online:=False;
  updateSearchResult:= updateSearcher.Search(Format('IsHidden=1 and IsInstalled = 1 and Type=%s',[QuotedStr('Software')]));
  UpdateCollection  := updateSearchResult.Updates;
  oEnum         := IUnknown(UpdateCollection._NewEnum) as IEnumVariant;
  while oEnum.Next(1, updateEntry, iValue) = 0 do
  begin
    Writeln(updateEntry.Title);
    updateEntry:=Unassigned;
  end;
  Writeln('Done');
end;


1 Comment

Change the drive letter using WMI and Delphi

Today i will show a short snippet to change the letter from a drive (Volume) using the WMI. the key is use the Win32_Volume class and set the value of the DriveLetter property. this property is read/write so we can update directly the value and then call the Put_ method of the SWbemObject object.

Check out this sample project

{$APPTYPE CONSOLE}

uses
  SysUtils,
  ActiveX,
  ComObj;

procedure  ChangeDriveLetter(OldDrive,NewDrive:Char);
var
  FSWbemLocator : OLEVariant;
  FWMIService   : OLEVariant;
  FWbemObjectSet: OLEVariant;
  FWbemObject   : OLEVariant;
  oEnum         : IEnumvariant;
  iValue        : LongWord;
begin;
  FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
  FWMIService   := FSWbemLocator.ConnectServer('localhost', 'root\CIMV2', '', '');
  FWbemObjectSet:= FWMIService.ExecQuery(Format('SELECT * FROM Win32_Volume Where DriveLetter=%s',[QuotedStr(OldDrive+':')]),'WQL',0);
  oEnum         := IUnknown(FWbemObjectSet._NewEnum) as IEnumVariant;
  if oEnum.Next(1, FWbemObject, iValue) = 0 then
  begin
    //Assign the New letter
    FWbemObject.DriveLetter:=NewDrive+':';
    //Apply the changes
    FWbemObject.Put_();
  end;
end;

begin
 try
    CoInitialize(nil);
    try
      //This will change the letter of the drive E to Z
      ChangeDriveLetter('E','Z');
      Readln;
    finally
      CoUninitialize;
    end;
 except
    on E:Exception do
    begin
        Writeln(E.Classname, ':', E.Message);
        Readln;
    end;
  end;
end.


21 Comments

Getting the installed Antivirus, AntiSpyware and Firewall software using Delphi and the WMI

The WMI allow you to get the installed Antivirus, AntiSpyware and Firewall (third party)  software using the root\SecurityCenter or the root\SecurityCenter2 namespaces and the AntiVirusProduct , AntiSpywareProduct, FirewallProduct classes.

First you must know which these classes and namespaces are not documented by Microsoft and only are supported in Windows Desktops editions (Windows XP, Windows Vista and Windows 7).
Now depending of the Windows version the properties retrieved by the the same class can change. this is a summary of the classes and properties availables depending of the windows version

Windows XP

Namespace : SecurityCenter
Classes availables: AntiVirusProduct, FirewallProduct

AntiVirusProduct-Properties

  • companyName
  • displayName
  • enableOnAccessUIMd5Hash
  • enableOnAccessUIParameters
  • instanceGuid
  • onAccessScanningEnabled
  • pathToEnableOnAccessUI
  • pathToUpdateUI
  • productUptoDate
  • updateUIMd5Hash
  • updateUIParameters
  • versionNumber

FirewallProduct-Properties

  • companyName
  • displayName
  • enabled
  • enableUIMd5Hash
  • enableUIParameters
  • instanceGuid
  • pathToEnableUI
  • versionNumber

Windows Vista and Windows 7

Namespace : SecurityCenter2
Classes availables : AntiVirusProduct, AntiSpywareProduct, FirewallProduct

AntiVirusProduct, AntiSpywareProduct, FirewallProduct – Properties

  • displayName
  • instanceGuid
  • pathToSignedProductExe
  • pathToSignedReportingExe
  • productState

This is a sample project which determine the Antivirus, AntiSpyware and Firewall software installed in the system.

program GetSecurityCenterInfo;

{$APPTYPE CONSOLE}

uses
  SysUtils,
  Windows,
  ActiveX,
  ComObj,
  Variants;

type
  TSecurityCenterProduct = (AntiVirusProduct,AntiSpywareProduct,FirewallProduct);
const
  WmiRoot='root';
  WmiClassSCProduct     : array [TSecurityCenterProduct] of string = ('AntiVirusProduct','AntiSpywareProduct','FirewallProduct');
  WmiNamespaceSCProduct : array [Boolean] of string = ('SecurityCenter','SecurityCenter2');

function VerSetConditionMask(dwlConditionMask: int64;dwTypeBitMask: DWORD; dwConditionMask: Byte): int64; stdcall; external kernel32;

{$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}

//verifies that the application is running on Windows 2000 Server or a later server, such as Windows Server 2003 or Windows Server 2008.
function Is_Win_Server : 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;

procedure  GetSCProductInfo(SCProduct:TSecurityCenterProduct);
var
  FSWbemLocator : OLEVariant;
  FWMIService   : OLEVariant;
  FWbemObjectSet: OLEVariant;
  FWbemObject   : OLEVariant;
  oEnum         : IEnumvariant;
  iValue        : LongWord;
  osVerInfo     : TOSVersionInfo;
begin
  osVerInfo.dwOSVersionInfoSize:=SizeOf(TOSVersionInfo);
  GetVersionEx(osVerInfo);
  if (SCProduct=AntiSpywareProduct) and (osVerInfo.dwMajorVersion<6)  then exit;   FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');   FWMIService   := FSWbemLocator.ConnectServer('localhost',Format('%s\%s',[WmiRoot,WmiNamespaceSCProduct[osVerInfo.dwMajorVersion>=6]]), '', '');
  FWbemObjectSet:= FWMIService.ExecQuery(Format('SELECT * FROM %s',[WmiClassSCProduct[SCProduct]]),'WQL',0);
  oEnum         := IUnknown(FWbemObjectSet._NewEnum) as IEnumVariant;
  while oEnum.Next(1, FWbemObject, iValue) = 0 do
  begin
    if osVerInfo.dwMajorVersion>=6 then  //windows vista or newer
    begin
      Writeln(Format('displayName                    %s',[FWbemObject.displayName]));// String
      Writeln(Format('instanceGuid                   %s',[FWbemObject.instanceGuid]));// String
      Writeln(Format('pathToSignedProductExe         %s',[FWbemObject.pathToSignedProductExe]));// String
      Writeln(Format('pathToSignedReportingExe       %s',[FWbemObject.pathToSignedReportingExe]));// String
      Writeln(Format('productState                   %s',[FWbemObject.productState]));// Uint32
    end
    else
    begin
     case SCProduct of

        AntiVirusProduct :
         begin
            Writeln(Format('companyName                    %s',[FWbemObject.companyName]));// String
            Writeln(Format('displayName                    %s',[FWbemObject.displayName]));// String
            Writeln(Format('enableOnAccessUIMd5Hash        %s',[FWbemObject.enableOnAccessUIMd5Hash]));// Uint8
            Writeln(Format('enableOnAccessUIParameters     %s',[FWbemObject.enableOnAccessUIParameters]));// String
            Writeln(Format('instanceGuid                   %s',[FWbemObject.instanceGuid]));// String
            Writeln(Format('onAccessScanningEnabled        %s',[FWbemObject.onAccessScanningEnabled]));// Boolean
            Writeln(Format('pathToEnableOnAccessUI         %s',[FWbemObject.pathToEnableOnAccessUI]));// String
            Writeln(Format('pathToUpdateUI                 %s',[FWbemObject.pathToUpdateUI]));// String
            Writeln(Format('productUptoDate                %s',[FWbemObject.productUptoDate]));// Boolean
            Writeln(Format('updateUIMd5Hash                %s',[FWbemObject.updateUIMd5Hash]));// Uint8
            Writeln(Format('updateUIParameters             %s',[FWbemObject.updateUIParameters]));// String
            Writeln(Format('versionNumber                  %s',[FWbemObject.versionNumber]));// String
         end;

       FirewallProduct  :
         begin
            Writeln(Format('companyName                    %s',[FWbemObject.companyName]));// String
            Writeln(Format('displayName                    %s',[FWbemObject.displayName]));// String
            Writeln(Format('enabled                        %s',[FWbemObject.enabled]));// Boolean
            Writeln(Format('enableUIMd5Hash                %s',[FWbemObject.enableUIMd5Hash]));// Uint8
            Writeln(Format('enableUIParameters             %s',[FWbemObject.enableUIParameters]));// String
            Writeln(Format('instanceGuid                   %s',[FWbemObject.instanceGuid]));// String
            Writeln(Format('pathToEnableUI                 %s',[FWbemObject.pathToEnableUI]));// String
            Writeln(Format('versionNumber                  %s',[FWbemObject.versionNumber]));// String
         end;
     end;
    end;
    Writeln('');
    FWbemObject:=Unassigned;
  end;
end;

begin
 try
    if Is_Win_Server then
    begin
     Writeln('Sorry this app only can run in desktop operating systems.');
     Halt;
    end;

    CoInitialize(nil);
    try
      Writeln('AntiVirus Info');
      Writeln('--------------');
      GetSCProductInfo(AntiVirusProduct);
      Writeln('AntiSpyware Info');
      Writeln('----------------');
      GetSCProductInfo(AntiSpywareProduct);
      Writeln('Firewall Info');
      Writeln('-------------');
      GetSCProductInfo(FirewallProduct);
      Readln;
    finally
      CoUninitialize;
    end;
 except
    on E:Exception do
    begin
        Writeln(E.Classname, ':', E.Message);
        Readln;
    end;
  end;
end.

And here is the result of the app.


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.


8 Comments

Avoiding the memory leak caused by the Delphi intellimouse support

Since the Delphi 2006 version, you can activate the full mouse wheel support (Intellimouse) by adding to the Uses statement the IMouse unit. for example to activate the Intellimouse support to a TMemo component you must set the ScrollBars property to ssHorizontal, ssVertical or ssBoth and add the IMouse unit to your project.

and the result will look like this.

So far all will work ok, but if you add the next line to your project, to report the memory leaks.

 ReportMemoryLeaksOnShutdown:=True;

you will receive a awful message like this

this is due which in the IMouse unit the Mouse.PanningWindow is never released. to avoid this memory leak you must add these lines to your project in the finalization part of your main unit or in the unit where your declare the IMouse unit.

  if Assigned(Mouse.PanningWindow) then
    Mouse.PanningWindow := nil;


36 Comments

Making a PING with Delphi and the WMI

Typically we use the IcmpSendEcho function or a component like TIdIcmpClient to make a ping request from Delphi. Today I will show you another way to do this using the WMI (Windows Management Instrumentation).

The WMI class which allow you to make a ping request is Win32_PingStatus, to use this class you only need to pass the parameter Address value in your WQL sentence , the form of the Address parameter can be either the computer name (ACCOUNT-PC), IPv4 address (192.168.154.102), or IPv6 address (2010:836B:4179::836B:4179).

SELECT * FROM Win32_PingStatus where Address='www.google.com'

Some of the advantages of use this class to make a ping is which supports IPv4 addresses and IPv6 addresses (Starting with Windows Vista) , and you can set the ping parameters in a single WQL sentence.

For example if you want send a Buffer of 64 bytes (instead of the 32 default size) and resolve the address of the host server you only need to write a sentence like this :

SELECT * FROM Win32_PingStatus where Address='192.168.1.221' AND BufferSize=64 AND ResolveAddressNames=TRUE

Now check this sample console application.

program WMIPing;

{$APPTYPE CONSOLE}

uses
  SysUtils,
  ActiveX,
  ComObj,
  Variants;

function GetStatusCodeStr(statusCode:integer) : string;
begin
  case statusCode of
    0     : Result:='Success';
    11001 : Result:='Buffer Too Small';
    11002 : Result:='Destination Net Unreachable';
    11003 : Result:='Destination Host Unreachable';
    11004 : Result:='Destination Protocol Unreachable';
    11005 : Result:='Destination Port Unreachable';
    11006 : Result:='No Resources';
    11007 : Result:='Bad Option';
    11008 : Result:='Hardware Error';
    11009 : Result:='Packet Too Big';
    11010 : Result:='Request Timed Out';
    11011 : Result:='Bad Request';
    11012 : Result:='Bad Route';
    11013 : Result:='TimeToLive Expired Transit';
    11014 : Result:='TimeToLive Expired Reassembly';
    11015 : Result:='Parameter Problem';
    11016 : Result:='Source Quench';
    11017 : Result:='Option Too Big';
    11018 : Result:='Bad Destination';
    11032 : Result:='Negotiating IPSEC';
    11050 : Result:='General Failure'
    else
    result:='Unknow';
  end;
end;


//The form of the Address parameter can be either the computer name (wxyz1234), IPv4 address (192.168.177.124), or IPv6 address (2010:836B:4179::836B:4179).
procedure  Ping(const Address:string;Retries,BufferSize:Word);
var
  FSWbemLocator : OLEVariant;
  FWMIService   : OLEVariant;
  FWbemObjectSet: OLEVariant;
  FWbemObject   : OLEVariant;
  oEnum         : IEnumvariant;
  iValue        : LongWord;
  i             : Integer;

  PacketsReceived : Integer;
  Minimum         : Integer;
  Maximum         : Integer;
  Average         : Integer;
begin;
  PacketsReceived:=0;
  Minimum        :=0;
  Maximum        :=0;
  Average        :=0;
  Writeln('');
  Writeln(Format('Pinging %s with %d bytes of data:',[Address,BufferSize]));
  FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
  FWMIService   := FSWbemLocator.ConnectServer('localhost', 'root\CIMV2', '', '');
  //FWMIService   := FSWbemLocator.ConnectServer('192.168.52.130', 'root\CIMV2', 'user', 'password');
  for i := 0 to Retries-1 do
  begin
    FWbemObjectSet:= FWMIService.ExecQuery(Format('SELECT * FROM Win32_PingStatus where Address=%s AND BufferSize=%d',[QuotedStr(Address),BufferSize]),'WQL',0);
    oEnum         := IUnknown(FWbemObjectSet._NewEnum) as IEnumVariant;
    if oEnum.Next(1, FWbemObject, iValue) = 0 then
    begin
      if FWbemObject.StatusCode=0 then
      begin
        if FWbemObject.ResponseTime>0 then
          Writeln(Format('Reply from %s: bytes=%s time=%sms TTL=%s',[FWbemObject.ProtocolAddress,FWbemObject.ReplySize,FWbemObject.ResponseTime,FWbemObject.TimeToLive]))
        else
          Writeln(Format('Reply from %s: bytes=%s time=<1ms TTL=%s',[FWbemObject.ProtocolAddress,FWbemObject.ReplySize,FWbemObject.TimeToLive]));

        Inc(PacketsReceived);

        if FWbemObject.ResponseTime>Maximum then
        Maximum:=FWbemObject.ResponseTime;

        if Minimum=0 then
        Minimum:=Maximum;

        if FWbemObject.ResponseTime<Minimum then
        Minimum:=FWbemObject.ResponseTime;

        Average:=Average+FWbemObject.ResponseTime;
      end
      else
      if not VarIsNull(FWbemObject.StatusCode) then
        Writeln(Format('Reply from %s: %s',[FWbemObject.ProtocolAddress,GetStatusCodeStr(FWbemObject.StatusCode)]))
      else
        Writeln(Format('Reply from %s: %s',[Address,'Error processing request']));
    end;
    FWbemObject:=Unassigned;
    FWbemObjectSet:=Unassigned;
    //Sleep(500);
  end;

  Writeln('');
  Writeln(Format('Ping statistics for %s:',[Address]));
  Writeln(Format('    Packets: Sent = %d, Received = %d, Lost = %d (%d%% loss),',[Retries,PacketsReceived,Retries-PacketsReceived,Round((Retries-PacketsReceived)*100/Retries)]));
  if PacketsReceived>0 then
  begin
   Writeln('Approximate round trip times in milli-seconds:');
   Writeln(Format('    Minimum = %dms, Maximum = %dms, Average = %dms',[Minimum,Maximum,Round(Average/PacketsReceived)]));
  end;
end;


begin
 try
    CoInitialize(nil);
    try
      //Ping('192.168.52.130',4,32);
      Ping('theroadtodelphi.wordpress.com',4,32);
    finally
      CoUninitialize;
    end;
 except
    on E:Exception do
        Writeln(E.Classname, ':', E.Message);
 end;
 Readln;
end.

And the output


1 Comment

Microsoft SQL Server CLR and Delphi Prism Part 1 : CLR Stored Procedures

This is the first of a series of articles where i will show you how integrate Delphi Prism and the SQL Server CLR support.

SQL Server (Since version 2005) allow you to create database objects using the integration with the .NET Framework common language runtime (CLR). this mean which you can create a .net assembly and then call the methods defined in your class directly from SQL Server like any SQL Object, you can create Scalar-valued user-defined functions (scalar UDFs), Table-valued user-defined functions (TVFs), User-defined procedures (UDPs) and User-defined triggers.

today we will see how to create CLR Stored Procedures from Delphi prism.

Ok, first you need to create a new Delphi prism project of class library type.

Now before to define the code to be accessed from SQL Server you must know the requirements of the CLR stored procedures.

1) In the common language runtime (CLR), stored procedures are implemented as public static methods on a class in a Microsoft .NET Framework assembly.

2) you must include the Microsoft.SqlServer.Server namespace in your uses list.

3) The Parameters passed to a CLR stored procedure can be any of the native SQL Server types that have an equivalent in managed code

4) all the methods must have the [Microsoft.SqlServer.Server.SqlProcedure()] attribute, this attribute tells to Visual Studio compiler that this is a stored procedure for SQL Server.

Check this sample declaration for a Delphi prism class which contains CLR stored procedures.

namespace MyNameSpace;

interface
uses
  System,
  System.Data,
  System.Data.SqlClient,
  Microsoft.SqlServer.Server,
  System.Data.SqlTypes;

type
  MyClass  = public class
  public
    [Microsoft.SqlServer.Server.SqlProcedure()]
    class method GetSqlVersion(out Intvalue: SqlInt32;out Strvalue: SqlString);
    [Microsoft.SqlServer.Server.SqlProcedure()]
    class method Hello;
    [Microsoft.SqlServer.Server.SqlProcedure()]
    class method GetTables;
    [Microsoft.SqlServer.Server.SqlProcedure()]
    class method GetRecordResult;
  end;

The CLR Stored Procedures can return information in several ways. This includes output parameters, tabular results, and messages.

OUTPUT Parameters and CLR Stored Procedures
in this sample method you can see how can return output parameters. this method return the sql version string and the sql version as a integer value. (off course you can obtain directly from SQL Server this information but this is just a sample)

class method MyClass.GetSqlVersion(out Intvalue: SqlInt32;out Strvalue: SqlString); //look the types used, are SQL Server types remember the requirements?
begin
    Intvalue := 0;
    Strvalue := '';    
    var  connection: SqlConnection := new SqlConnection('context connection=true'); //this is cool in this line you are using the current connection instance of the caller client, so you don't need connect to the SQL server.
    connection.Open();
    var command: SqlCommand := new SqlCommand('Select @@VERSION,@@MICROSOFTVERSION', connection); //get the version info
    var reader: SqlDataReader := command.ExecuteReader(); 
      if reader.Read() then begin
        Strvalue := reader.GetSqlString(0); //assign the values
        Intvalue := reader.GetSqlInt32(1);
      end
end;

Returning Messages
one of the overload versions of the SqlContext.Pipe.Send method allow you to send messages directly to the client or current output consumer.

class method MyClass.Hello;
begin
     SqlContext.Pipe.Send('Hello From delphi Prism'); //send the message to client
end;

Returning Tabular Results directly to the client
You can return directly to the client a result set. this sample method returns a list of the tables and rows in the current database.

class method MyClass.GetTables;
begin 
    var  connection: SqlConnection := new SqlConnection('context connection=true');
    connection.Open();
    var command: SqlCommand := new SqlCommand(
    'SELECT  so.name [TableName],MAX(si.rows) [RowCount] '+
    'FROM '+ 
    'sysobjects so, '+ 
    'sysindexes si '+ 
    'WHERE '+ 
    'so.xtype = ''U'' '+ 
    'AND '+ 
    'si.id = OBJECT_ID(so.name) '+ 
    'GROUP BY '+ 
    'so.name '+ 
    'ORDER BY '+ 
    '2 DESC', connection);
     // send the result set to the client directly.
     SqlContext.Pipe.ExecuteAndSend(command);   
end;

Creating a dynamic result set and send them to the client
You can also create a result set on the fly and return to the client the results. this sample method create a record with 4 columns(fields).

class method MyClass.GetRecordResult;
begin
      // Create a record object with 4 columns that represents an individual row, including it's metadata.
      var ARecord : SqlDataRecord  := new SqlDataRecord(new SqlMetaData('Col1', SqlDbType.NVarChar, 100),
                                                        new SqlMetaData('Col2', SqlDbType.Int),
                                                        new SqlMetaData('Col3', SqlDbType.Float),
                                                        new SqlMetaData('Col4', SqlDbType.DateTime)
      );    
      // Populate the record.
      ARecord.SetString(0, 'Delphi Prism is cool');      
      ARecord.SetInt32 (1, 1024*1024);      
      ARecord.SetDouble(2, Math.PI);      
      ARecord.SetDateTime(3, DateTime.Now);    
      // Send the record to the client.
      SqlContext.Pipe.Send(ARecord);
end;

Ok, now we have our code, we need deploy in the SQL Server.

first you must activate CLR support in the SQL server, because is disabled by default. execute this sentence to activate the CLR support.

sp_configure 'clr enabled', 1
GO
RECONFIGURE
GO

Now we need register our assembly using the CREATE ASSEMBLY sentence.
this is the syntax

CREATE ASSEMBLY assembly_name
[ AUTHORIZATION owner_name ]
FROM { <client_assembly_specifier> | <assembly_bits> [ ,...n ] }
[ WITH PERMISSION_SET = { SAFE | EXTERNAL_ACCESS | UNSAFE } ]
[ ; ]
<client_assembly_specifier> :: ='[\\computer_name\]share_name\[path\]manifest_file_name'
  | '[local_path\]manifest_file_name'<assembly_bits> :: =
{ varbinary_literal | varbinary_expression }

in this case the sentence will look like this

CREATE ASSEMBLY MyDelphiPrismAssembly1 from 'C:\Prism Projects\Delphi Prism SqlCLR\MyPrismClr\bin\Release\MyPrismClr.dll' 
WITH PERMISSION_SET = SAFE
GO

if all it’s ok you must can view the registered assembly under the assemblies folder of your SQL Management Studio.

next we need create and register every procedure of our assembly. see this sample, in this sentence we are creating a SQL Server stored procedure called hello where the implementation is defined in our assembly.

CREATE PROCEDURE Hello
AS
EXTERNAL NAME MyDelphiPrismAssembly1.[MyNameSpace.MyClass].Hello

now you can execute this stored procedure in this way

 EXEC Hello

and the result will be

Now the same steps to register our GetTables method

CREATE PROCEDURE GetTables
AS
EXTERNAL NAME MyDelphiPrismAssembly1.[MyNameSpace.MyClass].GetTables

and when you execute this stored procedure the result will be something like this.

now creating the GetRecordResult stored procedure

CREATE PROCEDURE GetRecordResult
AS
EXTERNAL NAME MyDelphiPrismAssembly1.[MyNameSpace.MyClass].GetRecordResult

and the output

finally this is how you must register a stored procedure with output parameters.

CREATE PROCEDURE  GetSqlVersion(@Intvalue int OUTPUT, @Strvalue NVARCHAR(255) OUTPUT)
AS
EXTERNAL NAME MyDelphiPrismAssembly1.[MyNameSpace.MyClass].GetSqlVersion

and to see the results

DECLARE @Intvalue int
DECLARE @Strvalue NVARCHAR(255)
EXECUTE  GetSqlVersion @Intvalue OUTPUT , @Strvalue OUTPUT
SELECT @Intvalue Version_Number,@Strvalue Version_Str

This is the full source-code of the Delphi prism class used in this article.

namespace MyNameSpace;

interface
uses
  System,
  System.Data,
  System.Data.SqlClient,
  Microsoft.SqlServer.Server,
  System.Data.SqlTypes;

type
  MyClass  = public class
  public
    //OUTPUT Parameters and CLR Stored Procedures
    [Microsoft.SqlServer.Server.SqlProcedure()]
    class method GetSqlVersion(out Intvalue: SqlInt32;out Strvalue: SqlString);
    //Returning Messages
    [Microsoft.SqlServer.Server.SqlProcedure()]
    class method Hello;
    //Returning Tabular Results directly to the client
    [Microsoft.SqlServer.Server.SqlProcedure()]
    class method GetTables;
    //Creating a dynamic result set and send them to the client
    [Microsoft.SqlServer.Server.SqlProcedure()]
    class method GetRecordResult;
  end;
  
implementation

//OUTPUT Parameters and CLR Stored Procedures
class method MyClass.GetSqlVersion(out Intvalue: SqlInt32;out Strvalue: SqlString);
begin
    Intvalue := 0;
    Strvalue := '';    
    var  connection: SqlConnection := new SqlConnection('context connection=true');
    connection.Open();
    var command: SqlCommand := new SqlCommand('Select @@VERSION,@@MICROSOFTVERSION', connection);
    var reader: SqlDataReader := command.ExecuteReader();
      if reader.Read() then begin
        Strvalue := reader.GetSqlString(0);
        Intvalue := reader.GetSqlInt32(1);
      end
end;

//Returning Messages
class method MyClass.Hello;
begin
     SqlContext.Pipe.Send('Hello From delphi Prism');
end;

//Returning Tabular Results directly to the client
class method MyClass.GetTables;
begin 
    var  connection: SqlConnection := new SqlConnection('context connection=true');
    connection.Open();
    var command: SqlCommand := new SqlCommand(
    'SELECT  so.name [TableName],MAX(si.rows) [RowCount] '+
    'FROM '+ 
    'sysobjects so, '+ 
    'sysindexes si '+ 
    'WHERE '+ 
    'so.xtype = ''U'' '+ 
    'AND '+ 
    'si.id = OBJECT_ID(so.name) '+ 
    'GROUP BY '+ 
    'so.name '+ 
    'ORDER BY '+ 
    '2 DESC', connection);
     // send the result set to the client directly.
     SqlContext.Pipe.ExecuteAndSend(command);   
end;

class method MyClass.GetRecordResult;
begin
      // Create a record object that represents an individual row, including it's metadata.
      var ARecord : SqlDataRecord  := new SqlDataRecord(new SqlMetaData('Col1', SqlDbType.NVarChar, 100),
                                                        new SqlMetaData('Col2', SqlDbType.Int),
                                                        new SqlMetaData('Col3', SqlDbType.Float),
                                                        new SqlMetaData('Col4', SqlDbType.DateTime)
      );    
      // Populate the record.
      ARecord.SetString(0, 'Delphi Prism is cool');      
      ARecord.SetInt32 (1, 1024*1024);      
      ARecord.SetDouble(2, Math.PI);      
      ARecord.SetDateTime(3, DateTime.Now);      
      // Send the record to the client.
      SqlContext.Pipe.Send(ARecord);
end;


end.

the samples showed in this article are very simple, and just pretend show the basic functionalities, you can find many ways to apply this to your own project. personally I use SQL CLR in real life applications to calculate hashes, encrypt data and make complex calculations.

See you.