Windows Programming Tips/fr
│
English (en) │
français (fr) │
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
- Problèmes connus avec Lazarus (et qui ne seront jamais réglés) - Liste de problèmes de compatibilité avec certaines interfaces.
- Interface win32/64 - Interface win32/64 pour Windows 95/98/Me/2K/XP/Vista, mais pas CE.
- Interface Windows CE - Pour Pocket PC et smartphones.
- Interface Carbon - Interface Carbon pour macOS.
- Interface Cocoa - Interface Cocoa pour macOS.
- Interface Qt - Interface Qt4 pour Unix, macOS, Windows et PDA basés sur Linux.
- Interface GTK1 - Interface GTK1 pour Unix, macOS et Windows.
- Interface GTK2 - Interface GTK2 pour Unix, macOS et Windows.
- Interface GTK3 - L'interface GTK3 pour les unix, macOS et Windows.
- Interface fpGUI - Interface basée sur la bibliothèque fpGUI, un ensemble de composants graphiques multiplateforme complètement écrit en Pascal Objet.
- Interface Custom Drawn - Backend LCL multiplateforme complètement écrit en Pascal Objet dans Lazarus. Il s'agit de l'interface de Lazarus pour Android.
Tuyaux spécifiques aux plate-formes
- Tuyau pour la programmation sous Windows
- Tuyaux pour la programmation sous Linux - Comment réaliser certaines tâches de programmation sous Linux
- Tuyaux pour la programmation sous macOS - Installation de Lazarus, outils utiles, commandes Unix, et plus encore...
- Tuyaux pour la programmation sous WinCE - Utilisation de l'API téléphone, envoi de SMS, et plus encore...
- Programmation Android - Pour les smartphones et les tablettes Android
- Développement iPhone/iPod - Au sujet de l'utilisation d'Objective Pascal pour développer des applications iOS
Articles sur le développement d'interfaces
- Carbon interface internals - Si vous voulez participer au développement de l'interface Carbon
- Windows CE Development Notes - Pour Pocket PC et Smartphones
- Ajouter une nouvelle interface - Comment ajouter une interface pour un nouveau jeu de widgets
- LCL Defines - Choix des bonnes options pour recompiler la LCL.
- LCL Internals - Des infos sur le fonctionnement interne de la LCL.
- Cocoa Internals - Des infos sur le fonctionnement interne du jeu de contrôles Cocoa.
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)
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 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;
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.
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 MyDocuments 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);
Another way to achieve the task without using the Windows API is to query a specific environment variable. This solution allows to write a more homogeneous system code since depending on the OS, only the variable name has to be changed.
For example:
program UseEnv;
uses sysutils;
begin
writeln(GetEnvironmentVariable('APPDATA'));
writeln(GetEnvironmentVariable('PROGRAMFILES'));
writeln(GetEnvironmentVariable('HOMEPATH'));
readln;
end.
However this solution is not always as accurate as SHGetSpecialFolderPath(), since it is sometimes necessary to compose between several variables.
The available variables can be retrieved with GetEnvironmentString():
program ListEnv;
uses sysutils;
var
i: integer;
begin
for i in [0..GetEnvironmentVariableCount-1] do
writeln(GetEnvironmentString(i));
readln;
end.
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 this to 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
│
English (en) │
français (fr) │
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. Below code cannot find out its own exename though.
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.
See also