I am trying to understand the documentation at MSDN regarding Device Events
and how to trigger a notification whenever a volume has been mounted.
I have managed to do this for USB devices using information presented in the following post: detect usb drive/device using delphi
as well as other information found on the internet,
but I have noticed that it would be easier to detect when a volume has been mounted directly.
So my question is: how do I implement Device Events handling in my Delphi app?
I am looking at the following documentation: https://msdn.microsoft.com/en-us/library/windows/desktop/aa363217(v=vs.85).aspx
But I can't really figure out how to get it up and running.
So far I have tried the following code, which compiles properly,
but nothing happens, please push me in the right direction:
PDevBroadcastHdr = ^DEV_BROADCAST_HDR;
DEV_BROADCAST_HDR = packed record
dbch_size : DWORD;
dbch_devicetype : DWORD;
dbch_reserved : DWORD;
end;
PDevBroadcastHandle = ^DEV_BROADCAST_HANDLE;
DEV_BROADCAST_HANDLE = packed record
dbch_size : DWORD ;
dbch_devicetype : DWORD ;
dbch_reserved : DWORD ;
dbch_handle : THandle ;
dbch_hdevnotify : HDEVNOTIFY ;
dbch_eventguid : TGUID ;
dbch_nameoffset : LongInt ;
dbch_data : byte ;
end;
...
procedure WMDeviceChange(var Msg: TMessage);
const
DBT_DEVTYP_HANDLE = $0006;
GUID_IO_VOLUME_MOUNT: TGUID = '{B5804878-1A96-11D2-8FFD-00A0C9A06D32}';
...
function TForm1.RegisterThis: Boolean;
var
dbv: DEV_BROADCAST_HANDLE;
Size: Integer;
r: Pointer;
begin
Size := SizeOf(DEV_BROADCAST_HANDLE);
ZeroMemory(#dbv, Size);
dbv.dbch_size := Size;
dbv.dbch_devicetype := DBT_DEVTYP_HANDLE;
dbv.dbch_reserved := 0;
dbv.dbch_handle := 0;
dbv.dbch_hdevnotify := nil;
dbv.dbch_eventguid := GUID_IO_VOLUME_MOUNT;
dbv.dbch_nameoffset := 0;
dbv.dbch_data := 0;
r := RegisterDeviceNotification(FWindowHandle, #dbv, DEVICE_NOTIFY_WINDOW_HANDLE);
if Assigned(r) then Result := True;
end;
procedure TForm1.WMDeviceChange(var Msg: TMessage);
var
VData: PDevBroadcastHandle;
begin
ShowMessage('Hello!');
end;
There are quite a lot of problems with what you have so far. Here is what I can see.
Incorrect recipient
You are passing a window handle to RegisterDeviceNotification. However, it's far from clear that your window handle implements a message handler for WM_DEVICECHANGE. I recommend using AllocateHWnd to obtain a window handle, and handle WM_DEVICECHANGE in the window procedure that you supply to AllocateHWnd.
Failure to call UnregisterDeviceNotification
The documentation of RegisterDeviceNotification says:
Device notification handles returned by RegisterDeviceNotification must be closed by calling the UnregisterDeviceNotification function when they are no longer needed.
You fail to do this. You have to hold on to the handle returned by RegisterDeviceNotification and pass it to UnregisterDeviceNotification when you no longer want to receive notifications.
Erroneous packing of records
You declared packed records. This is a mistake. For reasons unclear to me, it seems to be a prevailing mistake for Delphi developers to pack their records. Packing results in poor performance. Even worse, when performing interop with aligned records, packing simply results in an incorrect laying out of the record. These records are not packed.
Furthermore, I don't believe that your record should include a dbch_data member. That's only used for DBT_CUSTOMEVENT and I don't think that applies to you. I would declare the record like this:
type
DEV_BROADCAST_HANDLE = record
dbch_size : DWORD ;
dbch_devicetype : DWORD ;
dbch_reserved : DWORD ;
dbch_handle : THandle ;
dbch_hdevnotify : HDEVNOTIFY ;
dbch_eventguid : TGUID ;
dbch_nameoffset : LONG ;
end;
Weak error checking
You do check the return value of the call to RegisterDeviceNotification. That's good. But if that call fails then you don't call GetLastError to find out why, as described in the documentation. I'd write the call like this:
var
DevNotificationHandle: HDEVNOTIFY;
....
DevNotificationHandle := RegisterDeviceNotification(...);
Win32Check(DevNotificationHandle <> 0);
That way any errors will be translated into exceptions with textual error messages representing the Win32 error code.
Likely incorrect value of dbch_devicetype
I think you should be passing DBT_DEVTYP_DEVICEINTERFACE rather than DBT_DEVTYP_HANDLE. If you switch to DBT_DEVTYP_DEVICEINTERFACE and address all the points I raised above, then you will receive notifications. For instance:
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Classes,
Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.StdCtrls;
type
TForm1 = class(TForm)
Memo1: TMemo;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
FWindow: HWND;
FDevNotificationHandle: HDEVNOTIFY;
procedure WndMethod(var Message: TMessage);
function HandleDeviceChange(Event: DWORD; Data: Pointer): Boolean;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
type
DEV_BROADCAST_HANDLE = record
dbch_size: DWORD;
dbch_devicetype: DWORD;
dbch_reserved: DWORD;
dbch_handle: THandle;
dbch_hdevnotify: HDEVNOTIFY;
dbch_eventguid: TGUID;
dbch_nameoffset: LONG;
end;
const
DBT_DEVTYP_DEVICEINTERFACE = $0005;
GUID_IO_VOLUME_MOUNT: TGUID = '{B5804878-1A96-11D2-8FFD-00A0C9A06D32}';
procedure TForm1.FormCreate(Sender: TObject);
var
dbh: DEV_BROADCAST_HANDLE;
begin
FWindow := AllocateHWnd(WndMethod);
dbh := Default(DEV_BROADCAST_HANDLE);
dbh.dbch_size := SizeOf(dbh);
dbh.dbch_devicetype := DBT_DEVTYP_DEVICEINTERFACE;
dbh.dbch_eventguid := GUID_IO_VOLUME_MOUNT;
FDevNotificationHandle := RegisterDeviceNotification(FWindow, #dbh,
DEVICE_NOTIFY_WINDOW_HANDLE);
Win32Check(FDevNotificationHandle <> nil);
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
if FDevNotificationHandle <> nil then
Win32Check(UnregisterDeviceNotification(FDevNotificationHandle));
DeallocateHWnd(FWindow);
end;
procedure TForm1.WndMethod(var Message: TMessage);
begin
case Message.Msg of
WM_DEVICECHANGE:
Message.Result := ord(HandleDeviceChange(Message.WParam,
Pointer(Message.LParam)));
else
Message.Result := DefWindowProc(FWindow, Message.Msg, Message.WParam,
Message.LParam);
end;
end;
function TForm1.HandleDeviceChange(Event: DWORD; Data: Pointer): Boolean;
begin
Memo1.Lines.Add(Format('%4x', [Event]));
Result := True;
end;
end.
Note that a default set of notifications is broadcast to top-level windows. So you may not even need to register because I believe that volume changes are part of the default set.
You have to declare your WMDeviceChange method like this to receive message:
procedure WMDeviceChange(var Msg: TMessage); message WM_DEVICECHANGE;
Also, since your WMDeviceChange method is part of the Form you should use Form window Handle to register message.
r := RegisterDeviceNotification(Handle, #dbv, DEVICE_NOTIFY_WINDOW_HANDLE);
Since Handle can be recreated during Form's lifetime you should override Form's CreateWnd method and add registration there.
Or even better, you can encapsulate functionality in another class:
TDeviceDetector = class
protected
fHandle: THandle;
procedure WndProc(var Message: TMessage);
public
constructor Create;
destructor Destroy; override;
function RegisterThis: Boolean;
end;
constructor TDeviceDetector.Create;
begin
inherited;
fHandle := AllocateHWnd(WndProc);
end;
destructor TDeviceDetector.Destroy;
begin
DeallocateHWnd(fHandle);
inherited;
end;
function TDeviceDetector.RegisterThis: Boolean;
var
dbv: DEV_BROADCAST_HANDLE;
Size: Integer;
r: Pointer;
begin
Size := SizeOf(DEV_BROADCAST_HANDLE);
ZeroMemory(#dbv, Size);
dbv.dbch_size := Size;
dbv.dbch_devicetype := DBT_DEVTYP_HANDLE;
dbv.dbch_reserved := 0;
dbv.dbch_handle := 0;
dbv.dbch_hdevnotify := nil;
dbv.dbch_eventguid := GUID_IO_VOLUME_MOUNT;
dbv.dbch_nameoffset := 0;
dbv.dbch_data := 0;
r := RegisterDeviceNotification(fHandle, #dbv, DEVICE_NOTIFY_WINDOW_HANDLE);
if Assigned(r) then Result := True;
end;
procedure TDeviceDetector.WndProc(var Message: TMessage);
begin
if Message.Msg = WM_DEVICECHANGE then
begin
ShowMessage('Hello!');
end
else Message.Result := DefWindowProc(FHandle, Message.Msg, Message.wParam, Message.lParam); // Default Message Handler
end;
EDIT: Found a component on a forum regarding this. It is called TSHChangeNotify and was written by Elliott Shevinm back in 2000 (!)
See the forum thread here. It contains the sourcecode and a fix.
Theres also an article written by Zarko Gajic which explains how it works
found here
It works perfectly fine in Delphi XE7 on Windows 8.1 when using VCL only.
UPDATE: I modified the code so it now runs on Delphi XE7 with Firemonkey.
The updated code can be found here.
The way I set it up is by setting TSHChangeNotify.HardDriveOnly to FALSE
and putting TSHChangeNotify.Execute inside main forms OnCreate procedure.
Thanks to Dalija and David, I received some good information and code which came in handy.
However their answers did not solve my problem.
Like David said in one of the comments, he just wanted to "push me in the right direction" as I myself suggested in my question. Fair enough.
I started Googling for "guid_io_volume_mount c++" to see if I could find some usable code elsewhere that I could port.
I came across this forum post: http://www.mofeel.net/957-microsoft-public-vc-language/2343.aspx
The OP mentioned in his code that CreateFileA should be used in order to basically "monitor" whenever a mount point has changed.
A mount point seems to be the drive letter, for example C:, D:, E: etc...
So basically what happens is that by using the following code
var
dbv: DEV_BROADCAST_HANDLE;
Size: Integer;
r: Pointer;
begin
Size := SizeOf(DEV_BROADCAST_HANDLE);
ZeroMemory(#dbv, Size);
dbv.dbch_size := Size;
dbv.dbch_devicetype := DBT_DEVTYP_HANDLE;
dbv.dbch_reserved := 0;
dbv.dbch_handle := CreateFileA('\\.\C:', GENERIC_READ, FILE_SHARE_READ+FILE_SHARE_WRITE, nil, OPEN_EXISTING, FILE_FLAG_NO_BUFFERING + FILE_ATTRIBUTE_NORMAL + FILE_FLAG_SEQUENTIAL_SCAN, 0);
dbv.dbch_hdevnotify := 0;
dbv.dbch_nameoffset := 0;
r := RegisterDeviceNotification(fHandle, #dbv, DEVICE_NOTIFY_WINDOW_HANDLE);
if Assigned(r) then Result := True;
we let the OS know that whenever "C:" has changed its mount state (mount/dismount), the OS will send a message to our WndProc message catcher.
My full source is avaible below, still a bit buggy, but it presents a concept so far.
It can detect when a specified volume is mounted, at least.
Dismount is detected when you right click on a volume and select "Eject".
Now remember, this code can do more than just detecting when mount points are changed, this MSDN article has all the GUID's you need to do some pretty neat stuff.
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Classes,
Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.StdCtrls, Vcl.dialogs;
type
TDeviceDetector = class
protected
fHandle: THandle;
fLogger: TMemo;
fOnCDROM_EXCLUSIVE_LOCK ,
fOnCDROM_EXCLUSIVE_UNLOCK ,
fOnDEVICE_BECOMING_READY ,
fOnDEVICE_EXTERNAL_REQUEST ,
fOnMEDIA_ARRIVAL ,
fOnMEDIA_EJECT_REQUEST ,
fOnMEDIA_REMOVAL ,
fOnVOLUME_CHANGE ,
fOnVOLUME_CHANGE_SIZE ,
fOnVOLUME_DISMOUNT ,
fOnVOLUME_DISMOUNT_FAILED ,
fOnVOLUME_FVE_STATUS_CHANGE ,
fOnVOLUME_LOCK ,
fOnVOLUME_LOCK_FAILED ,
fOnVOLUME_MOUNT ,
fOnVOLUME_NAME_CHANGE ,
fOnVOLUME_NEED_CHKDSK ,
fOnVOLUME_PHYSICAL_CONFIGURATION_CHANGE ,
fOnVOLUME_PREPARING_EJECT ,
fOnVOLUME_UNIQUE_ID_CHANGE ,
fOnVOLUME_UNLOCK ,
fOnVOLUME_WEARING_OUT : TNotifyEvent;
procedure WndProc(var Message: TMessage);
procedure Log(AStr: string);
public
constructor Create;
destructor Destroy; override;
function RegisterThis: Boolean;
property Logger: TMemo read fLogger write fLogger;
published
property OnCDROM_EXCLUSIVE_LOCK : TNotifyEvent read fOnCDROM_EXCLUSIVE_LOCK write fOnCDROM_EXCLUSIVE_LOCK ;
property OnCDROM_EXCLUSIVE_UNLOCK : TNotifyEvent read fOnCDROM_EXCLUSIVE_UNLOCK write fOnCDROM_EXCLUSIVE_UNLOCK ;
property OnDEVICE_BECOMING_READY : TNotifyEvent read fOnDEVICE_BECOMING_READY write fOnDEVICE_BECOMING_READY ;
property OnDEVICE_EXTERNAL_REQUEST : TNotifyEvent read fOnDEVICE_EXTERNAL_REQUEST write fOnDEVICE_EXTERNAL_REQUEST ;
property OnMEDIA_ARRIVAL : TNotifyEvent read fOnMEDIA_ARRIVAL write fOnMEDIA_ARRIVAL ;
property OnMEDIA_EJECT_REQUEST : TNotifyEvent read fOnMEDIA_EJECT_REQUEST write fOnMEDIA_EJECT_REQUEST ;
property OnMEDIA_REMOVAL : TNotifyEvent read fOnMEDIA_REMOVAL write fOnMEDIA_REMOVAL ;
property OnVOLUME_CHANGE : TNotifyEvent read fOnVOLUME_CHANGE write fOnVOLUME_CHANGE ;
property OnVOLUME_CHANGE_SIZE : TNotifyEvent read fOnVOLUME_CHANGE_SIZE write fOnVOLUME_CHANGE_SIZE ;
property OnVOLUME_DISMOUNT : TNotifyEvent read fOnVOLUME_DISMOUNT write fOnVOLUME_DISMOUNT ;
property OnVOLUME_DISMOUNT_FAILED : TNotifyEvent read fOnVOLUME_DISMOUNT_FAILED write fOnVOLUME_DISMOUNT_FAILED ;
property OnVOLUME_FVE_STATUS_CHANGE : TNotifyEvent read fOnVOLUME_FVE_STATUS_CHANGE write fOnVOLUME_FVE_STATUS_CHANGE ;
property OnVOLUME_LOCK : TNotifyEvent read fOnVOLUME_LOCK write fOnVOLUME_LOCK ;
property OnVOLUME_LOCK_FAILED : TNotifyEvent read fOnVOLUME_LOCK_FAILED write fOnVOLUME_LOCK_FAILED ;
property OnVOLUME_MOUNT : TNotifyEvent read fOnVOLUME_MOUNT write fOnVOLUME_MOUNT ;
property OnVOLUME_NAME_CHANGE : TNotifyEvent read fOnVOLUME_NAME_CHANGE write fOnVOLUME_NAME_CHANGE ;
property OnVOLUME_NEED_CHKDSK : TNotifyEvent read fOnVOLUME_NEED_CHKDSK write fOnVOLUME_NEED_CHKDSK ;
property OnVOLUME_PHYSICAL_CONFIGURATION_CHANGE : TNotifyEvent read fOnVOLUME_PHYSICAL_CONFIGURATION_CHANGE write fOnVOLUME_PHYSICAL_CONFIGURATION_CHANGE;
property OnVOLUME_PREPARING_EJECT : TNotifyEvent read fOnVOLUME_PREPARING_EJECT write fOnVOLUME_PREPARING_EJECT ;
property OnVOLUME_UNIQUE_ID_CHANGE : TNotifyEvent read fOnVOLUME_UNIQUE_ID_CHANGE write fOnVOLUME_UNIQUE_ID_CHANGE ;
property OnVOLUME_UNLOCK : TNotifyEvent read fOnVOLUME_UNLOCK write fOnVOLUME_UNLOCK ;
property OnVOLUME_WEARING_OUT : TNotifyEvent read fOnVOLUME_WEARING_OUT write fOnVOLUME_WEARING_OUT ;
end;
TForm1 = class(TForm)
Memo1: TMemo;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
end;
var
Form1: TForm1;
dd: TDeviceDetector;
implementation
{$R *.dfm}
type
PDevBroadcastHdr = ^DEV_BROADCAST_HDR;
DEV_BROADCAST_HDR = packed record
dbch_size : DWORD;
dbch_devicetype : DWORD;
dbch_reserved : DWORD;
end;
PDevBroadcastHandle = ^DEV_BROADCAST_HANDLE;
DEV_BROADCAST_HANDLE = record
dbch_size : DWORD;
dbch_devicetype : DWORD;
dbch_reserved : DWORD;
dbch_handle : THandle;
dbch_hdevnotify : HDEVNOTIFY;
dbch_eventguid : TGUID;
dbch_nameoffset : LONG;
dbch_data: array [0..0] of Byte;
end;
const
DEVICE_NOTIFY_ALL_INTERFACE_CLASSES = $00000004;
DBT_CUSTOMEVENT = $8006;
DBT_DEVTYP_HANDLE = $0006;
GUID_IO_CDROM_EXCLUSIVE_LOCK : TGUID = '{bc56c139-7a10-47ee-a294-4c6a38f0149a}';
GUID_IO_CDROM_EXCLUSIVE_UNLOCK : TGUID = '{a3b6d27d-5e35-4885-81e5-ee18c00ed779}';
GUID_IO_DEVICE_BECOMING_READY : TGUID = '{d07433f0-a98e-11d2-917a-00a0c9068ff3}';
GUID_IO_DEVICE_EXTERNAL_REQUEST : TGUID = '{d07433d0-a98e-11d2-917a-00a0c9068ff3}';
GUID_IO_MEDIA_ARRIVAL : TGUID = '{d07433c0-a98e-11d2-917a-00a0c9068ff3}';
GUID_IO_MEDIA_EJECT_REQUEST : TGUID = '{d07433d1-a98e-11d2-917a-00a0c9068ff3}';
GUID_IO_MEDIA_REMOVAL : TGUID = '{d07433c1-a98e-11d2-917a-00a0c9068ff3}';
GUID_IO_VOLUME_CHANGE : TGUID = '{7373654a-812a-11d0-bec7-08002be2092f}';
GUID_IO_VOLUME_CHANGE_SIZE : TGUID = '{3a1625be-ad03-49f1-8ef8-6bbac182d1fd}';
GUID_IO_VOLUME_DISMOUNT : TGUID = '{d16a55e8-1059-11d2-8ffd-00a0c9a06d32}';
GUID_IO_VOLUME_DISMOUNT_FAILED : TGUID = '{E3C5B178-105D-11D2-8FFD-00A0C9A06D32}';
GUID_IO_VOLUME_FVE_STATUS_CHANGE : TGUID = '{062998b2-ee1f-4b6a-b857-e76cbbe9a6da}';
GUID_IO_VOLUME_LOCK : TGUID = '{50708874-c9af-11d1-8fef-00a0c9a06d32}';
GUID_IO_VOLUME_LOCK_FAILED : TGUID = '{ae2eed10-0ba8-11d2-8ffb-00a0c9a06d32}';
GUID_IO_VOLUME_MOUNT : TGUID = '{b5804878-1a96-11d2-8ffd-00a0c9a06d32}';
GUID_IO_VOLUME_NAME_CHANGE : TGUID = '{2de97f83-4c06-11d2-a532-00609713055a}';
GUID_IO_VOLUME_NEED_CHKDSK : TGUID = '{799a0960-0a0b-4e03-ad88-2fa7c6ce748a}';
GUID_IO_VOLUME_PHYSICAL_CONFIGURATION_CHANGE : TGUID = '{2de97f84-4c06-11d2-a532-00609713055a}';
GUID_IO_VOLUME_PREPARING_EJECT : TGUID = '{c79eb16e-0dac-4e7a-a86c-b25ceeaa88f6}';
GUID_IO_VOLUME_UNIQUE_ID_CHANGE : TGUID = '{af39da42-6622-41f5-970b-139d092fa3d9}';
GUID_IO_VOLUME_UNLOCK : TGUID = '{9a8c3d68-d0cb-11d1-8fef-00a0c9a06d32}';
GUID_IO_VOLUME_WEARING_OUT : TGUID = '{873113ca-1486-4508-82ac-c3b2e5297aaa}';
function WDE_GUID_To_String(AGUID: TGUID): string; //WDE stands for Windows Device Events
begin
if AGUID = GUID_IO_CDROM_EXCLUSIVE_LOCK then result := 'GUID_IO_CDROM_EXCLUSIVE_LOCK' else
if AGUID = GUID_IO_CDROM_EXCLUSIVE_UNLOCK then result := 'GUID_IO_CDROM_EXCLUSIVE_UNLOCK' else
if AGUID = GUID_IO_DEVICE_BECOMING_READY then result := 'GUID_IO_DEVICE_BECOMING_READY' else
if AGUID = GUID_IO_DEVICE_EXTERNAL_REQUEST then result := 'GUID_IO_DEVICE_BECOMING_READY' else
if AGUID = GUID_IO_MEDIA_ARRIVAL then result := 'GUID_IO_MEDIA_ARRIVAL' else
if AGUID = GUID_IO_MEDIA_EJECT_REQUEST then result := 'GUID_IO_MEDIA_EJECT_REQUEST' else
if AGUID = GUID_IO_MEDIA_REMOVAL then result := 'GUID_IO_MEDIA_REMOVAL' else
if AGUID = GUID_IO_VOLUME_CHANGE then result := 'GUID_IO_VOLUME_CHANGE' else
if AGUID = GUID_IO_VOLUME_CHANGE_SIZE then result := 'GUID_IO_VOLUME_CHANGE_SIZE' else
if AGUID = GUID_IO_VOLUME_DISMOUNT then result := 'GUID_IO_VOLUME_DISMOUNT' else
if AGUID = GUID_IO_VOLUME_DISMOUNT_FAILED then result := 'GUID_IO_VOLUME_DISMOUNT_FAILED' else
if AGUID = GUID_IO_VOLUME_FVE_STATUS_CHANGE then result := 'GUID_IO_VOLUME_FVE_STATUS_CHANGE' else
if AGUID = GUID_IO_VOLUME_LOCK then result := 'GUID_IO_VOLUME_LOCK' else
if AGUID = GUID_IO_VOLUME_LOCK_FAILED then result := 'GUID_IO_VOLUME_LOCK_FAILED' else
if AGUID = GUID_IO_VOLUME_MOUNT then result := 'GUID_IO_VOLUME_MOUNT' else
if AGUID = GUID_IO_VOLUME_NAME_CHANGE then result := 'GUID_IO_VOLUME_NAME_CHANGE' else
if AGUID = GUID_IO_VOLUME_NEED_CHKDSK then result := 'GUID_IO_VOLUME_NEED_CHKDSK' else
if AGUID = GUID_IO_VOLUME_PHYSICAL_CONFIGURATION_CHANGE then result := 'GUID_IO_VOLUME_PHYSICAL_CONFIGURATION_CHANGE' else
if AGUID = GUID_IO_VOLUME_PREPARING_EJECT then result := 'GUID_IO_VOLUME_PREPARING_EJECT' else
if AGUID = GUID_IO_VOLUME_UNIQUE_ID_CHANGE then result := 'GUID_IO_VOLUME_UNIQUE_ID_CHANGE' else
if AGUID = GUID_IO_VOLUME_UNLOCK then result := 'GUID_IO_VOLUME_UNLOCK' else
if AGUID = GUID_IO_VOLUME_WEARING_OUT then result := 'GUID_IO_VOLUME_WEARING_OUT';
end;
constructor TDeviceDetector.Create;
begin
inherited;
fHandle := AllocateHWnd(WndProc);
end;
destructor TDeviceDetector.Destroy;
begin
DeallocateHWnd(fHandle);
inherited;
end;
function TDeviceDetector.RegisterThis: Boolean;
var
dbv: DEV_BROADCAST_HANDLE;
Size: Integer;
r: Pointer;
begin
Size := SizeOf(DEV_BROADCAST_HANDLE);
ZeroMemory(#dbv, Size);
dbv.dbch_size := Size;
dbv.dbch_devicetype := DBT_DEVTYP_HANDLE;
dbv.dbch_reserved := 0;
dbv.dbch_handle := CreateFileA('\\.\E:', GENERIC_READ, FILE_SHARE_READ + FILE_SHARE_WRITE, nil, OPEN_EXISTING, FILE_FLAG_NO_BUFFERING + FILE_ATTRIBUTE_NORMAL + FILE_FLAG_SEQUENTIAL_SCAN, 0);
dbv.dbch_hdevnotify := RegisterDeviceNotification(fHandle, #dbv, DEVICE_NOTIFY_ALL_INTERFACE_CLASSES);;
dbv.dbch_nameoffset := 0;
if Assigned(dbv.dbch_hdevnotify) then Result := True;
end;
procedure TDeviceDetector.WndProc(var Message: TMessage);
var data: PDevBroadcastHdr;
data_H: PDevBroadcastHandle;
begin
if Message.wParam = DBT_CUSTOMEVENT then //according to MSDN, DEV_BROADCAST_HANDLE structure is treated as a custom event.
begin
Data := PDevBroadcastHdr(Message.LParam); //we need to treat this custom evend a DEV_BROADCAST_HDR structure first...
if Data^.dbch_devicetype = DBT_DEVTYP_HANDLE then //then we check if the device type is DBT_DEVTYP_HANDLE
begin
data_H := PDevBroadcastHandle(Message.lParam); //if the device type is DBT_DEVTYP_HANDLE, we treat the custom event as a DEV_BROADCAST_HANDLE structure
//final step is to see what GUID the event of the structure DEV_BROADCAST_HANDLE has
Log(WDE_GUID_To_String(data_H^.dbch_eventguid));
if IsEqualGUID(data_H^.dbch_eventguid, GUID_IO_CDROM_EXCLUSIVE_LOCK) = true then if assigned(fOnCDROM_EXCLUSIVE_LOCK) then fOnCDROM_EXCLUSIVE_LOCK(self) else
if IsEqualGUID(data_H^.dbch_eventguid, GUID_IO_CDROM_EXCLUSIVE_UNLOCK) = true then if assigned(fOnCDROM_EXCLUSIVE_UNLOCK) then fOnCDROM_EXCLUSIVE_UNLOCK(self) else
if IsEqualGUID(data_H^.dbch_eventguid, GUID_IO_DEVICE_BECOMING_READY) = true then if assigned(fOnDEVICE_BECOMING_READY) then fOnDEVICE_BECOMING_READY(self) else
if IsEqualGUID(data_H^.dbch_eventguid, GUID_IO_DEVICE_EXTERNAL_REQUEST) = true then if assigned(fOnDEVICE_EXTERNAL_REQUEST) then fOnDEVICE_EXTERNAL_REQUEST(self) else
if IsEqualGUID(data_H^.dbch_eventguid, GUID_IO_MEDIA_ARRIVAL) = true then if assigned(fOnMEDIA_ARRIVAL) then fOnMEDIA_ARRIVAL(self) else
if IsEqualGUID(data_H^.dbch_eventguid, GUID_IO_MEDIA_EJECT_REQUEST) = true then if assigned(fOnMEDIA_EJECT_REQUEST) then fOnMEDIA_EJECT_REQUEST(self) else
if IsEqualGUID(data_H^.dbch_eventguid, GUID_IO_MEDIA_REMOVAL) = true then if assigned(fOnMEDIA_REMOVAL) then fOnMEDIA_REMOVAL(self) else
if IsEqualGUID(data_H^.dbch_eventguid, GUID_IO_VOLUME_CHANGE) = true then if assigned(fOnVOLUME_CHANGE) then fOnVOLUME_CHANGE(self) else
if IsEqualGUID(data_H^.dbch_eventguid, GUID_IO_VOLUME_CHANGE_SIZE) = true then if assigned(fOnVOLUME_CHANGE_SIZE) then fOnVOLUME_CHANGE_SIZE(self) else
if IsEqualGUID(data_H^.dbch_eventguid, GUID_IO_VOLUME_DISMOUNT) = true then if assigned(fOnVOLUME_DISMOUNT) then fOnVOLUME_DISMOUNT(self) else
if IsEqualGUID(data_H^.dbch_eventguid, GUID_IO_VOLUME_DISMOUNT_FAILED) = true then if assigned(fOnVOLUME_DISMOUNT_FAILED) then fOnVOLUME_DISMOUNT_FAILED(self) else
if IsEqualGUID(data_H^.dbch_eventguid, GUID_IO_VOLUME_FVE_STATUS_CHANGE) = true then if assigned(fOnVOLUME_FVE_STATUS_CHANGE) then fOnVOLUME_FVE_STATUS_CHANGE(self) else
if IsEqualGUID(data_H^.dbch_eventguid, GUID_IO_VOLUME_LOCK) = true then if assigned(fOnVOLUME_LOCK) then fOnVOLUME_LOCK(self) else
if IsEqualGUID(data_H^.dbch_eventguid, GUID_IO_VOLUME_LOCK_FAILED) = true then if assigned(fOnVOLUME_LOCK_FAILED) then fOnVOLUME_LOCK_FAILED(self) else
if IsEqualGUID(data_H^.dbch_eventguid, GUID_IO_VOLUME_MOUNT) = true then if assigned(fOnVOLUME_MOUNT) then fOnVOLUME_MOUNT(self) else
if IsEqualGUID(data_H^.dbch_eventguid, GUID_IO_VOLUME_NAME_CHANGE) = true then if assigned(fOnVOLUME_NAME_CHANGE) then fOnVOLUME_NAME_CHANGE(self) else
if IsEqualGUID(data_H^.dbch_eventguid, GUID_IO_VOLUME_NEED_CHKDSK) = true then if assigned(fOnVOLUME_NEED_CHKDSK) then fOnVOLUME_NEED_CHKDSK(self) else
if IsEqualGUID(data_H^.dbch_eventguid, GUID_IO_VOLUME_PHYSICAL_CONFIGURATION_CHANGE) = true then if assigned(fOnVOLUME_PHYSICAL_CONFIGURATION_CHANGE) then fOnVOLUME_PHYSICAL_CONFIGURATION_CHANGE(self) else
if IsEqualGUID(data_H^.dbch_eventguid, GUID_IO_VOLUME_PREPARING_EJECT) = true then if assigned(fOnVOLUME_PREPARING_EJECT) then fOnVOLUME_PREPARING_EJECT(self) else
if IsEqualGUID(data_H^.dbch_eventguid, GUID_IO_VOLUME_UNIQUE_ID_CHANGE) = true then if assigned(fOnVOLUME_UNIQUE_ID_CHANGE) then fOnVOLUME_UNIQUE_ID_CHANGE(self) else
if IsEqualGUID(data_H^.dbch_eventguid, GUID_IO_VOLUME_UNLOCK) = true then if assigned(fOnVOLUME_UNLOCK) then fOnVOLUME_UNLOCK(self) else
if IsEqualGUID(data_H^.dbch_eventguid, GUID_IO_VOLUME_WEARING_OUT) = true then if assigned(fOnVOLUME_WEARING_OUT) then fOnVOLUME_WEARING_OUT(self);
end;
end;
end;
procedure TDeviceDetector.Log(AStr: string);
begin
fLogger.Lines.Add(AStr);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
dd := TDeviceDetector.Create;
dd.Logger := Memo1;
if dd.RegisterThis = true then Memo1.Lines.Add('Registered!') else Memo1.Lines.Add('Failed to register!');
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
dd.free;
end;
end.
Related
In a Delphi package, I have a .RC file, with following content:
STRINGTABLE
BEGIN
1000, "First line."
1001, "Second line"
1002, "Last line"
END
The .RC file was included in .dpk source, and the following command is fully functional:
LoadStr(1000) {returns "First line."}
I want to get a complete list of lines in string table.
Using EnumResourceNames, it just returns content of default .res file (forms contents, etc). No content of .RC returned using EnumResourceNames.
Here is the code calling EnumResourceNames:
unit uxbResources;
interface
uses
System.SysUtils, System.Classes, WinApi.Windows;
type
TxbResources = class
private
FItems: TStringList;
public
constructor Create;
destructor Destroy; override;
procedure Load(const AHandle: THandle);
property Items: TStringList read FItems;
end;
implementation
function EnumResNamesProc( module: HMODULE; restype, resname: PChar; list: TStrings): Integer; stdcall;
begin
if HiWord( Cardinal(resname) ) <> 0 then
list.add( ' '+resname )
else
list.add( format(' #%d',[loword(cardinal(resname))]));
result := 1;
end;
function StockResourceType( restype: PChar ): string;
const
restypenames: array [1..22] of string = (
'RT_CURSOR', // = MakeIntResource(1);
'RT_BITMAP', // = MakeIntResource(2);
'RT_ICON', // = MakeIntResource(3);
'RT_MENU', // = MakeIntResource(4);
'RT_DIALOG', // = MakeIntResource(5);
'RT_STRING', // = MakeIntResource(6);
'RT_FONTDIR',// = MakeIntResource(7);
'RT_FONT', // = MakeIntResource(8);
'RT_ACCELERATOR',// = MakeIntResource(9);
'RT_RCDATA', // = MakeIntResource(10);
'RT_MESSAGETABLE',// = MakeIntResource(11);
// DIFFERENCE = 11;
'RT_GROUP_CURSOR',// = MakeIntResource(DWORD(RT_CURSOR + DIFFERENCE));
'UNKNOWN', // 13 not used
'RT_GROUP_ICON', // = MakeIntResource(DWORD(RT_ICON + DIFFERENCE));
'UNKNOWN', // 15 not used
'RT_VERSION', // = MakeIntResource(16);
'RT_DLGINCLUDE', // = MakeIntResource(17);
'UNKNOWN',
'RT_PLUGPLAY', // = MakeIntResource(19);
'RT_VXD', // = MakeIntResource(20);
'RT_ANICURSOR', // = MakeIntResource(21);
'RT_ANIICON' // = MakeIntResource(22);
);
var
resid: Cardinal absolute restype;
begin
if resid In [1..22] then
result := restypenames[resid]
else
result := 'UNKNOWN';
end;
function enumResTypesProc( module: HMODULE; restype: PChar; list: TStrings): Integer; stdcall;
var
s: string;
begin
if HiWord( cardinal(restype) ) <> 0 then
s := restype
else
s := format('Stock type %d: %s',[LoWord(cardinal(restype)), StockResourcetype( restype )]);
if (Pos('stringtable', Lowercase(s)) > 0)
or (Pos('documento', Lowercase(s)) > 0) then
begin
sleep(1);
end;
list.Add(s);
EnumResourceNames( module, restype, #enumResNamesProc, Integer(list));
Result := 1;
end;
constructor TxbResources.Create;
begin
inherited;
FItems := TStringList.Create;
end;
destructor TxbResources.Destroy;
begin
FItems.Free;
inherited;
end;
procedure TxbResources.Load(const AHandle: THandle);
var
s: string;
begin
if not Enumresourcetypes(AHandle, #EnumResTypesProc, Integer(FItems)) then
SysErrorMessage(GetLastError);
end;
...
with TxbResources.Create do
Load(LoadPackage('mypackage.bpl');
My question is: How could I get all lines from STRINGTABLE, since I do not know the id?
Thanks
I am using this code with Mutex and custom Message to force the 1st instance of application to appear on screen if the user tries to start a 2nd instance. There must be only 1 instance of my app running.
It seems that this code is not working properly under Win10, it makes the Application Icon to flick on TaskBar, but the actual Window is not appearing on top of other Windows.
function ForceForeground(AppHandle:HWND): boolean;
const
SPI_GETFOREGROUNDLOCKTIMEOUT = $2000;
SPI_SETFOREGROUNDLOCKTIMEOUT = $2001;
var
ForegroundThreadID: DWORD;
ThisThreadID : DWORD;
timeout : DWORD;
OSVersionInfo : TOSVersionInfo;
Win32Platform : Integer;
begin
if IsIconic(AppHandle) then ShowWindow(AppHandle, SW_RESTORE);
if (GetForegroundWindow = AppHandle) then Result := true else
begin
Win32Platform := 0;
OSVersionInfo.dwOSVersionInfoSize := SizeOf(OSVersionInfo);
if GetVersionEx(OSVersionInfo) then Win32Platform := OSVersionInfo.dwPlatformId;
{ Windows 98/2000 doesn't want to foreground a window when some other window has keyboard focus}
if ((Win32Platform = VER_PLATFORM_WIN32_NT) and (OSVersionInfo.dwMajorVersion > 4)) or
((Win32Platform = VER_PLATFORM_WIN32_WINDOWS) and ((OSVersionInfo.dwMajorVersion > 4) or
((OSVersionInfo.dwMajorVersion = 4) and (OSVersionInfo.dwMinorVersion > 0)))) then
begin
Result := false;
ForegroundThreadID := windows.GetWindowThreadProcessID(GetForegroundWindow,nil);
ThisThreadID := windows.GetWindowThreadPRocessId(AppHandle,nil);
if AttachThreadInput(ThisThreadID, ForegroundThreadID, true) then
begin
BringWindowToTop(AppHandle);
SetForegroundWindow(AppHandle);
AttachThreadInput(ThisThreadID, ForegroundThreadID, false);
Result := (GetForegroundWindow = AppHandle);
end;
if not Result then
begin
SystemParametersInfo(SPI_GETFOREGROUNDLOCKTIMEOUT, 0, #timeout, 0);
SystemParametersInfo(SPI_SETFOREGROUNDLOCKTIMEOUT, 0, TObject(0), SPIF_SENDCHANGE);
BringWindowToTop(AppHandle);
SetForegroundWindow(AppHandle);
SystemParametersInfo(SPI_SETFOREGROUNDLOCKTIMEOUT, 0, TObject(timeout), SPIF_SENDCHANGE);
Result := (GetForegroundWindow = AppHandle);
if not Result then
begin
ShowWindow(AppHandle,SW_HIDE);
ShowWindow(AppHandle,SW_SHOWMINIMIZED);
ShowWindow(AppHandle,SW_SHOWNORMAL);
BringWindowToTop(AppHandle);
SetForegroundWindow(AppHandle);
end;
end;
end else
begin
BringWindowToTop(AppHandle);
SetForegroundWindow(AppHandle);
end;
Result := (GetForegroundWindow = AppHandle);
end;
end;
I have managed to make a complete demo program that shows my suggestion in the 2nd comment above. Create a new VCL application. Rename the form to MainForm, place a TListBox on it, align it to client, rename it to ListBox, then make empty events for the form's OnCreate and OnDestroy.
Then copy/paste this PASCAL source into your main form's PAS file from right after "interface", overwriting the code already there:
uses
Winapi.Windows, Winapi.Messages,
System.SysUtils, System.Variants, System.Classes,
Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls;
CONST
WM_PEEK = WM_USER+1234;
type
TMainForm = class(TForm)
ListBox: TListBox;
procedure FormDestroy(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
Running : HWND;
PROCEDURE PEEK(VAR MSG : TMessage); MESSAGE WM_PEEK;
PROCEDURE CopyData(VAR MSG : TMessage); MESSAGE WM_COPYDATA;
PROCEDURE BringForward(Sender : TObject);
PROCEDURE SendString(H : HWND ; CONST S : STRING ; E : TEncoding);
FUNCTION CommandLine : STRING;
FUNCTION MakeAtomName(H : HWND) : STRING;
FUNCTION FindGlobalAtom(CONST S : STRING) : ATOM;
FUNCTION AddGlobalAtom(CONST S : STRING) : ATOM;
FUNCTION GetGlobalAtomName(H : ATOM) : STRING;
FUNCTION AtomNameToHandle(CONST S : STRING) : HWND;
FUNCTION DeleteGlobalAtom(A : ATOM) : DWORD;
public
{ Public declarations }
PROCEDURE LOG(CONST S : STRING);
end;
var
MainForm: TMainForm;
implementation
USES System.Character;
{$R *.dfm}
PROCEDURE TMainForm.FormDestroy(Sender : TObject);
VAR
S : STRING;
A : ATOM;
BEGIN
S:=MakeAtomName(0);
REPEAT
A:=FindGlobalAtom(S);
IF A=0 THEN BREAK;
UNTIL DeleteGlobalAtom(A)<>ERROR_SUCCESS
END;
FUNCTION TMainForm.AddGlobalAtom(CONST S : STRING) : ATOM;
BEGIN
Result:=WinAPI.Windows.GlobalAddAtom(PChar(S))
END;
FUNCTION TMainForm.MakeAtomName(H : HWND) : STRING;
CONST
L = 8*SizeOf(POINTER); // 32 or 64 (number of bits in a handle)
VAR
S : STRING;
I : Cardinal;
C : CHAR;
BEGIN
Result:=ChangeFileExt(ExtractFileName(ParamStr(0)),''); S:='';
FOR C IN Result DO IF CharInSet(C,['A'..'Z','a'..'z']) THEN S:=S+C;
WHILE LENGTH(S)<L DO S:=S+S;
SetLength(S,L);
Result:='';
FOR I:=1 TO L DO BEGIN
IF H AND $01<>0 THEN C:=S[I].ToUpper ELSE C:=S[I].ToLower;
Result:=C+Result; H:=H SHR 1
END
END;
FUNCTION TMainForm.AtomNameToHandle(CONST S : STRING) : HWND;
VAR
C : CHAR;
BEGIN
Result:=0;
FOR C IN S DO BEGIN
Result:=Result SHL 1;
IF CharInSet(C,['A'..'Z']) THEN Result:=Result OR 1
END
END;
PROCEDURE TMainForm.BringForward(Sender : TObject);
BEGIN
SetForegroundWindow(Running);
SendString(Running,CommandLine,TEncoding.UTF8);
ExitProcess(0)
END;
FUNCTION TMainForm.CommandLine : STRING;
BEGIN
Result:=GetCommandLine
END;
PROCEDURE TMainForm.CopyData(VAR MSG : TMessage);
VAR
CDS : PCopyDataStruct;
S : STRING;
B : TBytes;
BEGIN
CDS:=PCopyDataStruct(MSG.LParam);
SetLength(B,CDS.cbData);
MOVE(CDS.lpData^,POINTER(B)^,LENGTH(B));
S:=TEncoding.UTF8.GetString(B);
LOG('Child['+IntToHex(MSG.WParam)+']: '+S)
END;
FUNCTION TMainForm.DeleteGlobalAtom(A : ATOM) : DWORD;
BEGIN
SetLastError(ERROR_SUCCESS);
WinAPI.Windows.GlobalDeleteAtom(A);
Result:=GetLastError
END;
FUNCTION TMainForm.FindGlobalAtom(CONST S : STRING) : ATOM;
BEGIN
Result:=WinAPI.Windows.GlobalFindAtom(PChar(S))
END;
PROCEDURE TMainForm.FormCreate(Sender : TObject);
VAR
A : ATOM;
H : HWND;
S,T : STRING;
BEGIN
S:=MakeAtomName(Handle);
REPEAT
A:=FindGlobalAtom(S);
IF A=0 THEN BREAK;
T:=GetGlobalAtomName(A); H:=AtomNameToHandle(T);
IF H<>Handle THEN
IF SendMessage(H,WM_PEEK,NativeInt(A),NativeInt(H))=NativeInt(A)+NativeInt(H) THEN BREAK
UNTIL DeleteGlobalAtom(A)<>ERROR_SUCCESS;
IF A=0 THEN BEGIN
A:=AddGlobalAtom(S);
LOG('Main['+IntToHex(Handle)+'] : '+CommandLine)
END ELSE BEGIN
Running:=H; OnDestroy:=NIL; OnActivate:=BringForward;
BorderStyle:=TFormBorderStyle.bsNone;
SetBounds(-10000,-10000,10,10)
END
END;
FUNCTION TMainForm.GetGlobalAtomName(H : ATOM) : STRING;
BEGIN
SetLength(Result,255);
SetLength(Result,WinAPI.Windows.GlobalGetAtomName(H,#Result[LOW(Result)],LENGTH(Result)))
END;
PROCEDURE TMainForm.LOG(CONST S : STRING);
BEGIN
ListBox.ItemIndex:=ListBox.Items.Add(S)
END;
PROCEDURE TMainForm.PEEK(VAR MSG : TMessage);
BEGIN
MSG.Result:=NativeInt(MSG.WParam)+MSG.LParam
END;
PROCEDURE TMainForm.SendString(H : HWND ; CONST S : STRING ; E : TEncoding);
VAR
B : TBytes;
CDS : TCopyDataStruct;
BEGIN
B:=E.GetBytes(S);
CDS.dwData:=1;
CDS.cbData:=LENGTH(B);
CDS.lpData:=POINTER(B);
SendMessage(H,WM_COPYDATA,Handle,NativeInt(#CDS));
END;
end.
When you initially run the application, it'll show the command line in the ListBox. If you then run it again, it'll detect the other window already exists (using a bit-encoded Global Atom to signify the initial instance's main form Handle) and move it to the foreground (after placing its own window out-of-screen, and thus being an invisible foreground window). It'll then use WM_COPYDATA to send the new instance's command line to the initial instance, and the initial instance will then log the received command line to the listbox.
Caveats:
It's the MAIN form that is brought to front, receives and processes the command line. If you have child forms open, the behaviour is undefined (as in: I haven't tested this).
The Atom name is a 32- (or 64-) character long name, consisting of a repeated pattern of the program executable's A-Z characters. If your application doesn't have A-Z character in its name, this will fail.
To test if the Window decoded from the Global Atom is one we recognize, I call a WM_PEEK message on that window. This could lead to an unexpected message call into a foreign application, if your main instance is allowed to start (and create the Atom) and then not terminate properly (so that the Atom is deleted in FormDestroy).
I've updating Microsoft Office from version 2016 to version 2019.
After that my Delphi-Program can't open new Outlook mail window.
The program uses SimpleMapi via Winapi.Mapi to start Outlook.
The Outlook App is setted as Standard-App for sending mails.
The windows registry don't contain the MAPI-Key in the standard like before.
I've tried to add the following MAPI Keys to the windows registry, but without success.
[HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows Messaging Subsystem]
"MAPI"="1"
"MAPIX"="1"
"OLEMessaging"="1"
"CMC"="1"
"MAPIXVER"="1.0.0.1"
"CMCDLLNAME32"="mapi32.dll"
The reason why I have tried this, is that Winapi.Mapi search in the HKLM\Software\Microsoft\Windows Messaging Subsystem for the MAPI keys to load the MAPI32.dll of the setted standard mail application.
The MAPI is allegedly not available if the Winapi.Mapi tried to load it.
A remark: The "mailto"-functionality works fine.
So my program works fine with the older versions of Microsoft Office like 2016 and earlier, but not with the version 2019.
The Question is: what is the reason for the failure? is the registry configuration a reason for that or maybe the obsolated Embarcadero lib?
I hope the problem description was clear enough.
Hope you can help me.
unit uAutomationSendMessage;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls;
function SendMessageViaOLE(Subject : WideString;
Body : WideString;
UseHtml : Boolean = False;
ShowModal : Boolean = True;
Recipients : TStringList = nil;
AttachList : TStringList = nil) : Integer;
function AutomationSendMessage(Subject : WideString;
Body : WideString;
UseHtml : Boolean = False;
ShowModal : Boolean = True;
recipients : TStringList = nil;
AttachList : TStringList = nil) : Integer; OverLoad;
function AutomationSendMessage(Subject : WideString;
Body : WideString;
UseHtml : Boolean = False;
ShowModal : Boolean = True;
recipients : String = '';
AttachFile : String = '') : Integer; OverLoad;
implementation
uses
OutlookSecMan,
Outlook2010,
ComObj,
ole;
procedure SleepForXXXMiliSecend(MiliSecunda : Integer);
Var
CurTime : Integer;
UntilMax : Integer;
begin
UntilMax := Trunc(MiliSecunda / 10);
if UntilMax < 5 then
UntilMax := 5;
For CurTime := 0 to UntilMax Do
begin
Sleep(05); {10 cose it work more then excepted}
Application.ProcessMessages;
end;
end;
function SendMessageViaOLE(Subject : WideString;
Body : WideString;
UseHtml : Boolean = False;
ShowModal : Boolean = True;
Recipients : TStringList = nil;
AttachList : TStringList = nil) : Integer;
const
olMailItem = 0;
var
OlSecurityManager: TOlSecurityManager;
CurItem : Integer;
Outlook : OLEVariant;
MailItem : Variant;
OLCreated : Boolean;
begin
Try
OlSecurityManager:= TOlSecurityManager.Create(Application);
OLCreated := False;
try
Outlook := GetActiveOleObject('Outlook.Application') ;
except
Outlook := CreateOleObject('Outlook.Application') ;
OLCreated := True;
end;
SleepForXXXMiliSecend(100);
MailItem := Outlook.CreateItem(olMailItem) ;
SleepForXXXMiliSecend(100);
//MailItem.Recipients.Add('johndoe#hotmail.com') ;
MailItem.Subject := Subject;
if UseHtml then
MailItem.HTMLBody := Body
else
MailItem.Body := Body;
if Assigned(Recipients) then
begin
for CurItem := 0 to Recipients.Count - 1 do
if Trim(Recipients.Strings[CurItem]) <> '' then
MailItem.Recipients.Add(Recipients.Strings[CurItem]);
end;
if Assigned(AttachList) then
begin
for CurItem := 0 to AttachList.Count - 1 do
if Trim(AttachList.Strings[CurItem]) <> '' then
MailItem.Attachments.Add(AttachList.Strings[CurItem]);
end;
MailItem.Display(False); //True=Send Immedeate
SleepForXXXMiliSecend(100);
If OLCreated Then
VarClear(Outlook);
Finally
OlSecurityManager.DisableOOMWarnings := False;
End;
end;
function AutomationSendMessage(Subject : WideString;
Body : WideString;
UseHtml : Boolean = False;
ShowModal : Boolean = True;
Recipients : TStringList = nil;
AttachList : TStringList = nil) : Integer;
const
olMailItem = 0;
olByValue = 1;
Var
CurTest : Integer;
CurItem : Integer;
//Outlook : OleVariant;
Outlook: Outlook2010.TOutlookApplication;
OlSecurityManager: TOlSecurityManager;
vMailItem : variant;
mRecipient, mSubject, mBody, mAttachement: String;
Begin
Result := -99;
Try
OlSecurityManager:= TOlSecurityManager.Create(Application);
//Try
// Outlook := GetActiveOleObject('Outlook.Application');
//Except;
// Outlook := CreateOleObject('Outlook.Application');
//End;
Outlook := TOutlookApplication.Create(nil);
OlSecurityManager.ConnectTo(Outlook.Application);
OlSecurityManager.DisableOOMWarnings := True;
vMailItem := Outlook.CreateItem(olMailItem);
SleepForXXXMiliSecend(20); // avoid Call was rejected by callee.
//vMailItem.Recipients.Add('test#hanibaal.co.il');
For CurTest := 0 To 10 Do
begin
Try
vMailItem.Subject := Subject;
Break;
Except;
// wait somw more for prevent - Call was rejected by callee.
SleepForXXXMiliSecend(20); // avoid Call was rejected by callee.
End;
end;
if UseHtml then
vMailItem.HTMLBody := Body
else
vMailItem.Body := Body;
//MailItem.Recipients.Add('someone#yahoo.com'); // Type=1 olTo
//MailItem.Recipients.Add('joesmoe#yahoo.com').Type := 2; // olCC
//MailItem.Recipients.Add('alice#yahoo.com').Type := 3; // olBCC
if Assigned(Recipients) then
begin
for CurItem := 0 to Recipients.Count - 1 do
if Trim(Recipients.Strings[CurItem]) <> '' then
vMailItem.Recipients.Add(Recipients.Strings[CurItem]);
end;
if Assigned(AttachList) then
begin
for CurItem := 0 to AttachList.Count - 1 do
if Trim(AttachList.Strings[CurItem]) <> '' then
vMailItem.Attachments.Add(AttachList.Strings[CurItem]);
end;
Try
IF ShowModal Then
begin
IF vMailItem.display(True) Then
begin
Result := 0 {Message sent}
end;
end
else
begin
//vMailItem.Send;
IF vMailItem.display(False) Then
begin
Result := 0 {Message sent}
end;
end;
Except
on e : System.SysUtils.Exception do
begin
Result := 1; {Message not sent}
ShowMessage('Sending mail fail - ' + e.Message);
end;
End;
Finally
OlSecurityManager.DisableOOMWarnings := False;
Try OlSecurityManager.Free; Except; End;
VarClear(vMailItem);
Outlook := nil;
end;
end;
function AutomationSendMessage(Subject : WideString;
Body : WideString;
UseHtml : Boolean = False;
ShowModal : Boolean = True;
recipients : String = '';
AttachFile : String = '') : Integer;
Var
recipientsList : TStringList;
AttachListList : TStringList;
begin
recipientsList := TStringList.Create;
AttachListList := TStringList.Create;
Try
recipientsList.Add(recipients);
AttachListList.Add(AttachFile);
result := AutomationSendMessage(Subject,
Body,
UseHtml,
ShowModal,
recipientsList,
AttachListList);
Finally
recipientsList.Free;
AttachListList.Free;
End;
end;
end.
Just came a cropper with this issue under windows 10/office 365
Add MAPI string value of '1' to this Key instead.
Computer\HKEY_LOCAL_MACHINE\SOFTWARE\WOW6432Node\Microsoft\Windows Messaging Subsystem
restart application and should be back in business.
How do I get a list of the running processes (with details of PID, Owner etc) on my machine using Delphi?
EDIT: None of the solutions proposed gives me the user that owns the process, only info such as PID, ExeName etc...
One way is using the Tool Help library (see TlHelp32 unit), or EnumProcesses on Windows NT (see PsAPI unit). Have a look at JclSysInfo.RunningProcessesList in the JCL for an example.
Here's a quick example of how to get the user name of a process:
type
PTokenUser = ^TTokenUser;
TTokenUser = packed record
User: SID_AND_ATTRIBUTES;
end;
function GetProcessUserName(ProcessID: Cardinal; out DomainName, UserName: string): Boolean;
var
ProcessHandle, ProcessToken: THandle;
InfoSize, UserNameSize, DomainNameSize: Cardinal;
User: PTokenUser;
Use: SID_NAME_USE;
_DomainName, _UserName: array[0..255] of Char;
begin
Result := False;
DomainName := '';
UserName := '';
ProcessHandle := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, False, ProcessID);
if ProcessHandle = 0 then
Exit;
try
if not OpenProcessToken(ProcessHandle, TOKEN_QUERY, ProcessToken) then
Exit;
try
GetTokenInformation(ProcessToken, TokenUser, nil, 0, InfoSize);
User := AllocMem(InfoSize * 2);
try
if GetTokenInformation(ProcessToken, TokenUser, User, InfoSize * 2, InfoSize) then
begin
DomainNameSize := SizeOf(_DomainName);
UserNameSize := SizeOf(_UserName);
Result := LookupAccountSid(nil, User^.User.Sid, _UserName, UserNameSize, _DomainName, DomainNameSize, Use);
if Result then
begin
SetString(DomainName, _DomainName, StrLen(_DomainName));
SetString(UserName, _UserName, StrLen(_UserName));
end;
end;
finally
FreeMem(User);
end;
finally
CloseHandle(ProcessToken);
end;
finally
CloseHandle(ProcessHandle);
end;
end;
This is the function we use to check if a process exists, the FProcessEntry32 holds all the info on the process, so you should be able to extend it to what every you need.
it was taken from here
uses TlHelp32
function processExists(exeFileName: string): Boolean;
{description checks if the process is running
URL: http://www.swissdelphicenter.ch/torry/showcode.php?id=2554}
var
ContinueLoop: BOOL;
FSnapshotHandle: THandle;
FProcessEntry32: TProcessEntry32;
begin
FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
FProcessEntry32.dwSize := SizeOf(FProcessEntry32);
ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32);
Result := False;
while Integer(ContinueLoop) <> 0 do
begin
if ((UpperCase(ExtractFileName(FProcessEntry32.szExeFile)) =
UpperCase(ExeFileName)) or (UpperCase(FProcessEntry32.szExeFile) =
UpperCase(ExeFileName))) then
begin
Result := True;
end;
ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32);
end;
CloseHandle(FSnapshotHandle);
end;
The TProcessEntry32 record looks like so:
tagPROCESSENTRY32 = packed record
dwSize: DWORD;
cntUsage: DWORD;
th32ProcessID: DWORD; // this process
th32DefaultHeapID: DWORD;
th32ModuleID: DWORD; // associated exe
cntThreads: DWORD;
th32ParentProcessID: DWORD; // this process's parent process
pcPriClassBase: Longint; // Base priority of process's threads
dwFlags: DWORD;
szExeFile: array[0..MAX_PATH - 1] of Char;// Path
end;
You have to use:
CreateToolhelp32Snapshot Function
Process32First Function
Process32Next Function
PROCESSENTRY32 Structure will contain all the informations that you may need.
The documentation is from MDSN, for C++, but it's the same in Delphi.
This class will give you a list of all open windows (listed below) with PID, caption, dimensions, etc. It's not exactly running processes information, but I've used it to find apps via it.
// Window List Component 1.5 by Jerry Ryle
//
// Aaugh! I accidentally uploaded the wrong source
// which had a nasty bug in the refresh procedure!
// Thanks to Serge, who found my mistake and suggested
// a few other improvements!
//
// This component will enumerate windows and return
// information about them in the Windows property.
// The component currently returns a handle, caption text,
// associated ProcessID, visibility, and dimensions.
// For documentation, please read the accompanying
// WindowList.txt
//
// This component is completely free of course. If you find
// it useful, and are compelled to send me cash, beer, or
// dead things in envelopes, please feel free to do so.
//
// email me if you make it better: gryle#calpoly.edu
unit WindowList;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
type
TWindowObject = record
WinHandle : HWnd; // Window Handle
WinCaption : String; // Window Caption Text (If any)
ProcessID : Integer; // Process the window belongs to
IsVisible : Boolean; // Is the window visible?
IsEnabled : Boolean; // Is the window enabled for mouse/keyboard input?
IsIconic : Boolean; // Is the window minimized?
WindowRect : TRect; // Window Dimensions
// Add more properties here if you like,
// then fill them in at the WindowCallback
// function.
end;
PTWindowObject = ^TWindowObject;
TWindowList = class(TComponent)
private
WindowLst : TList;
FCount : Integer;
protected
Function GetAWindow(Index : Integer) : TWindowObject;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
Procedure Refresh;
Property Windows[Index : Integer]: TWindowObject read GetAWindow;
Property Count : Integer read FCount;
published
// Published declarations
end;
procedure Register;
implementation
// Note that this function is not a member of WindowList.
// Therefore, the list to be filled needs to be passed
// as a pointer. Note that this is passed as a VAR. if you
// don't do this, bad things happen in memory.
Function WindowCallback(WHandle : HWnd; Var Parm : Pointer) : Boolean; stdcall;
// This function is called once for each window
Var MyString : PChar;
MyInt : Integer;
MyWindowPtr : ^TWindowObject;
begin
New(MyWindowPtr);
// Window Handle (Passed by the enumeration)
MyWindowPtr.WinHandle := WHandle;
// Window text
MyString := Allocmem(255);
GetWindowText(WHandle,MyString,255);
MyWindowPtr.WinCaption := String(MyString);
FreeMem(MyString,255);
// Process ID
MyInt := 0;
MyWindowPtr.ProcessID := GetWindowThreadProcessId(WHandle,#MyInt);
// Visiblity
MyWindowPtr.IsVisible := IsWindowVisible(WHandle);
// Enabled
MyWindowPtr.IsEnabled := IsWindowEnabled(WHandle);
// Iconic
MyWindowPtr.IsIconic := IsIconic(WHandle);
// Window Dimensions
MyWindowPtr.WindowRect := Rect(0,0,0,0);
GetWindowRect(WHandle,MyWindowPtr.WindowRect);
// Add the structure to the list. Do not dereference Parm...
// once again, bad things happen.
TList(Parm).Add(MyWindowPtr);
Result := True; // Everything's okay. Continue to enumerate windows
end;
constructor TWindowList.Create(AOwner: TComponent);
var MyWindowPtr : PTWindowObject;
begin
inherited;
WindowLst := TList.Create;
// Thanks Serge, I should've done this from the start :)
// Sloppy me.
If Not ( csDesigning in ComponentState ) Then
Begin
EnumWindows(#WindowCallback,Longint(#WindowLst));
FCount := WindowLst.Count;
End
Else
FCount := 0;
end;
destructor TWindowList.Destroy;
var I : Integer;
begin
If WindowLst.Count > 0 Then
Begin
For I := 0 To (WindowLst.Count - 1) Do
Dispose(PTWindowObject(WindowLst[I]));
End;
WindowLst.Free;
inherited;
end;
procedure TWindowList.Refresh;
begin
WindowLst.Clear; {Clear the list!}
EnumWindows(#WindowCallback,Longint(#WindowLst));
FCount := WindowLst.Count;
end;
function TWindowList.GetAWindow(Index : Integer) : TWindowObject;
begin
Result := PTWindowObject(WindowLst[Index])^;
end;
procedure Register;
begin
RegisterComponents('System', [TWindowList]);
end;
end.
You could look at using the WMISet components ($69 single licence, $199 for site licence, trial version available). The TWmiProcessControl component seems to encapsulate calls to Win32_Process. They also have an example of getting a process owner.
I think Madshi madKernel could be interesting to check out.
We need to validate an user on Microsoft's Active Directory using Delphi 7, what is the best way to do that?
We can have two scenarios: the user inputs its network username and password, where the username may include the domain, and we check on active directory if it is a valid, active user. Or we get the current logged user from Windows, and check on AD if it is still valid.
The first scenario requires user validation, while the second one just a simple AD search and locate.
Does anyone know of components or code that do one or both of the scenarios described above?
Here's a unit we wrote and use. Simple and gets the job done.
unit ADSI;
interface
uses
SysUtils, Classes, ActiveX, Windows, ComCtrls, ExtCtrls, ActiveDs_TLB,
adshlp, oleserver, Variants;
type
TPassword = record
Expired: boolean;
NeverExpires: boolean;
CannotChange: boolean;
end;
type
TADSIUserInfo = record
UID: string;
UserName: string;
Description: string;
Password: TPassword;
Disabled: boolean;
LockedOut: boolean;
Groups: string; //CSV
end;
type
TADSI = class(TComponent)
private
FUserName: string;
FPassword: string;
FCurrentUser: string;
FCurrentDomain: string;
function GetCurrentUserName: string;
function GetCurrentDomain: string;
protected
{ Protected declarations }
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property CurrentUserName: string read FCurrentUser;
property CurrentDomain: string read FCurrentDomain;
function GetUser(Domain, UserName: string; var ADSIUser: TADSIUserInfo): boolean;
function Authenticate(Domain, UserName, Group: string): boolean;
published
property LoginUserName: string read FUserName write FUserName;
property LoginPassword: string read FPassword write FPassword;
end;
procedure Register;
implementation
function ContainsValComma(s1,s: string): boolean;
var
sub,str: string;
begin
Result:=false;
if (s='') or (s1='') then exit;
if SameText(s1,s) then begin
Result:=true;
exit;
end;
sub:=','+lowercase(trim(s1))+','; str:=','+lowercase(trim(s))+',';
Result:=(pos(sub, str)>0);
end;
procedure Register;
begin
RegisterComponents('ADSI', [TADSI]);
end;
constructor TADSI.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FCurrentUser:=GetCurrentUserName;
FCurrentDomain:=GetCurrentDomain;
FUserName:='';
FPassword:='';
end;
destructor TADSI.Destroy;
begin
inherited Destroy;
end;
function TADSI.GetCurrentUserName : string;
const
cnMaxUserNameLen = 254;
var
sUserName : string;
dwUserNameLen : DWord;
begin
dwUserNameLen := cnMaxUserNameLen-1;
SetLength(sUserName, cnMaxUserNameLen );
GetUserName(PChar(sUserName), dwUserNameLen );
SetLength(sUserName, dwUserNameLen);
Result := sUserName;
end;
function TADSI.GetCurrentDomain: string;
const
DNLEN = 255;
var
sid : PSID;
sidSize : DWORD;
sidNameUse : DWORD;
domainNameSize : DWORD;
domainName : array[0..DNLEN] of char;
begin
sidSize := 65536;
GetMem(sid, sidSize);
domainNameSize := DNLEN + 1;
sidNameUse := SidTypeUser;
try
if LookupAccountName(nil, PChar(FCurrentUser), sid, sidSize,
domainName, domainNameSize, sidNameUse) then
Result:=StrPas(domainName);
finally
FreeMem(sid);
end;
end;
function TADSI.Authenticate(Domain, UserName, Group: string): boolean;
var
aUser: TADSIUserInfo;
begin
Result:=false;
if GetUser(Domain,UserName,aUser) then begin
if not aUser.Disabled and not aUser.LockedOut then begin
if Group='' then
Result:=true
else
Result:=ContainsValComma(Group, aUser.Groups);
end;
end;
end;
function TADSI.GetUser(Domain, UserName: string; var ADSIUser: TADSIUserInfo): boolean;
var
usr : IAdsUser;
flags : integer;
Enum : IEnumVariant;
grps : IAdsMembers;
grp : IAdsGroup;
varGroup : OleVariant;
Temp : LongWord;
dom1, uid1: string;
//ui: TADSIUserInfo;
begin
ADSIUser.UID:='';
ADSIUser.UserName:='';
ADSIUser.Description:='';
ADSIUser.Disabled:=true;
ADSIUser.LockedOut:=true;
ADSIUser.Groups:='';
Result:=false;
if UserName='' then
uid1:=FCurrentUser
else
uid1:=UserName;
if Domain='' then
dom1:=FCurrentDomain
else
dom1:=Domain;
if uid1='' then exit;
if dom1='' then exit;
try
if trim(FUserName)<>'' then
ADsOpenObject('WinNT://' + dom1 + '/' + uid1, FUserName, FPassword, 1, IADsUser, usr)
else
ADsGetObject('WinNT://' + dom1 + '/' + uid1, IADsUser, usr);
if usr=nil then exit;
ADSIUser.UID:= UserName;
ADSIUser.UserName := usr.FullName;
ADSIUser.Description := usr.Description;
flags := usr.Get('userFlags');
ADSIUser.Password.Expired := usr.Get('PasswordExpired');
ADSIUser.Password.CannotChange := (flags AND ADS_UF_PASSWD_CANT_CHANGE)<>0;
ADSIUser.Password.NeverExpires := (flags and ADS_UF_DONT_EXPIRE_PASSWD)<>0;
ADSIUser.Disabled := usr.AccountDisabled;
ADSIUser.LockedOut := usr.IsAccountLocked;
ADSIUser.Groups:='';
grps := usr.Groups;
Enum := grps._NewEnum as IEnumVariant;
if Enum <> nil then begin
while (Enum.Next(1,varGroup, Temp) = S_OK) do begin
grp := IDispatch(varGroup) as IAdsGroup;
//sGroupType := GetGroupType(grp);
if ADSIUser.Groups<>'' then ADSIUser.Groups:=ADSIUser.Groups+',';
ADSIUser.Groups:=ADSIUser.Groups+grp.Name;
VariantClear(varGroup);
end;
end;
usr:=nil;
Result:=true;
except
on e: exception do begin
Result:=false;
exit;
end;
end;
end;
end.
I'm flattered to see my ADSISearch component mentioned here :-), but in order to simply validate user credentials, you're probably even better off using the "LogonUser" Win32 API. I'm pretty sure (not doing any Delphi work anymore myself) that there's an implementation of that floating around somewhere - probably in the JVCL library or somewhere else.
I've always used the 'ADSISearch.pas' unit for working with AD, with great success. Also, here is some code I used (that uses this unit) to retrieve a user's HOMEDRIVE info from their AD object:
try
ADSISearch1.Filter := WideString('samaccountname=' + GetUserFromWindows());
try
ADSISearch1.Search;
slTemp := ADSISearch1.GetFirstRow();
except
//uh-oh, this is a problem, get out of here
// --- must not have been able to talk to AD
// --- could be the user recently changed pwd and is logged in with
// their cached credentials
// just suppress this exception
bHomeDriveMappingFailed := True;
Result := bSuccess;
Exit;
end;
while (slTemp <> nil) do
begin
for ix := 0 to slTemp.Count - 1 do
begin
curLine := AnsiUpperCase(slTemp[ix]);
if AnsiStartsStr('HOMEDIRECTORY', curLine) then
begin
sADHomeDriveUncPath := AnsiReplaceStr(curLine, 'HOMEDIRECTORY=', '');
//sADHomeDriveUncPath := slTemp[ix];
end
else if AnsiStartsStr('HOMEDRIVE', curLine) then
begin
sADHomeDriveLetter := AnsiReplaceStr(curLine, 'HOMEDRIVE=', '');
//sADHomeDriveLetter := slTemp[ix];
end;
end;
FreeAndNil(slTemp);
slTemp := ADSISearch1.GetNextRow();
end;
except
//suppress this exception
bHomeDriveMappingFailed := True;
Exit;
end;
And without further delay, here is the unit (not written by me):
(* ----------------------------------------------------------------------------
Module: ADSI Searching in Delphi
Author: Marc Scheuner
Date: July 17, 2000
Changes:
Description:
constructor Create(aOwner : TComponent); override;
Creates a new instance of component
destructor Destroy; override;
Frees instance of component
function CheckIfExists() : Boolean;
Checks to see if the object described in the properties exists or not
TRUE: Object exists, FALSE: object does not exist
procedure Search;
Launches the ADSI search - use GetFirstRow and GetNextRow to retrieve information
function GetFirstRow() : TWideStringList;
function GetNextRow() : TWideStringList;
Returns the first row / next row of the result set, as a WideStringList.
The values are stored in the string list as a <name>=<value> pair, so you
can access the values via the FWideStringList.Values['name'] construct.
Multivalued attributes are returned as one per line, in an array index
manner:
objectClass[0]=top
objectClass[1]=Person
objectClass[2]=organizationalPerson
objectClass[3]=user
and so forth. The index is zero-based.
If there are no (more) rows, the return value will be NIL.
It's up to the receiver to free the string list when no longer needed.
property Attributes : WideString
Defines the attributes you want to retrieve from the object. If you leave
this empty, all available attributes will be returned.
You can specify multiple attributes separated by comma:
cn,distinguishedName,name,ADsPath
will therefore retrieve these four attributes for all the objects returned
in the search (if the attributes exist).
property BaseIADs : IADs
If you already have an interface to an IADs object, you can reuse it here
by setting it to the BaseIADs property - in this case, ADSISearch can skip
the step of binding to the ADSI object and will be executing faster.
property BasePath : WideString
LDAP base path for the search - the further down in the LDAP tree you start
searching, the smaller the namespace to search and the quicker the search
will return what you're looking for.
LDAP://cn=Users,dc=stmaarten,dc=qc,dc=rnd
is the well-known LDAP path for the Users container in the stmaarten.qc.rnd
domain.
property ChaseReferrals : Boolean
If set to TRUE, the search might need to connect to other domain controllers
and naming contexts, which is very time consuming.
Set this property to FALSE to limit it to the current naming context, thus
speeding up searches significantly.
property DirSrchIntf : IDirectorySearch
Provides access to the basic Directory Search interface, in case you need
to do some low-level tweaking
property Filter : WideString
LDAP filter expression to search for. It will be ANDed together with a
(objectClass=<ObjectClass>) filter to form the full search filter.
It can be anything that is a valid LDAP search filter - see the appropriate
books or online help files for details.
It can be (among many other things):
cn=Marc*
badPwdCount>=0
countryCode=49
givenName=Steve
and multiple conditions can be ANDed or ORed together using the LDAP syntax.
property MaxRows : Integer
Maximum rows of the result set you want to retrieve.
Default is 0 which means all rows.
property PageSize : Integer
Maximum number of elements to be returned in a paged search. If you set this to 0,
the search will *not* be "paged", e.g. IDirectorySearch will return all elements
found in one big gulp, but there's a limit at 1'000 elements.
With paged searching, you can search and find any number of AD objects. Default is
set to 100 elements. No special need on the side of the developer / user to use
paged searches - just set the PageSize to something non-zero.
property ObjectClass: WideString
ObjectClass of the ADSI object you are searching for. This allows you to
specify e.g. just users, only computers etc.
Be aware that ObjectClass is a multivalued attribute in LDAP, and sometimes
has unexpected hierarchies (e.g."computer" descends from "user" and will therefore
show up if you search for object class "user").
This property will be included in the LDAP search filter passed to the
search engine. If you don't want to limit the objects returned, just leave
it at the default value of *
property SearchScope
Limits the scope of the search.
scBase: search only the base object (as specified by the LDAP path) - not very
useful.....
scOneLevel: search only object immediately contained by the specified base
object (does not include baes object) - limits the depth of
the search
scSubtree: no limit on how "deep" the search goes, below the specified
base object - this is the default.
---------------------------------------------------------------------------- *)
unit ADSISearch;
interface
uses
ActiveX,
ActiveDs_TLB,
Classes,
SysUtils
{$IFDEF UNICODE}
,Unicode
{$ENDIF}
;
type
EADSISearchException = class(Exception);
TSearchScope = (scBase, scOneLevel, scSubtree);
TADSISearch = class(TComponent)
private
FBaseIADs : IADs;
FDirSrchIntf : IDirectorySearch;
FSearchHandle : ADS_SEARCH_HANDLE;
FAttributes,
FFilter,
FBasePath,
FObjectClass : Widestring;
FResult : HRESULT;
FChaseReferrals,
FSearchExecuted : Boolean;
FMaxRows,
FPageSize : Integer;
FSearchScope : TSearchScope;
FUsername: Widestring;
FPassword: Widestring;
{$IFDEF UNICODE}
procedure EnumerateColumns(aStrList : TWideStringList);
{$ELSE}
procedure EnumerateColumns(aStrList : TStringList);
{$ENDIF}
function GetStringValue(oSrchColumn : ads_search_column; Index : Integer) : WideString;
procedure SetBaseIADs(const Value: IADs);
procedure SetBasePath(const Value: WideString);
procedure SetFilter(const Value: WideString);
procedure SetObjectClass(const Value: Widestring);
procedure SetMaxRows(const Value: Integer);
procedure SetPageSize(const Value: Integer);
procedure SetAttributes(const Value: WideString);
procedure SetChaseReferrals(const Value: Boolean);
procedure SetUsername(const Value: WideString);
procedure SetPassword(const Value: WideString);
public
constructor Create(aOwner : TComponent); override;
destructor Destroy; override;
function CheckIfExists() : Boolean;
procedure Search;
{$IFDEF UNICODE}
function GetFirstRow() : TWideStringList;
function GetNextRow() : TWideStringList;
{$ELSE}
function GetFirstRow() : TStringList;
function GetNextRow() : TStringList;
{$ENDIF}
published
// list of attributes to return - empty string equals all attributes
property Attributes : WideString read FAttributes write SetAttributes;
// search base - both as an IADs interface, as well as a LDAP path
property BaseIADs : IADs read FBaseIADs write SetBaseIADs stored False;
property BasePath : WideString read FBasePath write SetBasePath;
// chase possible referrals to other domain controllers?
property ChaseReferrals : Boolean read FChaseReferrals write SetChaseReferrals default False;
// "raw" search interface - for any low-level tweaking necessary
property DirSrchIntf : IDirectorySearch read FDirSrchIntf;
// LDAP filter to limit the search
property Filter : WideString read FFilter write SetFilter;
// maximum number of rows to return - 0 = all rows (no limit)
property MaxRows : Integer read FMaxRows write SetMaxRows default 0;
property ObjectClass : Widestring read FObjectClass write SetObjectClass;
property PageSize : Integer read FPageSize write SetPageSize default 100;
property SearchScope : TSearchScope read FSearchScope write FSearchScope default scSubtree;
property Username : Widestring read FUsername write SetUsername;
property Password : Widestring read FPassword write SetPassword;
end;
const
// ADSI success codes
S_ADS_ERRORSOCCURRED = $00005011;
S_ADS_NOMORE_ROWS = $00005012;
S_ADS_NOMORE_COLUMNS = $00005013;
// ADSI error codes
E_ADS_BAD_PATHNAME = $80005000;
E_ADS_INVALID_DOMAIN_OBJECT = $80005001;
E_ADS_INVALID_USER_OBJECT = $80005002;
E_ADS_INVALID_COMPUTER_OBJECT = $80005003;
E_ADS_UNKNOWN_OBJECT = $80005004;
E_ADS_PROPERTY_NOT_SET = $80005005;
E_ADS_PROPERTY_NOT_SUPPORTED = $80005006;
E_ADS_PROPERTY_INVALID = $80005007;
E_ADS_BAD_PARAMETER = $80005008;
E_ADS_OBJECT_UNBOUND = $80005009;
E_ADS_PROPERTY_NOT_MODIFIED = $8000500A;
E_ADS_PROPERTY_MODIFIED = $8000500B;
E_ADS_CANT_CONVERT_DATATYPE = $8000500C;
E_ADS_PROPERTY_NOT_FOUND = $8000500D;
E_ADS_OBJECT_EXISTS = $8000500E;
E_ADS_SCHEMA_VIOLATION = $8000500F;
E_ADS_COLUMN_NOT_SET = $80005010;
E_ADS_INVALID_FILTER = $80005014;
procedure Register;
(*============================================================================*)
(* IMPLEMENTATION *)
(*============================================================================*)
implementation
uses
Windows;
var
ActiveDSHandle : THandle;
gADsGetObject: function(pwcPathName: PWideChar; const xRIID: TGUID; out pVoid): HResult; stdcall;
gFreeADsMem : function(aPtr : Pointer) : BOOL; stdcall;
// Active Directory API helper functions - implemented in ActiveDs.DLL and
// dynamically loaded at time of initialization of this module
function ADsGetObject(pwcPathName: PWideChar; const xRIID: TGUID; var pVoid): HResult;
begin
Result := gADsGetObject(pwcPathName, xRIID, pVoid);
end;
function FreeADsMem(aPtr : Pointer) : BOOL;
begin
Result := gFreeADsMem(aPtr);
end;
// resource strings for all messages - makes localization so much easier!
resourcestring
rc_CannotLoadActiveDS = 'Cannot load ActiveDS.DLL';
rc_CannotGetProcAddress = 'Cannot GetProcAddress of ';
rc_CouldNotBind = 'Could not bind to object %s (%x)';
rc_CouldNotFreeSH = 'Could not free search handle (%x)';
rc_CouldNotGetIDS = 'Could not obtain IDirectorySearch interface for %s (%x)';
rc_GetFirstFailed = 'GetFirstRow failed (%x)';
rc_GetNextFailed = 'GetNextRow failed (%x)';
rc_SearchFailed = 'Search in ADSI failed (result code %x)';
rc_SearchNotExec = 'Search has not been executed yet';
rc_SetSrchPrefFailed = 'Setting the max row limit failed (%x)';
rc_UnknownDataType = '(unknown data type %d)';
// ---------------------------------------------------------------------------
// Constructor and destructor
// ---------------------------------------------------------------------------
constructor TADSISearch.Create(aOwner : TComponent);
begin
inherited Create(aOwner);
FBaseIADs := nil;
FDirSrchIntf := nil;
FAttributes := '';
FBasePath := '';
FFilter := '';
FObjectClass := '*';
FMaxRows := 0;
FPageSize := 100;
FChaseReferrals := False;
FSearchScope := scSubtree;
FSearchExecuted := False;
end;
destructor TADSISearch.Destroy;
begin
if (FSearchHandle <> 0) then
FResult := FDirSrchIntf.CloseSearchHandle(FSearchHandle);
FBaseIADs := nil;
FDirSrchIntf := nil;
inherited;
end;
// ---------------------------------------------------------------------------
// Set and Get methods
// ---------------------------------------------------------------------------
procedure TADSISearch.SetPassword(const Value: WideString);
begin
if (FPassword <> Value) then
begin
FPassword := Value;
end;
end;
procedure TADSISearch.SetUsername(const Value: WideString);
begin
if (FUsername <> Value) then
begin
FUsername := Value;
end;
end;
procedure TADSISearch.SetAttributes(const Value: WideString);
begin
if (FAttributes <> Value) then begin
FAttributes := Value;
end;
end;
// the methods to set the search base always need to update the other property
// as well, in order to make sure the base IADs interface and the BasePath
// property stay in sync
// setting the search base will require a new search
// therefore set internal flag FSearchExecuted to false
procedure TADSISearch.SetBaseIADs(const Value: IADs);
begin
if (FBaseIADs <> Value) then begin
FBaseIADs := Value;
FBasePath := FBaseIADs.ADsPath;
FSearchExecuted := False;
end;
end;
procedure TADSISearch.SetBasePath(const Value: WideString);
begin
if (FBasePath <> Value) then begin
FBasePath := Value;
FBaseIADs := nil;
FSearchExecuted := False;
end;
end;
procedure TADSISearch.SetChaseReferrals(const Value: Boolean);
begin
if (FChaseReferrals <> Value) then begin
FChaseReferrals := Value;
end;
end;
// setting the filter will require a new search
// therefore set internal flag FSearchExecuted to false
procedure TADSISearch.SetFilter(const Value: WideString);
begin
if (FFilter <> Value) then begin
FFilter := Value;
FSearchExecuted := False;
end;
end;
procedure TADSISearch.SetMaxRows(const Value: Integer);
begin
if (Value >= 0) and (Value <> FMaxRows) then begin
FMaxRows := Value;
end;
end;
procedure TADSISearch.SetPageSize(const Value: Integer);
begin
if (Value >= 0) and (Value <> FPageSize) then begin
FPageSize := Value;
end;
end;
// setting the object category will require a new search
// therefore set internal flag FSearchExecuted to false
procedure TADSISearch.SetObjectClass(const Value: Widestring);
begin
if (FObjectClass <> Value) then begin
if (Value = '') then
FObjectClass := '*'
else
FObjectClass := Value;
FSearchExecuted := False;
end;
end;
// ---------------------------------------------------------------------------
// Private helper methods
// ---------------------------------------------------------------------------
// EnumerateColumns iterates through all the columns in the current row of
// the search results and builds the string list of results
{$IFDEF UNICODE}
procedure TADSISearch.EnumerateColumns(aStrList: TWideStringList);
{$ELSE}
procedure TADSISearch.EnumerateColumns(aStrList: TStringList);
{$ENDIF}
var
ix : Integer;
bMultiple : Boolean;
pwColName : PWideChar;
oSrchColumn : ads_search_column;
wsColName, wsValue : WideString;
begin
// determine name of next column to fetch
FResult := FDirSrchIntf.GetNextColumnName(FSearchHandle, pwColName);
// as long as no error occured and we still do have columns....
while Succeeded(FResult) and (FResult <> S_ADS_NOMORE_COLUMNS) do begin
// get the column from the result set
FResult := FDirSrchIntf.GetColumn(FSearchHandle, pwColName, oSrchColumn);
if Succeeded(FResult) then begin
// check if it's a multi-valued attribute
bMultiple := (oSrchColumn.dwNumValues > 1);
if bMultiple then begin
// if it's a multi-valued attribute, iterate through the values
for ix := 0 to oSrchColumn.dwNumValues-1 do begin
wsColName := Format('%s[%d]', [oSrchColumn.pszAttrName, ix]);
wsValue := GetStringValue(oSrchColumn, ix);
aStrList.Add(wsColName + '=' + wsValue);
end;
end
else begin
// single valued attributes are quite straightforward
wsColName := oSrchColumn.pszAttrName;
wsValue := GetStringValue(oSrchColumn, 0);
aStrList.Add(wsColName + '=' + wsValue);
end;
end;
// free the memory associated with the search column, and the column name
FDirSrchIntf.FreeColumn(oSrchColumn);
FreeADsMem(pwColName);
// get next column name
FResult := FDirSrchIntf.GetNextColumnName(FSearchHandle, pwColName);
end;
end;
// Get string value will turn the supported types of data into a string representation
// for inclusion in the resulting string list
// For a complete list of possible values, see the ADSTYPE_xxx constants in the
// ActiveDs_TLB.pas file
function TADSISearch.GetStringValue(oSrchColumn: ads_search_column; Index: Integer): WideString;
var
wrkPointer : PADSValue;
oSysTime : _SYSTEMTIME;
dtDate,
dtTime : TDateTime;
begin
Result := '';
// advance the value pointer to the correct one of the potentially multiple
// values in the "array of values" for this attribute
wrkPointer := oSrchColumn.pADsValues;
Inc(wrkPointer, Index);
// depending on the type of the value, turning it into a string is more
// or less straightforward
case oSrchColumn.dwADsType of
ADSTYPE_CASE_EXACT_STRING : Result := wrkPointer^.__MIDL_0010.CaseExactString;
ADSTYPE_CASE_IGNORE_STRING : Result := wrkPointer^.__MIDL_0010.CaseIgnoreString;
ADSTYPE_DN_STRING : Result := wrkPointer^.__MIDL_0010.DNString;
ADSTYPE_OBJECT_CLASS : Result := wrkPointer^.__MIDL_0010.ClassName;
ADSTYPE_PRINTABLE_STRING : Result := wrkPointer^.__MIDL_0010.PrintableString;
ADSTYPE_NUMERIC_STRING : Result := wrkPointer^.__MIDL_0010.NumericString;
ADSTYPE_BOOLEAN : Result := IntToStr(wrkPointer^.__MIDL_0010.Boolean);
ADSTYPE_INTEGER : Result := IntToStr(wrkPointer^.__MIDL_0010.Integer);
ADSTYPE_LARGE_INTEGER : Result := IntToStr(wrkPointer^.__MIDL_0010.LargeInteger);
ADSTYPE_UTC_TIME:
begin
// ADS_UTC_TIME maps to a _SYSTEMTIME structure
Move(wrkPointer^.__MIDL_0010.UTCTime, oSysTime, SizeOf(oSysTime));
// create two TDateTime values for the date and the time
dtDate := EncodeDate(oSysTime.wYear, oSysTime.wMonth, oSysTime.wDay);
dtTime := EncodeTime(oSysTime.wHour, oSysTime.wMinute, oSysTime.wSecond, oSysTime.wMilliseconds);
// add the two TDateTime's (really only a Float), and turn into a string
Result := DateTimeToStr(dtDate+dtTime);
end;
else Result := Format(rc_UnknownDataType, [oSrchColumn.dwADsType]);
end;
end;
// ---------------------------------------------------------------------------
// Public methods
// ---------------------------------------------------------------------------
// Check if any object matching the criteria as defined in the properties exists
function TADSISearch.CheckIfExists(): Boolean;
var
{$IFDEF UNICODE}
slTemp : TWideStringList;
{$ELSE}
slTemp : TStringList;
{$ENDIF}
iOldMaxRows : Integer;
wsOldAttributes : WideString;
begin
Result := False;
// save the settings of the MaxRows and Attributes properties
iOldMaxRows := FMaxRows;
wsOldAttributes := FAttributes;
try
// set the attributes to return just one row (that's good enough for
// making sure it exists), and the Attribute of instanceType which is
// one attribute that must exist for any of the ADSI objects
FMaxRows := 1;
FAttributes := 'instanceType';
try
Search;
// did we get any results?? If so, at least one object exists!
slTemp := GetFirstRow();
Result := (slTemp <> nil);
slTemp.Free;
except
on EADSISearchException do ;
end;
finally
// restore the attributes to what they were before
FMaxRows := iOldMaxRows;
FAttributes := wsOldAttributes;
end;
end;
{$IFDEF UNICODE}
function TADSISearch.GetFirstRow(): TWideStringList;
var
slTemp : TWideStringList;
{$ELSE}
function TADSISearch.GetFirstRow(): TStringList;
var
slTemp : TStringList;
{$ENDIF}
begin
slTemp := nil;
try
if FSearchExecuted then begin
// get the first row of the result set
FResult := FDirSrchIntf.GetFirstRow(FSearchHandle);
// did we succeed? ATTENTION: if we don't have any more rows,
// we still get a "success" value back from ADSI!!
if Succeeded(FResult) then begin
// any more rows in the result set?
if (FResult <> S_ADS_NOMORE_ROWS) then begin
// create a string list
{$IFDEF UNICODE}
slTemp := TWideStringList.Create;
{$ELSE}
slTemp := TStringList.Create;
{$ENDIF}
// enumerate all columns into that resulting string list
EnumerateColumns(slTemp);
end;
end
else begin
raise EADSISearchException.CreateFmt(rc_GetFirstFailed, [FResult]);
end;
end
else begin
raise EADSISearchException.Create(rc_SearchNotExec);
end;
finally
Result := slTemp;
end;
end;
{$IFDEF UNICODE}
function TADSISearch.GetNextRow(): TWideStringList;
var
slTemp : TWideStringList;
{$ELSE}
function TADSISearch.GetNextRow(): TStringList;
var
slTemp : TStringList;
{$ENDIF}
begin
slTemp := nil;
try
if FSearchExecuted then begin
// get the next row of the result set
FResult := FDirSrchIntf.GetNextRow(FSearchHandle);
// did we succeed? ATTENTION: if we don't have any more rows,
// we still get a "success" value back from ADSI!!
if Succeeded(FResult) then begin
// any more rows in the result set?
if (FResult <> S_ADS_NOMORE_ROWS) then begin
// create result string list
{$IFDEF UNICODE}
slTemp := TWideStringList.Create;
{$ELSE}
slTemp := TStringList.Create;
{$ENDIF}
// enumerate all columns in result set
EnumerateColumns(slTemp);
end;
end
else begin
raise EADSISearchException.CreateFmt(rc_GetNextFailed, [FResult]);
end;
end
else begin
raise EADSISearchException.Create(rc_SearchNotExec);
end;
finally
Result := slTemp;
end;
end;
// this is the core piece of the component - the actual search method
procedure TADSISearch.Search;
var
ix : Integer;
wsFilter : WideString;
{$IFDEF UNICODE}
slTemp : TWideStringList;
{$ELSE}
slTemp : TStringList;
{$ENDIF}
AttrCount : Cardinal;
AttrArray : array of WideString;
SrchPrefInfo : array of ads_searchpref_info;
DSO :IADsOpenDSObject;
Dispatch:IDispatch;
begin
// check to see if we have assigned an IADs, if not, bind to it
if (FBaseIADs = nil) then begin
ADsGetObject('LDAP:', IID_IADsOpenDSObject, DSO);
Dispatch := DSO.OpenDSObject(FBasePath, FUsername, FPassword, ADS_SECURE_AUTHENTICATION);
FResult := Dispatch.QueryInterface(IID_IADs, FBaseIADs);
//FResult := ADsGetObject(#FBasePath[1], IID_IADs, FBaseIADs);
if not Succeeded(FResult) then begin
raise EADSISearchException.CreateFmt(rc_CouldNotBind, [FBasePath, FResult]);
end;
end;
// get the IDirectorySearch interface from the base object
FDirSrchIntf := (FBaseIADs as IDirectorySearch);
if (FDirSrchIntf = nil) then begin
raise EADSISearchException.CreateFmt(rc_CouldNotGetIDS, [FBasePath, FResult]);
end;
// if we still have a valid search handle => close it
if (FSearchHandle <> 0) then begin
FResult := FDirSrchIntf.CloseSearchHandle(FSearchHandle);
if not Succeeded(FResult) then begin
raise EADSISearchException.CreateFmt(rc_CouldNotFreeSH, [FResult]);
end;
end;
// we are currently setting 3 search preferences
// for a complete list of possible search preferences, please check
// the ADS_SEARCHPREF_xxx values in ActiveDs_TLB.pas
SetLength(SrchPrefInfo, 4);
// Set maximum number of rows to be what is defined in the MaxRows property
SrchPrefInfo[0].dwSearchPref := ADS_SEARCHPREF_SIZE_LIMIT;
SrchPrefInfo[0].vValue.dwType := ADSTYPE_INTEGER;
SrchPrefInfo[0].vValue.__MIDL_0010.Integer := FMaxRows;
// set the "chase referrals" search preference
SrchPrefInfo[1].dwSearchPref := ADS_SEARCHPREF_CHASE_REFERRALS;
SrchPrefInfo[1].vValue.dwType := ADSTYPE_BOOLEAN;
SrchPrefInfo[1].vValue.__MIDL_0010.Boolean := Ord(FChaseReferrals);
// set the "search scope" search preference
SrchPrefInfo[2].dwSearchPref := ADS_SEARCHPREF_SEARCH_SCOPE;
SrchPrefInfo[2].vValue.dwType := ADSTYPE_INTEGER;
SrchPrefInfo[2].vValue.__MIDL_0010.Integer := Ord(FSearchScope);
// set the "page size " search preference
SrchPrefInfo[3].dwSearchPref := ADS_SEARCHPREF_PAGESIZE;
SrchPrefInfo[3].vValue.dwType := ADSTYPE_INTEGER;
SrchPrefInfo[3].vValue.__MIDL_0010.Integer := FPageSize;
// set the search preferences of our directory search interface
FResult := FDirSrchIntf.SetSearchPreference(Pointer(SrchPrefInfo), Length(SrchPrefInfo));
if not Succeeded(FResult) then begin
raise EADSISearchException.CreateFmt(rc_SetSrchPrefFailed,
Google for using ADSI with Delphi, you can find some articles talking about that
Active Directory Service Interfaces
Using ADSI in Delphi
and you can also look at online-admin which they offer components to manage many of windows services including AD