Windows Programming Tips/fr

From Lazarus wiki
Jump to navigationJump to search

│ English (en) │ français (fr) │

Windows logo - 2012.svg

Cet article s'applique uniquement à Windows.

Voir aussi: Multiplatform Programming Guide/fr

Cette page est dédiée au bureau Windows - en y incluant le serveur - Trucs de programmation Windows.

Autres Interfaces

Tuyaux spécifiques aux plate-formes

Articles sur le développement d'interfaces

Articles sur la programmation Windows

  • High DPI - Comment rendre sensible au DPI votre application sur Windows 7 ?
  • Aero Glass - Comment appliquer l'effet Aero Glass sur une fiche Lazarus sur Windows 7 ?
  • Icône Windows - Comment concevoir votre icône dans les bonnes tailles ?
  • Emploi d'Inno Setup - Comment créer les fichiers d'installation avec le support des associations de fichiers ?

Avertissement sur FPC 2.6.x/Lazarus (support manquant pour SEH)

Warning-icon.png

Avertissement: Si vous pouvez l'éviter, n'utilisez pas les versions Win64 de Lazarus basées sur FPC 2.6.x et antérieures (ceci inclut Lazarus 1.x. Voir plus bas pour les détails.

Gardez à l'esprit que les versions Lazarus 1.x utilisent FPC 2.6.x. FPC 2.6.x (et probablement aussi de plus anciennes versions) ne supporte pas proprement Windows 64 bit. En conséquence, utilisez de préférence l'IDE Lazarus 32-bit sous Win64. S'il est absolument nécessaire de construire des exécutables 64-bit (p.ex. des extensions de l'explorateur), installez alors le compilateur croisé 64-bit en add-on pour l'IDE 32-bit.

Détails sur le bug : Sur Win64, les exceptions dans les DLLs (tierce-partie) peuvent être levée en utilsant SEH. Ces exceptions devrait être gérées à l'intérieur de la DLL elle-même.

Toutefois, FPC voit une exception FPC (incorrecte) qui peut amener votre programme ou Lazarus à planter. Cela s'applique au DLLs comme les pilotes d'imprimantes, les pilotes de base de données, les extensions de Windows Explorer.

Le problème a été corrigé dans la version de développement de FPC mais c'est un changement majeur qui ne sera reporté dans FPC 2.6.x.

Des rapports de bug pertinents incluent http://bugs.freepascal.org/view.php?id=12742.

Options du compilateur spécifiques à Windows

Les plus importantes options sont les drapeaux -W. Une application IHM nécessite le drapeau -WG. Voir Options pour le projet / Options du compilateur / Ajouts et remplacements / Définir Win32. Aucune console n'est visible, writeln et readln ne sont pas possible, vous obtiendrez des erreurs File not open. L'omission de cette option aboutit à une application console (identique à -WC).

Ecrire du code multiplate-forme qui tourne sur Windows

Alors que vous pouvez utiliser du code Windows seulement (comme avec l'unité windows), avec un peu de soin vous pouvez souvent préparer pour une utilisation multiplate-forme (i.e. utiliser l'unité lclintf).

Voir Problèmes spécifiques à Windows pour plus de détails.

Programmation COM

Importation et emploi d'une bibliothèque COM

La première étape pour import et utiliser une bibliothèque COM consiste à générer les définitions d'interface à partir d'elle. Utiliser le programme importtl qui est à l'emplacement fpc/utils/importtl dans Free Pascal. Un binaire pré-compilé peut être trouvé là : http://sourceforge.net/projects/p-tools/files/ImportTL/.

Vous pouvez l'appeler, par exemple pour MSAA comme cela : 

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

Et il générera l'unité Pascal de bibliothèque de type Accessibility_1_1_TLB.pas dans le dossier où il se trouve.

Création d'une bibliothèque qui exporte un objet COM

A faire: écrivez-moi...

Capteur Windows/API de localisation

Disponible depuis Windows 7. Voir Implémentation possible dans Windows

Contrôles ActiveX

Vous pouvez utiliser des contrôles ActiveX dans les versions récentes de Lazarus. Voir LazActiveX.

Services

Lazarus et FPC facilitent l'écriture de services Windows. See Daemons et Services.

Extraits de code

Association de fichier

Pour ajouter des icônes aux associations de fichier et l'enregistrer pour l'utilisation avec un programme, utilisez le composant FileAssociation.

Liste de tous les lecteurs disponibles

program listdevices;

{$ifdef fpc}{$mode delphi}{$endif}
{$apptype console}

uses
  Windows;

var
  Drive: Char;
  DriveLetter: string;
  OldMode: Word; 
begin
  WriteLn('The following drives were found in this computer:');
  WriteLn('');

  // Empty Floppy or Zip drives can generate a Windows error.
  // We disable system errors during the listing.
  // Note that another way to skip these errors would be to use DEVICE_IO_CONTROL.
  OldMode := SetErrorMode(SEM_FAILCRITICALERRORS);
  try 

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

  finally
    // Restores previous Windows error mode.
    SetErrorMode(OldMode); 
  end;

  // Also add a stop to see the result under Windows
  WriteLn('');
  WriteLn('Please press <ENTER> to exit the program.');
  ReadLn(DriveLetter);
end.

Création d'un fichier raccourci (.lnk)

La création d'un raccourci sur le bureau peut être adapté à tout emplacement. Adapté de posté par Felipe Monteiro de Carvalho L'objet ISLink a plus de méthodes a plus de méthodes que vous pouvez utiliser pour modifier votre raccourci... 

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;

Obtention des dossiers spéciaux (Mes documents, Bureau, Données locales d'application, etc)

Il est souvent utile d'obtenir l'emplacement d'un dossier spécial tel que le bureau. L'exemple du dessous montre comment vous pouvez obtenir le dossier LocalAppData - où vous pouvez enregistrer un fichier de configuration dédié à l'utilisateur, des fichiers etc pour votre programme.

Utiliser le dossier MesDocuments (ou un sous-dossier) pour stocker des documents.

Regardez dans l'unité shlobj (note: le lien peut ne pas être à jour) pour plus de définitions qui vous laissent atteindre le Bureau (note : utilisez CSIDL_DESKTOPDIRECTORY, pas CSIDL_DESKTOP), la poubelle, 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);

Une autre manière pour réussir cela sans employer l'API Windows est d'interroger une variable d'environnement spécifique. Cette solution permet d'écrire un code système plus homogène puisque selon le système d'exploitation, seul le nom de la variable doit être modifié.

Par exemple : 

program UseEnv;

uses sysutils;

begin
  writeln(GetEnvironmentVariable('APPDATA'));
  writeln(GetEnvironmentVariable('PROGRAMFILES'));
  writeln(GetEnvironmentVariable('HOMEPATH'));
  readln;
end.

Toutefois cette solution n'est pas aussi précise que SHGetSpecialFolderPath(), puisqu'il est parfois nécessaire de composer entre plusieurs variables.

Les variables disponibles peuvent être récupérées avec SHGetSpecialFolderPath() : 

program ListEnv;

uses sysutils;

var
  i: integer;

begin
  for i in [0..GetEnvironmentVariableCount-1] do
    writeln(GetEnvironmentString(i));
  readln;
end.

Activation et désactivation de périphériques

Le code suivant peut être utilisé pour activer et désactiver des périphériques Windows ; c'est utile pour p.ex. réinitialiser un port série pour un périphérique USB. Un exemple suit dessous. 

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.

Exemple de programme qui liste tous les ports précédé d'un nombre.

Entrez un nombre et le port sera désactivé. Entrez Retour à nouveau et le port sera activé à nouveau. 

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.

Télécharger un fichier en utilisant urlmon

Urlmon.dll est construite dans Windows et peut être pour p.ex. télécharger un fichier depuis un site Web. Il supporte les connexions SSL/TLS.

Valable uniquement pour Windows ; regardez dans les bibliothèques comme fphttpclient, Synapse et Indy pour des solutions multi plates-formes. 

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;

Montrer/trouver des processus

UTiliser un code comme celui-ci pour trouver un handle de processus en se basant sur le nom de l'exécutable (similaire à la commande TaskList) : 

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.

Identifier la version de Windows

C'est un exemple de code de WindowsVersion/de.

│ English (en) │ français (fr) │

Teste si une application est déjà en train de tourner

Voici une unité qui marche à la fois sous Windows et Linux.

  • Il n'est pas besoin de passer le chemin complet à l'application - Le ExeName suffira en général.
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.

NdT: une version objet aurait été plus tendance...

Retrieved from "http://wiki.freepascal.org/index.php?title=Windows_Programming_Tips/fr&oldid=105385"