Windows Programming Tips

From Lazarus wiki
Jump to: navigation, search
Windows logo - 2012.svg

This article applies to Windows only.

See also: Multiplatform Programming Guide

This page is dedicated to desktop Windows - including server - Windows) programming tips.

Contents


Other Interfaces

Platform specific Tips

Interfaces Development Articles

Articles about Windows Programming

  • High DPI - How to make your application DPI-aware on Windows 7.
  • Aero Glass - How to apply Aero Glass effect in a Lazarus Form on Windows 7.
  • Windows Icon - How to design your icon with the right sizes.
  • Inno Setup Usage - How to create setup files with File Association support.

FPC 2.6.x/Lazarus warning (Missing support for SEH)

Warning-icon.png

Warning: If you can avoid it, do not use Win64 builds of Lazarus based on FPC 2.6.x and earlier (this includes Lazarus 1.x. See below for details.

Please be aware that all current Lazarus 1.x releases use FPC 2.6.x. FPC 2.6.x (and probably earlier versions as well) does not properly support Windows 64 bit. Therefore, please use the 32 bit Lazarus IDE on Win64. If it is absolutely necessary to build 64 bit executables (e.g. explorer extensions), please install the 64 bit cross compiler add on for the 32 bit IDE.

Details of the bug: on Windows 64, exceptions in (third party) DLLs may be raised using SEH. These exceptions should be handled within the DLL itself.

However, FPC sees an (incorrect) FPC exception which may cause your programs (or Lazarus) to crash. This applies to DLLs like printer drivers, database drivers, Windows explorer extensions.

The issue has been fixed in the FPC development version but it is a major change and it will not be backported to FPC 2.6.x.

Relevant bug reports include http://bugs.freepascal.org/view.php?id=12742

Windows specific compiler options

The most prominent options are the -W flags. A GUI application requires the -WG flag. See Project Options / Compiler Options / Linking / Target OS Specific options / Win32 GUI application. No console is shown, writeln and readln are not possible, you will get File not open errors. Omitting this option creates a console application (same as passing -WC).

Writing cross-platform code that works on Windows

While you can use Windows-only code (such as the windows unit), with a little care you can often prepare for cross-platform use (e.g. use the lclintf unit).

See Multiplatform Programming Guide#Windows specific issues for more details.

COM Programming

Importing and using a COM library

The first step to import and use a COM library is generating the interface definitions from it. Use the program importtl which is located in Free Pascal in fpc/utils/importtl. A pre-compiled binary of this program can be found here: http://sourceforge.net/projects/p-tools/files/ImportTL/

You can call it, for example for MSAA like this:

importtl.exe C:\Windows\system32\oleacc.dll

And it will generate the type library pascal unit Accessibility_1_1_TLB.pas in the folder where it is.

Creating a library which exports a COM object

ToDo: write me

Windows Sensor/Location API

Available since Windows 7. See LazDeviceAPIs#Possible Windows implementation

ActiveX controls

You can use ActiveX controls in recent Lazarus versions. See LazActiveX

Services

Lazarus and FPC make writing Windows services easy. See Daemons and Services

Code snippets

File Association

To add icons to file associations and register for use with a program use: FileAssociation component.

Listing all available drives

program listdevices;
 
{$ifdef fpc}{$mode delphi}{$endif}
{$apptype console}
 
uses
  Windows;
 
var
  Drive: Char;
  DriveLetter: string;
begin
  WriteLn('The following drives were found in this computer:');
  WriteLn('');
 
  // Search all drive letters
  for Drive := 'A' to 'Z' do
  begin
    DriveLetter := Drive + ':\';
 
    case GetDriveType(PChar(DriveLetter)) of
     DRIVE_REMOVABLE: WriteLn(DriveLetter + ' Floppy Drive');
     DRIVE_FIXED:     WriteLn(DriveLetter + ' Fixed Drive');
     DRIVE_REMOTE:    WriteLn(DriveLetter + ' Network Drive');
     DRIVE_CDROM:     WriteLn(DriveLetter + ' CD-ROM Drive');
     DRIVE_RAMDISK:   WriteLn(DriveLetter + ' RAM Disk');
    end;
  end;
 
  // Also add a stop to see the result under Windows
  WriteLn('');
  WriteLn('Please press <ENTER> to exit the program.');
  ReadLn(DriveLetter);
end.

Creating a shortcut (.lnk) file

Creating a shortcut on the desktop (can be easily adapted to any location). Adapted from post by Felipe Monteiro de Carvalho The ISLink object has more methods that you can use to modify your shortcut... 

uses
...
windows, shlobj {for special folders}, ActiveX, ComObj;
...
procedure CreateDesktopShortCut(Target, TargetArguments, ShortcutName: string);
var
  IObject: IUnknown;
  ISLink: IShellLink;
  IPFile: IPersistFile;
  PIDL: PItemIDList;
  InFolder: array[0..MAX_PATH] of Char;
  TargetName: String;
  LinkName: WideString;
begin
  { Creates an instance of IShellLink }
  IObject := CreateComObject(CLSID_ShellLink);
  ISLink := IObject as IShellLink;
  IPFile := IObject as IPersistFile;
 
  ISLink.SetPath(pChar(Target));
  ISLink.SetArguments(pChar(TargetArguments));
  ISLink.SetWorkingDirectory(pChar(ExtractFilePath(Target)));
 
  { Get the desktop location }
  SHGetSpecialFolderLocation(0, CSIDL_DESKTOPDIRECTORY, PIDL);
  SHGetPathFromIDList(PIDL, InFolder);
  LinkName := InFolder + PathDelim + ShortcutName+'.lnk';
 
  { Create the link }
  IPFile.Save(PWChar(LinkName), false);
end;

Getting special folders (My documents, Desktop, local application data, etc)

Often it is useful to get the location of a special folder such as the desktop. The example below shows how you can get the LocalAppData directory - where you can store user-specific configuration file files etc for your programs.

Use the My Documents folder (or a subfolder) to store documents.

Look in the shlobj unit (note: link may not be up to date) for more defines that let you look up the Desktop (note: use CSIDL_DESKTOPDIRECTORY, not CSIDL_DESKTOP), Recycle Bin, etc. 

uses 
...
shlobj;
 
var
  AppDataPath: Array[0..MaxPathLen] of Char; //Allocate memory
...
begin
...
    AppDataPath:='';
    SHGetSpecialFolderPath(0,AppDataPath,CSIDL_LOCAL_APPDATA,false);
    writeln('Your local appdata path is: ' + AppDataPath);

Enabling and disabling devices

The following code can be used to enable and disable Windows devices; it is useful to e.g. reset a serial port or USB device. An example program follows below. 

unit controlwindevice;
 
{ Enable Disable windows devices
 
  Copyright (c) 2010-2012 Ludo Brands
 
  Permission is hereby granted, free of charge, to any person obtaining a copy
  of this software and associated documentation files (the "Software"), to
  deal in the Software without restriction, including without limitation the
  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
  sell copies of the Software, and to permit persons to whom the Software is
  furnished to do so, subject to the following conditions:
 
  The above copyright notice and this permission notice shall be included in
  all copies or substantial portions of the Software.
 
  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
  IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
  AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
  IN THE SOFTWARE.
}
 
 
{$mode delphi}{$H+}
 
interface
 
uses
  Classes, SysUtils,dynlibs,windows;
 
const
  GUID_DEVCLASS_NET : TGUID = '{4D36E972-E325-11CE-BFC1-08002BE10318}';
  GUID_DEVCLASS_PORT : TGUID = '{4D36E978-E325-11CE-BFC1-08002BE10318}';
 
type
  TDeviceControlResult=(DCROK,DCRErrEnumDeviceInfo,DCRErrSetClassInstallParams,
    DCRErrDIF_PROPERTYCHANGE);
 
function LoadDevices(GUID_DevClass:TGUID):TStringList;
function EnableDevice(SelectedItem: DWord):TDeviceControlResult;
function DisableDevice(SelectedItem: DWord):TDeviceControlResult;
 
implementation
 
// Setup api, based on SetupApi.pas JEDI library
const
    DIF_PROPERTYCHANGE                = $00000012;
    DICS_ENABLE     = $00000001;
    DICS_DISABLE    = $00000002;
    DICS_FLAG_GLOBAL         = $00000001;  // make change in all hardware profiles
    DIGCF_PRESENT         = $00000002;
    SPDRP_DEVICEDESC                  = $00000000; // DeviceDesc (R/W)
    SPDRP_CLASS                       = $00000007; // Class (R--tied to ClassGUID)
    SPDRP_CLASSGUID                   = $00000008; // ClassGUID (R/W)
    SPDRP_FRIENDLYNAME                = $0000000C; // FriendlyName (R/W)
 
type
  HDEVINFO = Pointer;
  DI_FUNCTION = LongWord;    // Function type for device installer
 
  PSPClassInstallHeader = ^TSPClassInstallHeader;
  SP_CLASSINSTALL_HEADER = packed record
    cbSize: DWORD;
    InstallFunction: DI_FUNCTION;
  end;
  TSPClassInstallHeader = SP_CLASSINSTALL_HEADER;
 
  PSPPropChangeParams = ^TSPPropChangeParams;
  SP_PROPCHANGE_PARAMS = packed record
    ClassInstallHeader: TSPClassInstallHeader;
    StateChange: DWORD;
    Scope: DWORD;
    HwProfile: DWORD;
  end;
  TSPPropChangeParams = SP_PROPCHANGE_PARAMS;
 
  PSPDevInfoData = ^TSPDevInfoData;
  SP_DEVINFO_DATA = packed record
    cbSize: DWORD;
    ClassGuid: TGUID;
    DevInst: DWORD; // DEVINST handle
    Reserved: ULONG_PTR;
  end;
  TSPDevInfoData = SP_DEVINFO_DATA;
 
  TSetupDiEnumDeviceInfo = function(DeviceInfoSet: HDEVINFO;
    MemberIndex: DWORD; var DeviceInfoData: TSPDevInfoData): LongBool; stdcall;
  TSetupDiSetClassInstallParamsA = function(DeviceInfoSet: HDEVINFO;
    DeviceInfoData: PSPDevInfoData; ClassInstallParams: PSPClassInstallHeader;
    ClassInstallParamsSize: DWORD): LongBool; stdcall;
  TSetupDiSetClassInstallParamsW = function(DeviceInfoSet: HDEVINFO;
    DeviceInfoData: PSPDevInfoData; ClassInstallParams: PSPClassInstallHeader;
    ClassInstallParamsSize: DWORD): LongBool; stdcall;
  TSetupDiSetClassInstallParams = TSetupDiSetClassInstallParamsA;
  TSetupDiCallClassInstaller = function(InstallFunction: DI_FUNCTION;
    DeviceInfoSet: HDEVINFO; DeviceInfoData: PSPDevInfoData): LongBool; stdcall;
  TSetupDiGetClassDevs = function(ClassGuid: PGUID; const Enumerator: PAnsiChar;
    hwndParent: HWND; Flags: DWORD): HDEVINFO; stdcall;
  TSetupDiGetDeviceRegistryPropertyA = function(DeviceInfoSet: HDEVINFO;
    const DeviceInfoData: TSPDevInfoData; Property_: DWORD;
    var PropertyRegDataType: DWORD; PropertyBuffer: PBYTE; PropertyBufferSize: DWORD;
    var RequiredSize: DWORD): BOOL; stdcall;
  TSetupDiGetDeviceRegistryPropertyW = function(DeviceInfoSet: HDEVINFO;
    const DeviceInfoData: TSPDevInfoData; Property_: DWORD;
    var PropertyRegDataType: DWORD; PropertyBuffer: PBYTE; PropertyBufferSize: DWORD;
    var RequiredSize: DWORD): BOOL; stdcall;
  TSetupDiGetDeviceRegistryProperty = TSetupDiGetDeviceRegistryPropertyA;
 
var
  DevInfo: hDevInfo;
  SetupDiEnumDeviceInfo: TSetupDiEnumDeviceInfo;
  SetupDiSetClassInstallParams: TSetupDiSetClassInstallParams;
  SetupDiCallClassInstaller: TSetupDiCallClassInstaller;
  SetupDiGetClassDevs: TSetupDiGetClassDevs;
  SetupDiGetDeviceRegistryProperty: TSetupDiGetDeviceRegistryProperty;
 
var
  SetupApiLoadCount:integer=0;
 
function LoadSetupApi: Boolean;
var SetupApiLib:TLibHandle;
begin
  Result := True;
  Inc(SetupApiLoadCount);
  if SetupApiLoadCount > 1 then
    Exit;
  SetupApiLib:=LoadLibrary('SetupApi.dll');
  Result := SetupApiLib<>0;
  if Result then
  begin
    SetupDiEnumDeviceInfo := GetProcedureAddress(SetupApiLib, 'SetupDiEnumDeviceInfo');
    SetupDiSetClassInstallParams := GetProcedureAddress(SetupApiLib, 'SetupDiSetClassInstallParamsA');
    SetupDiCallClassInstaller := GetProcedureAddress(SetupApiLib, 'SetupDiCallClassInstaller');
    SetupDiGetClassDevs := GetProcedureAddress(SetupApiLib, 'SetupDiGetClassDevsA');
    SetupDiGetDeviceRegistryProperty := GetProcedureAddress(SetupApiLib, 'SetupDiGetDeviceRegistryPropertyA');
  end;
end;
 
// implementation
 
function StateChange(NewState, SelectedItem: DWord;
  hDevInfo: hDevInfo): TDeviceControlResult;
var
  PropChangeParams: TSPPropChangeParams;
  DeviceInfoData: TSPDevInfoData;
begin
  PropChangeParams.ClassInstallHeader.cbSize := SizeOf(TSPClassInstallHeader);
  DeviceInfoData.cbSize := SizeOf(TSPDevInfoData);
  // Get a handle to the Selected Item.
  if (not SetupDiEnumDeviceInfo(hDevInfo, SelectedItem, DeviceInfoData)) then
  begin
    Result := DCRErrEnumDeviceInfo;
    exit;
  end;
  // Set the PropChangeParams structure.
  PropChangeParams.ClassInstallHeader.InstallFunction := DIF_PROPERTYCHANGE;
  PropChangeParams.Scope := DICS_FLAG_GLOBAL;
  PropChangeParams.StateChange := NewState;
  if (not SetupDiSetClassInstallParams(hDevInfo, @DeviceInfoData,
     PSPClassInstallHeader(@PropChangeParams), SizeOf(PropChangeParams))) then
  begin
    Result := DCRErrSetClassInstallParams;
    exit;
  end;
  // Call the ClassInstaller and perform the change.
  if (not SetupDiCallClassInstaller(DIF_PROPERTYCHANGE, hDevInfo, @DeviceInfoData)) then
  begin
    Result := DCRErrDIF_PROPERTYCHANGE;
    exit;
  end;
  Result := DCROK;
end;
 
function GetRegistryProperty(PnPHandle: HDEVINFO;
  DevData: TSPDevInfoData; Prop: DWORD; Buffer: PChar;
  dwLength: DWord): Boolean;
var
  aBuffer: array[0..256] of Char;
begin
  dwLength := 0;
  aBuffer[0] := #0;
  SetupDiGetDeviceRegistryProperty(PnPHandle, DevData, Prop, Prop, PBYTE(@aBuffer[0]), SizeOf(aBuffer), dwLength);
  StrCopy(Buffer, aBuffer);
  Result := Buffer^ <> #0;
end;
 
function ConstructDeviceName(DeviceInfoSet: hDevInfo;
  DeviceInfoData: TSPDevInfoData; Buffer: PChar; dwLength: DWord): Boolean;
const
  UnknownDevice = '<Unknown Device>';
begin
  if (not GetRegistryProperty(DeviceInfoSet, DeviceInfoData, SPDRP_FRIENDLYNAME, Buffer, dwLength)) then
  begin
    if (not GetRegistryProperty(DeviceInfoSet, DeviceInfoData, SPDRP_DEVICEDESC, Buffer, dwLength)) then
    begin
      if (not GetRegistryProperty(DeviceInfoSet, DeviceInfoData, SPDRP_CLASS, Buffer, dwLength)) then
      begin
        if (not GetRegistryProperty(DeviceInfoSet, DeviceInfoData, SPDRP_CLASSGUID, Buffer, dwLength)) then
        begin
          dwLength := DWord(SizeOf(UnknownDevice));
          Buffer := Pointer(LocalAlloc(LPTR, Cardinal(dwLength)));
          StrCopy(Buffer, UnknownDevice);
        end;
      end;
    end;
  end;
  Result := true;
end;
 
 
function LoadDevices(GUID_DevClass:TGUID):TStringList;
var
  DeviceInfoData: TSPDevInfoData;
  i: DWord;
  pszText: PChar;
 
begin
  if (not LoadSetupAPI) then
    begin
    result:=nil;
    exit;
    end;
  DevInfo := nil;
  // Get a handle to all devices in all classes present on system
  DevInfo := SetupDiGetClassDevs(@GUID_DevClass, nil, 0, DIGCF_PRESENT);
  if (DevInfo = Pointer(INVALID_HANDLE_VALUE)) then
  begin
    result:=nil;
    exit;
  end;
  Result:=TStringList.Create;
  DeviceInfoData.cbSize := SizeOf(TSPDevInfoData);
  i := 0;
  // Enumerate though all the devices.
  while SetupDiEnumDeviceInfo(DevInfo, i, DeviceInfoData) do
  begin
    GetMem(pszText, 256);
    try
      // Get a friendly name for the device.
      ConstructDeviceName(DevInfo, DeviceInfoData, pszText, DWord(nil));
      Result.AddObject(pszText,Tobject(i));
    finally
      FreeMem(pszText);
      inc(i);
    end;
  end;
end;
 
function EnableDevice(SelectedItem: DWord):TDeviceControlResult;
 
begin
  result:=StateChange(DICS_ENABLE, SelectedItem , DevInfo);
end;
 
function DisableDevice(SelectedItem: DWord):TDeviceControlResult;
 
begin
  result:=StateChange(DICS_DISABLE, SelectedItem , DevInfo);
end;
 
end.

Example program that lists all ports preceeded by a number.

Enter a number and the port will be disabled. Enter return again and the port will be enabled again. 

program devicetest;
 
{$mode delphi}{$H+}
 
uses
  Classes, controlwindevice;
var
  sl:tstringlist;
  i:integer;
begin
  sl:=Loaddevices(GUID_DEVCLASS_PORT);
  for i:=0 to sl.count-1 do
    writeln(i,' : ',sl[i]);
  readln(i);
  if DisableDevice(i)=DCROK then
    writeln(sl[i],' disabled');
  readln;
  if EnableDevice(i)=DCROK then
    writeln(sl[i],' enabled');
  sl.Free;
  readln;
end.

Downloading a file using urlmon

Urlmon.dll is built into Windows and can be used to e.g. download a file from a web site. It supports SSL/TLS connections.

Windows-only; please look into libraries like fphttpclient, Synapse and Indy for cross-platform solutions. 

function URLDownloadToFile(pCaller: pointer; URL: PChar; FileName: PChar; Reserved: DWORD; lpfnCB : pointer): HResult; stdcall; external 'urlmon.dll' name 'URLDownloadToFileA';
 
procedure TForm1.Button1Click(Sender: TObject);
var Source, Dest: string;
begin
 Source:='http://lazarus.freepascal.org';
 Dest:='C:\Windows\temp\data.txt';
 if URLDownloadToFile(nil, PChar(Source), PChar(Dest), 0, nil)=0 then
  showmessage('Download ok!')
 else
  showMessage('Error downloading '+Source);
end;

Showing/finding processes

Use code like thisto find a process handle based on the executable name (akin to the tasklist command): 

program ProcessFindPID;
 
{$mode objfpc}{$H+}
 
uses 
  Classes, Sysutils, Windows, JwaTlHelp32;
 
function QueryFullProcessImageName(hProcess: HANDLE; dwFlags: DWORD; var lpExeName: LPTSTR;
var lpdwSize: LPDWORD): BOOL; stdcall; external 'KERNEL32.dll';
 
function FindInProcesses(const PName: string): DWord;
  // Looks for process with PName executable and return
var
  i: integer;
  CPID: DWORD;
  CProcName: array[0..259] of char;
  S: HANDLE;
  PE: TProcessEntry32;
begin
  Result := 0;
  CProcName := '';
  S := CreateToolHelp32Snapshot(TH32CS_SNAPALL, 0); // Create snapshot
  PE.DWSize := SizeOf(PE); // Set size before use
  I := 1;
  if Process32First(S, PE) then
    repeat
      CProcName := PE.szExeFile;
      CPID := PE.th32ProcessID;
      //if CProcName = '' then Writeln(IntToStr(i) + ' - (' + IntToStr(CPID) + ') Failed to get a process name')
      Inc(i);
      if UpperCase(CProcName) = UpperCase(PName) then
        // Found the name. Set Result to the PID of process found
        Result := CPID;
    until not Process32Next(S, PE);
  CloseHandle(S);
end;
 
begin
  writeln('Explorer.exe has process id '+inttostr(FindInProcesses('explorer.exe')));
end.

Identify Windows Version

There is a code example at WindowsVersion/de

Test whether an Application is already running

Here's a unit that works under both Windows and Linux

  • There's no need to pass the full application path to the function - the ExeName will usually do 
unit uappisrunning;
 
{$mode objfpc}{$H+}
 
interface
 
uses
  Classes, SysUtils
  {$IFDEF WINDOWS}, Windows, JwaTlHelp32{$ENDIF}
  {$IFDEF LINUX},process{$ENDIF};
// JwaTlHelp32 is in fpc\packages\winunits-jedi\src\jwatlhelp32.pas
 
// Returns TRUE if EXEName is running under Windows or Linux
// Don't pass an .exe extension to Linux!
function AppIsRunning(const ExeName: string):Boolean;
 
implementation
// These functions return Zero if app is NOT running
// Override them if you have a better implementation
{$IFDEF WINDOWS}
function WindowsAppIsRunning(const ExeName: string): integer;
var
  ContinueLoop: BOOL;
  FSnapshotHandle: THandle;
  FProcessEntry32: TProcessEntry32;
begin
  FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
  FProcessEntry32.dwSize := SizeOf(FProcessEntry32);
  ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32);
  Result := 0;
  while integer(ContinueLoop) <> 0 do
    begin
    if ((UpperCase(ExtractFileName(FProcessEntry32.szExeFile)) =
      UpperCase(ExeName)) or (UpperCase(FProcessEntry32.szExeFile) =
      UpperCase(ExeName))) then
      begin
      Inc(Result);
      // SendMessage(Exit-Message) possible?
      end;
    ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32);
    end;
  CloseHandle(FSnapshotHandle);
end;
{$ENDIF}
{$IFDEF LINUX}
function LinuxAppIsRunning(const ExeName: string): integer;
var
  t: TProcess;
  s: TStringList;
begin
  Result := 0;
  t := tprocess.Create(nil);
  t.CommandLine := 'ps -C ' + ExeName;
  t.Options := [poUsePipes, poWaitonexit];
    try
    t.Execute;
    s := TStringList.Create;
      try
      s.LoadFromStream(t.Output);
      Result := Pos(ExeName, s.Text);
      finally
      s.Free;
      end;
    finally
    t.Free;
    end;
end;
{$ENDIF}
function AppIsRunning(const ExeName: string):Boolean;
begin
{$IFDEF WINDOWS}
  Result:=(WindowsAppIsRunning(ExeName) > 0);
{$ENDIF}
{$IFDEF LINUX}
  Result:=(LinuxAppIsRunning(ExeName) > 0);
{$ENDIF}
end;
end.

Minesadorada

Retrieved from "http://wiki.lazarus.freepascal.org/index.php?title=Windows_Programming_Tips&oldid=85533"
Personal tools