Delphi HID in Delphi7 and Delphi XE2 - delphi

I made a small program in Delphi 7 to show some details of all attached HID devices. I only used system files like SetupAPI, Moduleloader and HID.pas. This works perfect.
When I take the same code and compile it in Delphi XE2 or (2010 for that matter), it fails to produce the required output.
Probably this has something to do with pointer casting or so, but I cannot find the root cause.
Can anyone help.
This is my code:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes,
Graphics, Controls, Forms, Dialogs, StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
Memo1: TMemo;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
Uses
SetUpAPI, HID;
{$R *.dfm}
Type
THIDUSBDeviceInfo = Record { contains interface level information of each device}
SymLink : String;
BufferSize : Word;
Handle : THandle;
VID : DWord;
PID : DWord;
VersionNumber : Word;
ManufacturerString : String;
ProductString : String;
SerialNumberString : String;
end;
THIDDeviceList = Array of THIDUSBDeviceInfo;
Const
HIDUSB_COUNTOFINTERRUPTBUFFERS = 64; // Count of buffers for interrupt data
Procedure ScanForHIDdevices( Var DeviceList : THIDDeviceList;
TargetVID, TargetPID : DWord);
Var
HID_GUIid : TGUID;
spdid : TSPDeviceInterfaceData;
pSpDidd : PSPDEVICEINTERFACEDETAILDATAA;
spddd : TSPDevInfoData;
HIDinfo : HDEVINFO;
CurIdx : Integer;
dwSize : DWord;
SymbolicLink : String;
DevHandle : THandle;
HidAttrs : THIDDAttributes;
FoundIdx : Integer;
Info : THIDUSBDeviceInfo;
Function GetHidDeviceInfo( Symlink : PChar) : THIDUSBDeviceInfo;
Var
pstr : pWideChar;
preparsedData : PHIDPPreparsedData;
hidCaps : THIDPCaps;
Begin
FillChar(Result, SizeOf( Result), 0);
Result.SymLink := SymLink+ #0;
GetMem( pstr, 512);
DevHandle := CreateFile( Symlink,
GENERIC_READ or GENERIC_WRITE,
FILE_SHARE_READ or FILE_SHARE_WRITE,
nil,
OPEN_EXISTING,
0,
0);
If DevHandle <> INVALID_HANDLE_VALUE then
begin
If HidD_GetAttributes( DevHandle,
HidAttrs) then
begin
result.VID := HidAttrs.VendorID;
result.PID := HidAttrs.ProductID;
result.VersionNumber := HidAttrs.VersionNumber;
end;
If HidD_GetManufacturerString( DevHandle, pstr, 512) then
Result.ManufacturerString := pStr;
If HidD_GetProductString( DevHandle, pstr, 512) then
Result.ProductString := pStr;
If HidD_GetSerialNumberString( DevHandle, pstr, 512) then
Result.SerialNumberString := pStr;
{ Set Input buffer size }
HidD_SetNumInputBuffers( DevHandle,
HIDUSB_COUNTOFINTERRUPTBUFFERS);
{ Get capabilities }
HidD_GetPreparsedData( DevHandle, preparsedData);
if (preparsedData) then
begin
HidP_GetCaps( preparsedData, hidCaps);
Result.BufferSize := hidCaps.OutputReportByteLength;
end
else
Result.BufferSize := 11;
closeHandle( DevHandle);
end;
FreeMem( pStr);
End;
Begin
FoundIdx := 0;
DeviceList := Nil;
{ Get GUID of hid class }
HidD_GetHidGuid( HID_GUIid);
{ Get a list of devices belonging to HID class }
HIDinfo := SetupDiGetClassDevs( #HID_GUIid,
nil,
GetDesktopWindow(),
DIGCF_DEVICEINTERFACE or DIGCF_PRESENT);
{ Go through list of devices }
If thandle(HIDinfo) <> INVALID_HANDLE_VALUE then
begin
CurIdx := 0;
spdid.cbSize := SizeOf(spdid);
While SetupDiEnumDeviceInterfaces( HIDinfo,
nil,
HID_GUIid,
curIdx,
spdid) do
begin
dwSize := 0;
{ Get device path for Createfile calls }
SetupDiGetDeviceInterfaceDetail( HIDinfo,
#spdid,
nil,
dwSize,
#dwSize,
nil);
If dwSize > 0 then
begin
GetMem(pSpDidd, dwSize);
pSpDidd^.cbSize := SizeOf( TSPDEVICEINTERFACEDETAILDATAA);
spddd.cbSize := SizeOf(spddd);
If SetupDiGetDeviceInterfaceDetail( HIDinfo,
#spdid,
pSpDidd,
dwSize,
#dwSize,
#spddd) then
begin
SymbolicLink := PChar( #(pSpDidd^.DevicePath));
{ Get information about the device (Vendor and
Product IDs, Strings, ...) }
FillChar(info, SizeOf(Info), 0);
Info := GetHidDeviceInfo( #(pSpDidd^.DevicePath));
Info.Handle := INVALID_HANDLE_VALUE;
{ check if VID/PID match targets }
If (Info.VID = TargetVID) AND
(Info.PID = TargetPID) then
begin
{ Add Devices to result list }
SetLength(DeviceList, FoundIdx + 1);
DeviceList[foundIdx] := Info;
Inc(FoundIdx);
end
else // list all HID devices if no target is specified
If (TargetVID = 0) AND (TargetPID = 0) then
begin
{ Add Devices to result list }
SetLength( DeviceList, FoundIdx + 1);
DeviceList[FoundIdx] := Info;
Inc(FoundIdx);
end;
end;
FreeMem( pSpDidd);
end;
inc(CurIdx);
end;
SetupDiDestroyDeviceInfoList( HIDinfo);
end;
End;
procedure TForm1.Button1Click(Sender: TObject);
Var
DeviceList : THIDDeviceList;
I : Integer;
begin
ScanForHIDdevices( DeviceList, 0, 0);
Memo1.Lines.Clear;
Memo1.Lines.Add(IntToStr(Length(DeviceList)) + ' device(s) found');
If Length(DeviceList) > 0 then
For I := 0 to Length(DeviceList)-1 do
With DeviceList[I] do
begin
Memo1.Lines.Add('Device Number : ' + IntToStr(I));
Memo1.Lines.Add('Symbolic link : ' + SymLink);
Memo1.Lines.Add('Handle : 0x' + IntToHex(Handle, 1));
Memo1.Lines.Add('Buffer size : ' + IntToStr(BufferSize));
Memo1.Lines.Add('VID : 0x' + IntToHex(VID, 4));
Memo1.Lines.Add('PID : 0x' + IntToHex(PID, 4));
Memo1.Lines.Add('Version : ' + IntToStr(VersionNumber));
Memo1.Lines.Add('Manufacturer : ' + ManufacturerString);
Memo1.Lines.Add('Product name : ' + ProductString);
Memo1.Lines.Add('Serial number : ' + SerialNumberString);
Memo1.Lines.Add(' ');
end;
Memo1.SetFocus;
end;

You have to load the DLL module before you call any of these functions:
LoadHid();
LoadSetupApi();
I suppose that we have to unload the DLL when finished with the program. Then use this code:
UnloadHid;
UnloadSetupApi

Related

ask Delphi7 NtQueryObject and NtQuerySystemInformation

Can you explain why the Handle type "Process" has a PID / process name in Process Hacker:
I've tried NtQueryObject() and NtQuerySystemInformation() but all of them don't work. There is no PID / process name on Handle Type "Process".
You can enumerate the handles with NtQuerySystemInformation and the SystemHandleInformation Information Class. This will return an array of SYSTEM_HANDLE_INFORMATION records.
SYSTEM_HANDLE_INFORMATION = record // Information Class 16
ProcessId: ULONG;
ObjectTypeNumber: UCHAR;
Flags: UCHAR; // 0x01 = PROTECT_FROM_CLOSE, 0x02 = INHERIT
Handle: USHORT;
Object_: PVOID;
GrantedAccess: ACCESS_MASK;
end;
As this contains the PID of the process you now have a 1:1 relation between a process and the handles it has open.
Example code (full example here):
// uses JwaNative;
procedure EnumHandles;
var
shi: PSYSTEM_HANDLE_INFORMATION;
cbSize: DWORD;
cbRet: DWORD;
nts: NTSTATUS;
i: Integer;
hDupHandle: THandle;
dwErr: DWORD;
ObjectName: string;
begin
WriteLn('Enumerating Handles');
cbSize := $5000;
GetMem(shi, cbSize);
repeat
cbSize := cbSize * 2;
ReallocMem(shi, cbSize);
nts := NtQuerySystemInformation(SystemHandleInformation, shi, cbSize, #cbRet);
until nts <> STATUS_INFO_LENGTH_MISMATCH;
if nts = STATUS_SUCCESS then
begin
for i := 0 to shi^.HandleCount - 1 do
begin
if shi^.Handles[i].GrantedAccess <> $0012019f then
begin
if shi^.Handles[i].ProcessId = dwPid then
begin
nts := NtDuplicateObject(hProcess, shi^.Handles[i].Handle,
GetCurrentProcess, #hDupHandle, 0, 0, 0);
if nts = STATUS_SUCCESS then
begin
ObjectName := GetObjectName(hDupHandle);
if (ObjectName <> '') and SameText(RightStr(ObjectName, Length(EventName)), EventName) then
begin
WriteLn(Format('Handle=%d Name=%s', [shi^.Handles[i].Handle, ObjectName]));
CloseHandle(hDupHandle);
nts := NtDuplicateObject(hProcess, shi^.Handles[i].Handle,
GetCurrentProcess, #hDupHandle, 0, 0, DUPLICATE_CLOSE_SOURCE);
if nts = STATUS_SUCCESS then
begin
WriteLn(Format('Duplicated Handle with DUPLICATE_CLOSE_SOURCE, new Handle=%d', [hDupHandle]));
end;
end;
if hDupHandle > 0 then
CloseHandle(hDupHandle);
end;
end;
end;
end;
end
else begin
dwErr := RtlNtStatusToDosError(nts);
WriteLn(Format('Failed to read handles, NtQuerySystemInformation failed with %.8x => %d (%s)', [nts, SysErrorMessage(dwErr)]));
end;
FreeMem(shi);
end;

How to get all of the registered file formats from VCL.Graphics... but 64bit

In my 32bit application I'm using the FindRegisteredPictureFileFormats unit provided by Cosmin Prund => (How to get all of the supported file formats from Graphics unit?).
I need the same but for 64bit. David Heffernan replied it had already a 64bit version. Can this code be made public ?
Thanks a lot !!
I believe that this unit does what you are looking for. I've testing it on 32 bit and 64 bit Windows, with runtime packages and without. I've not tested it with top-down memory allocation, but I don't believe that there are pointer truncation bugs.
unit FindRegisteredPictureFileFormats;
{$POINTERMATH ON}
interface
uses Classes, Contnrs;
// Extracts the file extension + the description; Returns True if the hack was successful,
// False if unsuccesful.
function GetListOfRegisteredPictureFileFormats(List: TStrings): Boolean;
// This returns the list of TGraphicClass registered; True for successful hack, false
// for unsuccesful hach
function GetListOfRegisteredPictureTypes(List: TClassList): Boolean;
implementation
uses Graphics;
type
TRelativeCallOpcode = packed record
OpCode: Byte;
Offset: Integer;
end;
PRelativeCallOpcode = ^TRelativeCallOpcode;
TLongAbsoluteJumpOpcode = packed record
OpCode: array [0 .. 1] of Byte;
Destination: Cardinal;
end;
PLongAbsoluteJumpOpcode = ^TLongAbsoluteJumpOpcode;
TReturnTList = function: TList;
// Structure copied from Graphics unit.
PFileFormat = ^TFileFormat;
TFileFormat = record
GraphicClass: TGraphicClass;
Extension: string;
Description: string;
DescResID: Integer;
end;
function FindFirstRelativeCallOpcode(StartOffset: NativeUInt): NativeUInt;
var
Ram: ^Byte;
i: Integer;
PLongJump: PLongAbsoluteJumpOpcode;
begin
Ram := nil;
PLongJump := PLongAbsoluteJumpOpcode(#Ram[StartOffset]);
if (PLongJump^.OpCode[0] = $FF) and (PLongJump^.OpCode[1] = $25) then
{$IF Defined(WIN32)}
Result := FindFirstRelativeCallOpcode(PNativeUInt(PLongJump^.Destination)^)
{$ELSEIF Defined(Win64)}
Result := FindFirstRelativeCallOpcode(PNativeUInt(PLongJump^.Destination + StartOffset + SizeOf(PLongJump^))^)
{$ELSE}
{$MESSAGE Fatal 'Architecture not supported'}
{$ENDIF}
else
begin
for i := 0 to 64 do
if PRelativeCallOpcode(#Ram[StartOffset + i])^.OpCode = $E8 then
Exit(StartOffset + i + PRelativeCallOpcode(#Ram[StartOffset + i])
^.Offset + 5);
Result := 0;
end;
end;
procedure FindGetFileFormatsFunc(out ProcAddr: TReturnTList);
var
Offset_from_RegisterFileFormat: NativeUInt;
Offset_from_RegisterFileFormatRes: NativeUInt;
begin
Offset_from_RegisterFileFormat := FindFirstRelativeCallOpcode(NativeUInt(#TPicture.RegisterFileFormat));
Offset_from_RegisterFileFormatRes := FindFirstRelativeCallOpcode(NativeUInt(#TPicture.RegisterFileFormatRes));
if (Offset_from_RegisterFileFormat = Offset_from_RegisterFileFormatRes) then
ProcAddr := TReturnTList(Pointer(Offset_from_RegisterFileFormat))
else
ProcAddr := nil;
end;
function GetListOfRegisteredPictureFileFormats(List: TStrings): Boolean;
var
GetListProc: TReturnTList;
L: TList;
i: Integer;
begin
FindGetFileFormatsFunc(GetListProc);
if Assigned(GetListProc) then
begin
Result := True;
L := GetListProc;
for i := 0 to L.Count - 1 do
List.Add(PFileFormat(L[i])^.Extension + '=' + PFileFormat(L[i])
^.Description);
end
else
Result := False;
end;
function GetListOfRegisteredPictureTypes(List: TClassList): Boolean;
var
GetListProc: TReturnTList;
L: TList;
i: Integer;
begin
FindGetFileFormatsFunc(GetListProc);
if Assigned(GetListProc) then
begin
Result := True;
L := GetListProc;
for i := 0 to L.Count - 1 do
List.Add(PFileFormat(L[i])^.GraphicClass);
end
else
Result := False;
end;
end.

List all users of an AD group in Delphi

How can I list all users of an AD group in Delphi 7?
One of the options, as I know, is to use a string LDAP. I got a LDAP string, but how to use it?
I tried to use WinAPI, example from internet that i search
function TSequrity.DomainUsers: String;
var
EntiesRead: DWORD;
TotalEntries: DWORD;
UserInfo: lpUSER_INFO_1;
lpBuffer: Pointer;
ResumeHandle: DWORD;
Counter: Integer;
NetApiStatus: LongWord;
w:WideString;
begin
ResumeHandle := 0;
w:=Domain;
NetApiStatus := NetUserEnum(#w[1], 1, 0, lpBuffer, 0, EntiesRead, TotalEntries, ResumeHandle);
NetApiBufferFree(lpBuffer);
NetApiStatus := NetUserEnum(#w[1], 1, 0, lpBuffer, TotalEntries*TotalEntries, EntiesRead, TotalEntries, ResumeHandle);
UserInfo := lpBuffer;
for Counter := 0 to EntiesRead - 1 do
begin
Result:=Result+WideCharToString(UserInfo^.usri1_name)+#13#10;
Inc(UserInfo);
end;
NetApiBufferFree(lpBuffer);
end;
It find local users. But im need to find users of domain group.
Here's an example using "NetGroupGetUsers". Please be aware that this does not work with nested groups (groups containing other groups).
{$WARN SYMBOL_PLATFORM OFF}
program DomainGroupGetUsersTest;
{$APPTYPE CONSOLE}
uses
SysUtils, Windows, Classes;
const
netapi32lib = 'netapi32.dll';
type
PGroupUsersInfo0 = ^TGroupUsersInfo0;
_GROUP_USERS_INFO_0 = record
grui0_name: LPWSTR;
end;
TGroupUsersInfo0 = _GROUP_USERS_INFO_0;
GROUP_USERS_INFO_0 = _GROUP_USERS_INFO_0;
NET_API_STATUS = DWORD;
LPBYTE = ^BYTE;
function NetApiBufferFree (Buffer: Pointer): NET_API_STATUS; stdcall;
external netapi32lib;
function NetGroupGetUsers (servername: LPCWSTR; groupname: LPCWSTR;
level: DWORD; var bufptr: LPBYTE; prefmaxlen: DWORD; var entriesread: DWORD;
var totalentries: DWORD; ResumeHandle: PDWORD): NET_API_STATUS; stdcall;
external netapi32lib;
function DomainGroupGetUsers (const sGroup: WideString;
const UserList: TStrings;
const sLogonServer: WideString) : Boolean;
{ "sLogonServer" must be prefixed with "\\".
"sGroup" must contain the group name only. }
type
TaUserGroup = array of TGroupUsersInfo0;
const
PREF_LEN = 1024;
var
pBuffer : LPBYTE;
i : Integer;
Res : NET_API_STATUS;
dwRead, dwTotal : DWord;
hRes : DWord;
begin
Assert (sGroup <> '');
Assert (sLogonServer <> '');
Assert (UserList <> NIL);
UserList.Clear;
Result := true;
hRes := 0;
repeat
Res := NetGroupGetUsers (PWideChar (sLogonServer), PWideChar (sGroup),
0, pBuffer, PREF_LEN, dwRead, dwTotal,
PDWord (#hRes));
if (Res = Error_Success) or (Res = ERROR_MORE_DATA) then
begin
if (dwRead > 0) then
for i := 0 to dwRead - 1 do
with TaUserGroup (pBuffer) [i] do
UserList.Add (grui0_name);
NetApiBufferFree (pBuffer);
end { if }
else Result := false;
until (Res <> ERROR_MORE_DATA);
end; { DomainGroupGetUsers }
var
UserList : TStringList;
iIndex : Integer;
begin
UserList := TStringList.Create;
try
DomainGroupGetUsers ('Domain Users', UserList,
GetEnvironmentVariable ('LOGONSERVER'));
for iIndex := 0 to UserList.Count - 1 do
WriteLn (UserList [iIndex]);
finally
UserList.Free;
end; { try / finally }
if (DebugHook <> 0) then
begin
WriteLn;
Write ('Press [Enter] to continue ...');
ReadLn;
end; { if }
end.

in Delphi7, How can I retrieve hard disk unique serial number?

Hi
I want to retrieve HDD unique (hardware) serial number.
I use some functions but in Windows Seven or Vista they don't work correctly because of admin right.
Is it possible retrieve it without run as Administrator?
Following the links in the question comments Sertac posted, I came across this interesting C++ question, where Fredou answered with a nice link to a codeproject example showing how to do this in .NET, which in turn was based on a link to Borland C++ code and article.
The cool thing is that this C++ code works as a non-administrator user too!
Now you need someone to help you translate this C++ code to Delphi.
Edit: Found a Delphi unit that does this for you.
I wrote some sample use for it:
program DiskDriveSerialConsoleProject;
{$APPTYPE CONSOLE}
uses
Windows,
SysUtils,
hddinfo in 'hddinfo.pas';
const
// Max number of drives assuming primary/secondary, master/slave topology
MAX_IDE_DRIVES = 16;
procedure ReadPhysicalDriveInNTWithZeroRights ();
var
DriveNumber: Byte;
HDDInfo: THDDInfo;
begin
HDDInfo := THDDInfo.Create();
try
for DriveNumber := 0 to MAX_IDE_DRIVES - 1 do
try
HDDInfo.DriveNumber := DriveNumber;
if HDDInfo.IsInfoAvailable then
begin
Writeln('VendorId: ', HDDInfo.VendorId);
Writeln('ProductId: ', HDDInfo.ProductId);
Writeln('ProductRevision: ', HDDInfo.ProductRevision);
Writeln('SerialNumber: ', HDDInfo.SerialNumber);
Writeln('SerialNumberInt: ', HDDInfo.SerialNumberInt);
Writeln('SerialNumberText: ', HDDInfo.SerialNumberText);
end;
except
on E: Exception do
Writeln(Format('DriveNumber %d, %s: %s', [DriveNumber, E.ClassName, E.Message]));
end;
finally
HDDInfo.Free;
end;
end;
begin
ReadPhysicalDriveInNTWithZeroRights;
Write('Press <Enter>');
Readln;
end.
Unit from http://www.delphipraxis.net/564756-post28.html
// http://www.delphipraxis.net/564756-post28.html
unit hddinfo;
interface
uses Windows, SysUtils, Classes;
const
IOCTL_STORAGE_QUERY_PROPERTY = $2D1400;
type
THDDInfo = class (TObject)
private
FDriveNumber: Byte;
FFileHandle: Cardinal;
FInfoAvailable: Boolean;
FProductRevision: string;
FProductId: string;
FSerialNumber: string;
FVendorId: string;
procedure ReadInfo;
procedure SetDriveNumber(const Value: Byte);
public
constructor Create;
property DriveNumber: Byte read FDriveNumber write SetDriveNumber;
property VendorId: string read FVendorId;
property ProductId: string read FProductId;
property ProductRevision: string read FProductRevision;
property SerialNumber: string read FSerialNumber;
function SerialNumberInt: Cardinal;
function SerialNumberText: string;
function IsInfoAvailable: Boolean;
end;
implementation
type
STORAGE_PROPERTY_QUERY = packed record
PropertyId: DWORD;
QueryType: DWORD;
AdditionalParameters: array[0..3] of Byte;
end;
STORAGE_DEVICE_DESCRIPTOR = packed record
Version: ULONG;
Size: ULONG;
DeviceType: Byte;
DeviceTypeModifier: Byte;
RemovableMedia: Boolean;
CommandQueueing: Boolean;
VendorIdOffset: ULONG;
ProductIdOffset: ULONG;
ProductRevisionOffset: ULONG;
SerialNumberOffset: ULONG;
STORAGE_BUS_TYPE: DWORD;
RawPropertiesLength: ULONG;
RawDeviceProperties: array[0..511] of Byte;
end;
function ByteToChar(const B: Byte): Char;
begin
Result := Chr(B + $30)
end;
function SerialNumberToCardinal (SerNum: String): Cardinal;
begin
HexToBin(PChar(SerNum), PChar(#Result), SizeOf(Cardinal));
end;
function SerialNumberToString(SerNum: String): String;
var
I, StrLen: Integer;
Pair: string;
B: Byte;
Ch: Char absolute B;
begin
Result := '';
StrLen := Length(SerNum);
if Odd(StrLen) then Exit;
I := 1;
while I < StrLen do
begin
Pair := Copy (SerNum, I, 2);
HexToBin(PChar(Pair), PChar(#B), 1);
Result := Result + Chr(B);
Inc(I, 2);
end;
I := 1;
while I < Length(Result) do
begin
Ch := Result[I];
Result[I] := Result[I + 1];
Result[I + 1] := Ch;
Inc(I, 2);
end;
end;
constructor THddInfo.Create;
begin
inherited;
SetDriveNumber(0);
end;
function THDDInfo.IsInfoAvailable: Boolean;
begin
Result := FInfoAvailable
end;
procedure THDDInfo.ReadInfo;
type
PCharArray = ^TCharArray;
TCharArray = array[0..32767] of Char;
var
Returned: Cardinal;
Status: LongBool;
PropQuery: STORAGE_PROPERTY_QUERY;
DeviceDescriptor: STORAGE_DEVICE_DESCRIPTOR;
PCh: PChar;
begin
FInfoAvailable := False;
FProductRevision := '';
FProductId := '';
FSerialNumber := '';
FVendorId := '';
try
FFileHandle := CreateFile(
PChar('\\.\PhysicalDrive' + ByteToChar(FDriveNumber)),
0,
FILE_SHARE_READ or FILE_SHARE_WRITE,
nil,
OPEN_EXISTING,
0,
0
);
if FFileHandle = INVALID_HANDLE_VALUE then
RaiseLastOSError;
ZeroMemory(#PropQuery, SizeOf(PropQuery));
ZeroMemory(#DeviceDescriptor, SizeOf(DeviceDescriptor));
DeviceDescriptor.Size := SizeOf(DeviceDescriptor);
Status := DeviceIoControl(
FFileHandle,
IOCTL_STORAGE_QUERY_PROPERTY,
#PropQuery,
SizeOf(PropQuery),
#DeviceDescriptor,
DeviceDescriptor.Size,
Returned,
nil
);
if not Status then
RaiseLastOSError;
if DeviceDescriptor.VendorIdOffset <> 0 then
begin
PCh := #PCharArray(#DeviceDescriptor)^[DeviceDescriptor.VendorIdOffset];
FVendorId := PCh;
end;
if DeviceDescriptor.ProductIdOffset <> 0 then
begin
PCh := #PCharArray(#DeviceDescriptor)^[DeviceDescriptor.ProductIdOffset];
FProductId := PCh;
end;
if DeviceDescriptor.ProductRevisionOffset <> 0 then
begin
PCh := #PCharArray(#DeviceDescriptor)^[DeviceDescriptor.ProductRevisionOffset];
FProductRevision := PCh;
end;
if DeviceDescriptor.SerialNumberOffset <> 0 then
begin
PCh := #PCharArray(#DeviceDescriptor)^[DeviceDescriptor.SerialNumberOffset];
FSerialNumber := PCh;
end;
FInfoAvailable := True;
finally
if FFileHandle <> INVALID_HANDLE_VALUE then
CloseHandle(FFileHandle);
end;
end;
function THDDInfo.SerialNumberInt: Cardinal;
begin
Result := 0;
if ((IsInfoAvailable = True) and (FSerialNumber <> '')) then Result := SerialNumberToCardinal(FSerialNumber)
end;
function THDDInfo.SerialNumberText: string;
begin
Result := '';
if ((IsInfoAvailable = True) and (FSerialNumber <> '')) then Result := SerialNumberToString(FSerialNumber)
end;
procedure THDDInfo.SetDriveNumber(const Value: Byte);
begin
FDriveNumber := Value;
ReadInfo;
end;
end.
Edit: RAID configurations require special provisions.
For instance, I got a RAID system with multiple RAID 5 array; only the first one displays, and it does not show the drive serial numbers, but the serial number of the RAID array:
VendorId: AMCC
ProductId: 9550SXU-16ML
ProductRevision: 3.08
SerialNumber: 006508296D6A2A00DE82
SerialNumberInt: 688416000
--jeroen
You can use the WMI (Windows Management Instrumentation) to get information related to windows hardware.
Exist two wmi classes wich exposes a property called SerialNumber which store the Number allocated by the manufacturer to identify the physical media. these classes are Win32_DiskDrive and Win32_PhysicalMedia.to access the SerialNumber property of these classes you must know the DeviceId of the Disk which is something like this \\.\PHYSICALDRIVE0. Another way is use a association class which link the Physical drive with the logical drive (C,D,E)
so you must find this link previous to obtain the serial number. the sequence to find this association is like this.
Win32_DiskPartition -> Win32_LogicalDiskToPartition -> Win32_DiskDrive
Note 1 : The SerialNumber property for the Win32_DiskDrive class does not exist in Windows Server 2003, Windows XP, Windows 2000, and Windows NT 4.0, so how you are talking about use Windows Vista or Windows 7, will work ok for you.
Note 2 : The code does not require a administrator account to run.
check this code
{$APPTYPE CONSOLE}
uses
SysUtils,
ActiveX,
ComObj,
Variants;
function GetDiskSerial(const Drive:AnsiChar):string;
var
FSWbemLocator : OLEVariant;
objWMIService : OLEVariant;
colDiskDrives : OLEVariant;
colLogicalDisks: OLEVariant;
colPartitions : OLEVariant;
objDiskDrive : OLEVariant;
objPartition : OLEVariant;
objLogicalDisk : OLEVariant;
oEnumDiskDrive : IEnumvariant;
oEnumPartition : IEnumvariant;
oEnumLogical : IEnumvariant;
iValue : LongWord;
DeviceID : string;
begin;
Result:='';
FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
objWMIService := FSWbemLocator.ConnectServer('localhost', 'root\CIMV2', '', ''); //Connect to the WMI
colDiskDrives := objWMIService.ExecQuery('SELECT * FROM Win32_DiskDrive','WQL',0);
oEnumDiskDrive:= IUnknown(colDiskDrives._NewEnum) as IEnumVariant;
while oEnumDiskDrive.Next(1, objDiskDrive, iValue) = 0 do
begin
DeviceID := StringReplace(objDiskDrive.DeviceID,'\','\\',[rfReplaceAll]); //Escape the `\` chars in the DeviceID value because the '\' is a reserved character in WMI.
colPartitions := objWMIService.ExecQuery(Format('ASSOCIATORS OF {Win32_DiskDrive.DeviceID="%s"} WHERE AssocClass = Win32_DiskDriveToDiskPartition',[DeviceID]));//link the Win32_DiskDrive class with the Win32_DiskDriveToDiskPartition class
oEnumPartition := IUnknown(colPartitions._NewEnum) as IEnumVariant;
while oEnumPartition.Next(1, objPartition, iValue) = 0 do
begin
colLogicalDisks := objWMIService.ExecQuery('ASSOCIATORS OF {Win32_DiskPartition.DeviceID="'+objPartition.DeviceID+'"} WHERE AssocClass = Win32_LogicalDiskToPartition'); //link the Win32_DiskPartition class with theWin32_LogicalDiskToPartition class.
oEnumLogical := IUnknown(colLogicalDisks._NewEnum) as IEnumVariant;
while oEnumLogical.Next(1, objLogicalDisk, iValue) = 0 do
begin
if objLogicalDisk.DeviceID=(Drive+':') then //compare the device id
begin
Result:=objDiskDrive.SerialNumber;
Exit;
end;
objLogicalDisk:=Unassigned;
end;
objPartition:=Unassigned;
end;
end;
end;
begin
try
CoInitialize(nil);
try
Writeln(GetDiskSerial('C'));
Readln;
finally
CoUninitialize;
end;
except
on E:Exception do
begin
Writeln(E.Classname, ':', E.Message);
Readln;
end;
end;
end.
Here is another DiskId32 translation from C++ to Delphi by Victor Derevyanko
project:
http://code.google.com/p/dvsrc/
Because the first method (WithZeroRights) doesn't work for me, I wrote another for ReadIdeDriveAsScsiDriveInNT method:
unit HDScsiInfo;
interface
uses
Windows, SysUtils;
const
IDENTIFY_BUFFER_SIZE = 512;
FILE_DEVICE_SCSI = $0000001b;
IOCTL_SCSI_MINIPORT_IDENTIFY = ((FILE_DEVICE_SCSI shl 16) + $0501);
IDE_ATA_IDENTIFY = $EC; // Returns ID sector for ATA.
IOCTL_SCSI_MINIPORT = $0004D008; // see NTDDSCSI.H for definition
type
TDiskData = array [0..256-1] of DWORD;
TDriveInfo = record
ControllerType: Integer; //0 - primary, 1 - secondary, 2 - Tertiary, 3 - Quaternary
DriveMS: Integer; //0 - master, 1 - slave
DriveModelNumber: String;
DriveSerialNumber: String;
DriveControllerRevisionNumber: String;
ControllerBufferSizeOnDrive: Int64;
DriveType: String; //fixed or removable or unknown
DriveSizeBytes: Int64;
end;
THDScsiInfo = class (TObject)
private
FDriveNumber: Byte;
FFileHandle: Cardinal;
FInfoAvailable: Boolean;
FProductRevision: string;
FSerialNumber: string;
FControllerType: Integer;
FDriveMS: Integer;
FDriveModelNumber: string;
FControllerBufferSizeOnDrive: Int64;
FDriveType: string;
FDriveSizeBytes: Int64;
procedure ReadInfo;
procedure SetDriveNumber(const Value: Byte);
procedure PrintIdeInfo(DiskData: TDiskData);
public
constructor Create;
property DriveNumber: Byte read FDriveNumber write SetDriveNumber;
property ProductRevision: string read FProductRevision;
property SerialNumber: string read FSerialNumber;
property ControllerType: Integer read FControllerType;
property DriveMS: Integer read FDriveMS;
property DriveModelNumber: string read FDriveModelNumber;
property ControllerBufferSizeOnDrive: Int64 read FControllerBufferSizeOnDrive;
property DriveType: string read FDriveType;
property DriveSizeBytes: Int64 read FDriveSizeBytes;
function IsInfoAvailable: Boolean;
end;
implementation
type
SRB_IO_CONTROL = record
HeaderLength: Cardinal;
Signature: array [0..8-1] of Byte;
Timeout: Cardinal;
ControlCode: Cardinal;
ReturnCode: Cardinal;
Length: Cardinal;
end;
PSRB_IO_CONTROL = ^SRB_IO_CONTROL;
DRIVERSTATUS = record
bDriverError: Byte;// Error code from driver, or 0 if no error.
bIDEStatus: Byte;// Contents of IDE Error register.
// Only valid when bDriverError is SMART_IDE_ERROR.
bReserved: array [0..1] of Byte;// Reserved for future expansion.
dwReserved: array [0..1] of Longword;// Reserved for future expansion.
end;
SENDCMDOUTPARAMS = record
cBufferSize: Longword;// Size of bBuffer in bytes
DriverStatus: DRIVERSTATUS;// Driver status structure.
bBuffer: array [0..0] of Byte;// Buffer of arbitrary length in which to store the data read from the // drive.
end;
IDEREGS = record
bFeaturesReg: Byte;// Used for specifying SMART "commands".
bSectorCountReg: Byte;// IDE sector count register
bSectorNumberReg: Byte;// IDE sector number register
bCylLowReg: Byte;// IDE low order cylinder value
bCylHighReg: Byte;// IDE high order cylinder value
bDriveHeadReg: Byte;// IDE drive/head register
bCommandReg: Byte;// Actual IDE command.
bReserved: Byte;// reserved for future use. Must be zero.
end;
SENDCMDINPARAMS = record
cBufferSize: Longword;// Buffer size in bytes
irDriveRegs: IDEREGS; // Structure with drive register values.
bDriveNumber: Byte;// Physical drive number to send
// command to (0,1,2,3).
bReserved: array[0..2] of Byte;// Reserved for future expansion.
dwReserved: array [0..3] of Longword;// For future use.
bBuffer: array [0..0] of Byte;// Input buffer. //!TODO: this is array of single element
end;
PSENDCMDINPARAMS = ^SENDCMDINPARAMS;
PSENDCMDOUTPARAMS = ^SENDCMDOUTPARAMS;
IDSECTOR = record
wGenConfig: Word;
wNumCyls: Word;
wReserved: Word;
wNumHeads: Word;
wBytesPerTrack: Word;
wBytesPerSector: Word;
wSectorsPerTrack: Word;
wVendorUnique: array [0..3-1] of Word;
sSerialNumber: array [0..20-1] of AnsiChar;
wBufferType: Word;
wBufferSize: Word;
wECCSize: Word;
sFirmwareRev: array [0..8-1] of AnsiChar;
sModelNumber: array [0..40-1] of AnsiChar;
wMoreVendorUnique: Word;
wDoubleWordIO: Word;
wCapabilities: Word;
wReserved1: Word;
wPIOTiming: Word;
wDMATiming: Word;
wBS: Word;
wNumCurrentCyls: Word;
wNumCurrentHeads: Word;
wNumCurrentSectorsPerTrack: Word;
ulCurrentSectorCapacity: Cardinal;
wMultSectorStuff: Word;
ulTotalAddressableSectors: Cardinal;
wSingleWordDMA: Word;
wMultiWordDMA: Word;
bReserved: array [0..128-1] of Byte;
end;
PIDSECTOR = ^IDSECTOR;
TArrayDriveInfo = array of TDriveInfo;
type
DeviceQuery = record
HeaderLength: Cardinal;
Signature: array [0..8-1] of Byte;
Timeout: Cardinal;
ControlCode: Cardinal;
ReturnCode: Cardinal;
Length: Cardinal;
cBufferSize: Longword;// Buffer size in bytes
irDriveRegs: IDEREGS; // Structure with drive register values.
bDriveNumber: Byte;// Physical drive number to send
bReserved: array[0..2] of Byte;// Reserved for future expansion.
dwReserved: array [0..3] of Longword;// For future use.
bBuffer: array [0..0] of Byte;// Input buffer. //!TODO: this is array of single element
end;
function ConvertToString (diskdata: TDiskData;
firstIndex: Integer;
lastIndex: Integer;
buf: PAnsiChar): PAnsiChar;
var
index: Integer;
position: Integer;
begin
position := 0;
// each integer has two characters stored in it backwards
for index := firstIndex to lastIndex do begin
// get high byte for 1st character
buf[position] := AnsiChar(Chr(diskdata [index] div 256));
inc(position);
// get low byte for 2nd character
buf [position] := AnsiChar(Chr(diskdata [index] mod 256));
inc(position);
end;
// end the string
buf[position] := Chr(0);
// cut off the trailing blanks
index := position - 1;
while (index >0) do begin
// if not IsSpace(AnsiChar(buf[index]))
if (AnsiChar(buf[index]) <> ' ')
then break;
buf [index] := Chr(0);
dec(index);
end;
Result := buf;
end;
constructor THDScsiInfo.Create;
begin
inherited;
SetDriveNumber(0);
end;
function THDScsiInfo.IsInfoAvailable: Boolean;
begin
Result := FInfoAvailable
end;
procedure THDScsiInfo.PrintIdeInfo (DiskData: TDiskData);
var
nSectors: Int64;
serialNumber: array [0..1024-1] of AnsiChar;
modelNumber: array [0..1024-1] of AnsiChar;
revisionNumber: array [0..1024-1] of AnsiChar;
begin
// copy the hard drive serial number to the buffer
ConvertToString (DiskData, 10, 19, #serialNumber);
ConvertToString (DiskData, 27, 46, #modelNumber);
ConvertToString (DiskData, 23, 26, #revisionNumber);
FControllerType := FDriveNumber div 2;
FDriveMS := FDriveNumber mod 2;
FDriveModelNumber := modelNumber;
FSerialNumber := serialNumber;
FProductRevision := revisionNumber;
FControllerBufferSizeOnDrive := DiskData [21] * 512;
if ((DiskData [0] and $0080) <> 0)
then FDriveType := 'Removable'
else if ((DiskData [0] and $0040) <> 0)
then FDriveType := 'Fixed'
else FDriveType := 'Unknown';
// calculate size based on 28 bit or 48 bit addressing
// 48 bit addressing is reflected by bit 10 of word 83
if ((DiskData[83] and $400) <> 0) then begin
nSectors := DiskData[103] * Int64(65536) * Int64(65536) * Int64(65536) +
DiskData[102] * Int64(65536) * Int64(65536) +
DiskData[101] * Int64(65536) +
DiskData[100];
end else begin
nSectors := DiskData [61] * 65536 + DiskData [60];
end;
// there are 512 bytes in a sector
FDriveSizeBytes := nSectors * 512;
end;
procedure THDScsiInfo.ReadInfo;
type
DataArry = array [0..256-1] of WORD;
PDataArray = ^DataArry;
const
SENDIDLENGTH = sizeof (SENDCMDOUTPARAMS) + IDENTIFY_BUFFER_SIZE;
var
I: Integer;
buffer: array [0..sizeof (SRB_IO_CONTROL) + SENDIDLENGTH - 1] of AnsiChar;
dQuery: DeviceQuery;
dummy: DWORD;
pOut: PSENDCMDOUTPARAMS;
pId: PIDSECTOR;
DiskData: TDiskData;
pIdSectorPtr: PWord;
begin
FInfoAvailable := False;
FFileHandle := CreateFile (PChar(Format('\\.\Scsi%d:', [FDriveNumber])),
GENERIC_READ or GENERIC_WRITE,
FILE_SHARE_READ or FILE_SHARE_WRITE, nil,
OPEN_EXISTING, 0, 0);
if (FFileHandle <> INVALID_HANDLE_VALUE) then begin
ZeroMemory(#dQuery, SizeOf(dQuery));
dQuery.HeaderLength := sizeof (SRB_IO_CONTROL);
dQuery.Timeout := 10000;
dQuery.Length := SENDIDLENGTH;
dQuery.ControlCode := IOCTL_SCSI_MINIPORT_IDENTIFY;
StrLCopy(#dQuery.Signature, 'SCSIDISK', 8);
dQuery.irDriveRegs.bCommandReg := IDE_ATA_IDENTIFY;
dQuery.bDriveNumber := FDriveNumber;
if (DeviceIoControl (FFileHandle, IOCTL_SCSI_MINIPORT,
#dQuery,
SizeOf(dQuery),
#buffer,
sizeof (SRB_IO_CONTROL) + SENDIDLENGTH,
dummy, nil))
then begin
pOut := PSENDCMDOUTPARAMS(buffer + sizeof (SRB_IO_CONTROL)); //!TOCHECK
pId := PIDSECTOR(#pOut^.bBuffer[0]);
if (pId^.sModelNumber[0] <> Chr(0) ) then begin
pIdSectorPtr := PWord(pId);
for I := 0 to 256-1 do
DiskData[I] := PDataArray(pIdSectorPtr)[I];
PrintIdeInfo (DiskData);
FInfoAvailable := True;
end;
end;
CloseHandle(FFileHandle);
end;
end;
procedure THDScsiInfo.SetDriveNumber(const Value: Byte);
begin
FDriveNumber := Value;
ReadInfo;
end;
end.
Sample usage:
procedure ReadIdeDriveAsScsiDriveInNT;
var
DriveNumber: Byte;
HDDInfo: THDScsiInfo;
begin
HDDInfo := THDScsiInfo.Create();
try
for DriveNumber := 0 to MAX_IDE_DRIVES - 1 do
try
HDDInfo.DriveNumber := DriveNumber;
if HDDInfo.IsInfoAvailable then begin
Writeln('Available Drive: ', HDDInfo.DriveNumber);
Writeln('ControllerType: ', HDDInfo.ControllerType);
Writeln('DriveMS: ', HDDInfo.DriveMS);
Writeln('DriveModelNumber: ', HDDInfo.DriveModelNumber);
Writeln('ControllerBufferSizeOnDrive: ', HDDInfo.ControllerBufferSizeOnDrive);
Writeln('DriveType: ', HDDInfo.DriveType);
Writeln('DriveSizeBytes: ', HDDInfo.DriveSizeBytes);
Writeln('ProductRevision: ', HDDInfo.ProductRevision);
Writeln('SerialNumber: ', HDDInfo.SerialNumber);
end;
except
on E: Exception do
Writeln(Format('DriveNumber %d, %s: %s', [DriveNumber, E.ClassName, E.Message]));
end;
finally
HDDInfo.Free;
end;
end;
begin
ReadIdeDriveAsScsiDriveInNT;
Write('Press <Enter>');
end.
This works great with my WD disk.
I found this code, it is fixed one and working fine with me on windows 7 64
https://code.google.com/p/dvsrc/downloads/detail?name=20120116DiskId32Port_fixed.7z&can=2&q=
and this his all work
https://code.google.com/p/dvsrc/downloads/list
Posting this purely for completeness sake, and to possibly satisfy those interested or die hard hardware fanatics.
I do not have a Pascal compiler at my disposal to test these routines on current Windows systems, but I do know this code worked back in the DOS era. Maybe it still works from a command prompt window.
Pascal code:
uses
Dos, Crt;
type
SerNoType = record
case Integer of
0: (SerNo1, SerNo2: Word);
1: (SerNo: Longint);
end;
DiskSerNoInfoType = record
Infolevel: Word;
VolSerNo: SerNoType;
VolLabel: array[1..11] of Char;
FileSys: array[1..8] of Char;
end;
function HexDigit(N: Byte): Char;
begin
if N < 10 then
HexDigit := Chr(Ord('0') + N)
else
HexDigit := Chr(Ord('A') + (N - 10));
end;
function GetVolSerialNo(DriveNo: Byte): String;
var
ReturnArray: DiskSerNoInfoType;
Regs: Registers;
begin
with Regs do
begin
AX := $440d;
BL := DriveNo;
CH := $08;
CL := $66;
DS := Seg(ReturnArray);
DX := Ofs(ReturnArray);
Intr($21, Regs);
if (Flags and FCarry) <> 0 then
GetVolSerialNo := ''
else
with ReturnArray.VolSerNo do
GetVolSerialNo :=
HexDigit(Hi(SerNo2) div 16) + HexDigit(Hi(SerNo2) mod 16) +
HexDigit(Lo(SerNo2) div 16) + HexDigit(Lo(SerNo2) mod 16) +
HexDigit(Hi(SerNo1) div 16) + HexDigit(Hi(SerNo1) mod 16) +
HexDigit(Lo(SerNo1) div 16) + HexDigit(Lo(SerNo1) mod 16);
end;
end;
procedure PutVolSerialNo(DriveNo: Byte; SerialNo: Longint);
var
ReturnArray: DiskSerNoInfoType;
Regs: Registers;
begin
with Regs do
begin
AX := $440d;
BL := DriveNo;
CH := $08;
CL := $66;
DS := Seg(ReturnArray);
DX := Ofs(ReturnArray);
Intr($21, Regs);
if (Flags and FCarry) = 0 then
begin
ReturnArray.VolSerNo.SerNo := SerialNo;
AH := $69;
BL := DriveNo;
AL := $01;
DS := Seg(ReturnArray);
DX := Ofs(ReturnArray);
Intr($21, Regs);
end;
end;
end;
Please feel free to update this answer in order to get it working (if possible at all) in Delphi.

Delphi - get what files are opened by an application

How can I get the list of opened files by an application, using Delphi?
For example what files are opened by winword.exe
Using the Native API function NtQuerySystemInformation you can list all open handles from all processes.
try this example
program ListAllHandles;
{$APPTYPE CONSOLE}
uses
PSApi,
Windows,
SysUtils;
const
SystemHandleInformation = $10;
STATUS_SUCCESS = $00000000;
STATUS_BUFFER_OVERFLOW = $80000005;
STATUS_INFO_LENGTH_MISMATCH = $C0000004;
DefaulBUFFERSIZE = $100000;
type
OBJECT_INFORMATION_CLASS = (ObjectBasicInformation,ObjectNameInformation,ObjectTypeInformation,ObjectAllTypesInformation,ObjectHandleInformation );
SYSTEM_HANDLE=packed record
uIdProcess:ULONG;
ObjectType:UCHAR;
Flags :UCHAR;
Handle :Word;
pObject :Pointer;
GrantedAccess:ACCESS_MASK;
end;
PSYSTEM_HANDLE = ^SYSTEM_HANDLE;
SYSTEM_HANDLE_ARRAY = Array[0..0] of SYSTEM_HANDLE;
PSYSTEM_HANDLE_ARRAY= ^SYSTEM_HANDLE_ARRAY;
SYSTEM_HANDLE_INFORMATION=packed record
uCount:ULONG;
Handles:SYSTEM_HANDLE_ARRAY;
end;
PSYSTEM_HANDLE_INFORMATION=^SYSTEM_HANDLE_INFORMATION;
TNtQuerySystemInformation=function (SystemInformationClass:DWORD; SystemInformation:pointer; SystemInformationLength:DWORD; ReturnLength:PDWORD):THandle; stdcall;
TNtQueryObject =function (ObjectHandle:cardinal; ObjectInformationClass:OBJECT_INFORMATION_CLASS; ObjectInformation:pointer; Length:ULONG;ResultLength:PDWORD):THandle;stdcall;
UNICODE_STRING=packed record
Length :Word;
MaximumLength:Word;
Buffer :PWideChar;
end;
OBJECT_NAME_INFORMATION=UNICODE_STRING;
POBJECT_NAME_INFORMATION=^OBJECT_NAME_INFORMATION;
Var
NTQueryObject :TNtQueryObject;
NTQuerySystemInformation:TNTQuerySystemInformation;
function GetObjectInfo(hObject:cardinal; objInfoClass:OBJECT_INFORMATION_CLASS):LPWSTR;
var
pObjectInfo:POBJECT_NAME_INFORMATION;
HDummy :THandle;
dwSize :DWORD;
begin
Result:=nil;
dwSize := sizeof(OBJECT_NAME_INFORMATION);
pObjectInfo := AllocMem(dwSize);
HDummy := NTQueryObject(hObject, objInfoClass, pObjectInfo,dwSize, #dwSize);
if((HDummy = STATUS_BUFFER_OVERFLOW) or (HDummy = STATUS_INFO_LENGTH_MISMATCH)) then
begin
FreeMem(pObjectInfo);
pObjectInfo := AllocMem(dwSize);
HDummy := NTQueryObject(hObject, objInfoClass, pObjectInfo,dwSize, #dwSize);
end;
if((HDummy >= STATUS_SUCCESS) and (pObjectInfo.Buffer <> nil)) then
begin
Result := AllocMem(pObjectInfo.Length + sizeof(WCHAR));
CopyMemory(result, pObjectInfo.Buffer, pObjectInfo.Length);
end;
FreeMem(pObjectInfo);
end;
Procedure EnumerateOpenFiles();
var
sDummy : string;
hProcess : THandle;
hObject : THandle;
ResultLength: DWORD;
aBufferSize : DWORD;
aIndex : Integer;
pHandleInfo : PSYSTEM_HANDLE_INFORMATION;
HDummy : THandle;
lpwsName : PWideChar;
lpwsType : PWideChar;
lpszProcess : PAnsiChar;
begin
AbufferSize := DefaulBUFFERSIZE;
pHandleInfo := AllocMem(AbufferSize);
HDummy := NTQuerySystemInformation(DWORD(SystemHandleInformation), pHandleInfo,AbufferSize, #ResultLength); //Get the list of handles
if(HDummy = STATUS_SUCCESS) then //If no error continue
begin
for aIndex:=0 to pHandleInfo^.uCount-1 do //iterate the list
begin
hProcess := OpenProcess(PROCESS_DUP_HANDLE or PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, FALSE, pHandleInfo.Handles[aIndex].uIdProcess); //open the process to get aditional info
if(hProcess <> INVALID_HANDLE_VALUE) then //Check valid handle
begin
hObject := 0;
if DuplicateHandle(hProcess, pHandleInfo.Handles[aIndex].Handle,GetCurrentProcess(), #hObject, STANDARD_RIGHTS_REQUIRED,FALSE, 0) then //Get a copy of the original handle
begin
lpwsName := GetObjectInfo(hObject, ObjectNameInformation); //Get the filename linked to the handle
if (lpwsName <> nil) then
begin
lpwsType := GetObjectInfo(hObject, ObjectTypeInformation);
lpszProcess := AllocMem(MAX_PATH);
if GetModuleFileNameEx(hProcess, 0,lpszProcess, MAX_PATH)<>0 then //get the name of the process
sDummy:=ExtractFileName(lpszProcess)
else
sDummy:= 'System Process';
Writeln('PID ',pHandleInfo.Handles[aIndex].uIdProcess);
Writeln('Handle ',pHandleInfo.Handles[aIndex].Handle);
Writeln('Process ',sDummy);
Writeln('FileName ',string(lpwsName));
Writeln;
FreeMem(lpwsName);
FreeMem(lpwsType);
FreeMem(lpszProcess);
end;
CloseHandle(hObject);
end;
CloseHandle(hProcess);
end;
end;
end;
FreeMem(pHandleInfo);
end;
begin
try
NTQueryObject := GetProcAddress(GetModuleHandle('NTDLL.DLL'), 'NtQueryObject');
NTQuerySystemInformation := GetProcAddress(GetModuleHandle('NTDLL.DLL'), 'NtQuerySystemInformation');
if (#NTQuerySystemInformation<>nil) and (#NTQuerySystemInformation<>nil) then
EnumerateOpenFiles();
Readln;
except
on E:Exception do
Writeln(E.Classname, ': ', E.Message);
end;
end.
You could port walkobjects.cpp or run a command line process that does it for you and parse it's output.
I've looked at the MSDN page...
it said NtQuerySystemInformation() is an OS internal proc,
and that we're not recommended to use it:
The NtQuerySystemInformation function
and the structures that it returns are
internal to the operating system and
subject to change from one release of
Windows to another. To maintain the
compatibility of your application, it
is better to use the alternate
functions previously mentioned
instead.

Resources