LsaOpenPolicy is throwing exception in my code. Why? - delphi

I got the following code from a newsgroup posting. Strangely, it isn't working for me in Delphi 2010; An exception is being thrown at the LsaOpenPolicy function call:
function AddLogonAsAService(ID: pchar): boolean;
const
Right: PChar = 'SeServiceLogonRight';
var
FResult: NTSTATUS;
//szSystemName: LPTSTR;
FObjectAttributes: TLSAObjectAttributes;
FPolicyHandle: LSA_HANDLE;
Server, Privilege: TLSAUnicodeString;
FSID: PSID;
cbSid: DWORD;
ReferencedDomain: LPTSTR;
cchReferencedDomain: DWORD;
peUse: SID_NAME_USE;
PrivilegeString: String;
begin
Result := false;
try
ZeroMemory(#FObjectAttributes, sizeof(FObjectAttributes));
Server.Buffer := nil;
Server.Length := 0;
Server.MaximumLength := 256;
PrivilegeString := Right; //or some other privilege
Privilege.Buffer := PChar(PrivilegeString);
Privilege.Length := 38;
Privilege.MaximumLength := 256;
FResult := LsaOpenPolicy(
#Server, //this machine, because the Buffer is NIL
#FObjectAttributes,
POLICY_ALL_ACCESS,
FPolicyHandle);
if FResult = STATUS_SUCCESS then begin
cbSid := 128;
cchReferencedDomain := 16;
GetMem(FSID, cbSid);
//FSID:=PSID(HeapAlloc(GetProcessHeap(), 0, cbSid));
GetMem(ReferencedDomain, cchReferencedDomain);
//ReferencedDomain := LPTSTR(HeapAlloc(GetProcessHeap(), 0, cchReferencedDomain * sizeof(ReferencedDomain^)));
if LookupAccountName(nil, ID, FSID, cbSid, ReferencedDomain,
cchReferencedDomain, peUse) then begin
FResult := LsaAddAccountRights(FPolicyHandle, FSID, #Privilege, 1);
Result := FResult = STATUS_SUCCESS;
end;
FreeMem(FSID, cbSid);
FreeMem(ReferencedDomain, cchReferencedDomain);
end;
except
Result := false;
end;
end;
Original posting may be found at Google Groups archive:
From: "andrew"
Newsgroups:
borland.public.delphi.winapi
Subject: NetUserAdd and assigning user
rights
Date: Tue, 25 Sep 2001 10:08:35 +1000
Thanks in advance for any answers.

According to the MSDN docs you should not use an LSA_UNICODE_STRING with the Buffer set to nil but pass nil instead: LsaOpenPolicy(nil, ...
/EDIT:
The code below works fine for me using Jedi Apilib so I think something might be wrong with your definition (maybe calling convention?), so please add this to your code.
Also you are specifying maximum buffer size of 256 in the LSA_UNICODE_STRING's which is incorrect, in the first case the maximum buffer is 0.
uses
JwaWinType, JwaNtSecApi;
procedure TForm1.Button1Click(Sender: TObject);
var
ObjectAttribs: LSA_OBJECT_ATTRIBUTES;
PolicyHandle: LSA_HANDLE;
nts: NTSTATUS;
begin
ZeroMemory(#ObjectAttribs, SizeOf(ObjectAttribs));
nts := LsaOpenPolicy(nil, ObjectAttribs, POLICY_ALL_ACCESS, PolicyHandle);
Memo1.Lines.Add(Format('nts=%.8x', [nts]));
end;

Fixed/changed function, tested on Win7 under D2009 (but should work on older/newer too). Of course app. must be running with admin rights.
uses
JwaWinNT, JwaWinType, JwaNtStatus, JwaNtSecApi, JwaLmCons;
function AddPrivilegeToAccount(AAccountName, APrivilege: String): DWORD;
var
lStatus: TNTStatus;
lObjectAttributes: TLsaObjectAttributes;
lPolicyHandle: TLsaHandle;
lPrivilege: TLsaUnicodeString;
lSid: PSID;
lSidLen: DWORD;
lTmpDomain: String;
lTmpDomainLen: DWORD;
lTmpSidNameUse: TSidNameUse;
{$IFDEF UNICODE}
lPrivilegeWStr: String;
{$ELSE}
lPrivilegeWStr: WideString;
{$ENDIF}
begin
ZeroMemory(#lObjectAttributes, SizeOf(lObjectAttributes));
lStatus := LsaOpenPolicy(nil, lObjectAttributes, POLICY_LOOKUP_NAMES, lPolicyHandle);
if lStatus <> STATUS_SUCCESS then
begin
Result := LsaNtStatusToWinError(lStatus);
Exit;
end;
try
lTmpDomainLen := JwaLmCons.DNLEN; // In 'clear code' this should be get by LookupAccountName
SetLength(lTmpDomain, lTmpDomainLen);
lSidLen := SECURITY_MAX_SID_SIZE;
GetMem(lSid, lSidLen);
try
if LookupAccountName(nil, PChar(AAccountName), lSid, lSidLen, PChar(lTmpDomain),
lTmpDomainLen, lTmpSidNameUse) then
begin
lPrivilegeWStr := APrivilege;
lPrivilege.Buffer := PWideChar(lPrivilegeWStr);
lPrivilege.Length := Length(lPrivilegeWStr) * SizeOf(Char);
lPrivilege.MaximumLength := lPrivilege.Length;
lStatus := LsaAddAccountRights(lPolicyHandle, lSid, #lPrivilege, 1);
Result := LsaNtStatusToWinError(lStatus);
end else
Result := GetLastError;
finally
FreeMem(lSid);
end;
finally
LsaClose(lPolicyHandle);
end;
end;
procedure TForm2.Button1Click(Sender: TObject);
var
lStatus: DWORD;
begin
lStatus := AddPrivilegeToAccount('Administrators'{or any account/group name}, 'SeServiceLogonRight');
if lStatus = ERROR_SUCCESS then
Caption := 'OK'
else
Caption := SysErrorMessage(lStatus);
end;

Related

printer settings don't change (winapi: documentproperties)

Language: delphi 6
I succeeded in opening the dialog using documentproperties.
However, I changed the settings and clicked OK, but it does not change.
I want to change the paper to A3.
Please tell me how to do it.
code:
var
FPrinterHandle:THandle;
aDevice: array[0..255] of char;
DevMode: PDeviceMode;
StubDevMode: TDeviceMode;
DeviceMode: THandle;
begin
strpcopy(aDevice, Combobox1.Text);
if OpenPrinter(aDevice,FPrinterHandle,nil) then begin
DeviceMode := GlobalAlloc(GHND, DocumentProperties(self.handle, FPrinterHandle, ADevice, StubDevMode, StubDevMode, 0));
if DeviceMode <> 0 then begin
DevMode := GlobalLock(DeviceMode);
DocumentProperties(0, FPrinterHandle, ADevice, DevMode^, DevMode^, DM_OUT_BUFFER);
DevMode^.dmFields := DM_PAPERSIZE;
DevMode^.dmPaperSize := DMPAPER_A3;
DocumentProperties(0, FPrinterHandle, ADevice, DevMode^, DevMode^, DM_OUT_BUFFER or DM_IN_BUFFER);
GlobalUnlock(DeviceMode);
GlobalFree(DeviceMode);
end;
end;
end;
It's not the code I wrote, it's from somewhere. Hope it helps.
Pass the printer name and desired paper size as parameters. (I used GetPrinter procedure)
If parameter(integer) is 0, it is set to A3, and if it is 1, it is set to A4.
And when I printed pdf file with shellexecute, I checked that it prints in the desired size.
※ Before print, the tray of the printer should be set to 'automatic selection'.
procedure SetPrinterInfo(APrinterName: PChar; Psize: Integer);
var
HPrinter : THandle;
InfoSize, BytesNeeded: Cardinal;
DevMode: PDeviceMode;
PI2: PPrinterInfo2;
PrinterDefaults: TPrinterDefaults;
begin
with PrinterDefaults do
begin
DesiredAccess := PRINTER_ACCESS_USE;
pDatatype := nil;
pDevMode := nil;
end;
if OpenPrinter(APrinterName, HPrinter, #PrinterDefaults) then
try
SetLastError(0);
//Determine the number of bytes to allocate for the PRINTER_INFO_2 construct...
if not GetPrinter(HPrinter, 2, nil, 0, #BytesNeeded) then
begin
//Allocate memory space for the PRINTER_INFO_2 pointer (PrinterInfo2)...
PI2 := AllocMem(BytesNeeded);
try
InfoSize := SizeOf(TPrinterInfo2);
if GetPrinter(HPrinter, 2, PI2, BytesNeeded, #BytesNeeded) then
begin
DevMode := PI2.pDevMode;
DevMode.dmFields := DevMode.dmFields or DM_PAPERSIZE;
if Psize = 0 then DevMode.dmPaperSize := DMPAPER_A3
else if Psize = 1 then DevMode.dmPaperSize := DMPAPER_A4;
PI2.pSecurityDescriptor := nil;
// Apply settings to the printer
if DocumentProperties(0, hPrinter, APrinterName, PI2.pDevMode^,
PI2.pDevMode^, DM_IN_BUFFER or DM_OUT_BUFFER) = IDOK then
begin
SetPrinter(HPrinter, 2, PI2, 0); // Ignore the result of this call...
end;
end;
finally
FreeMem(PI2, BytesNeeded);
end;
end;
finally
ClosePrinter(HPrinter);
end;
end;

Delphi reboot Windows

I'm using Windows 10 and I am logged in as Administrator.
When I try to reboot the system, all it does is it logs me off.
ExitWindowsEx(EWX_REBOOT and EWX_FORCE, 0);
Can someone please tell me why is this not rebooting?
So it seems that even though I am a administrator I need to set the rights with the following function
function NTSetPrivilege(sPrivilege: string; bEnabled: Boolean): Boolean;
var
hToken: THandle;
TokenPriv: TOKEN_PRIVILEGES;
PrevTokenPriv: TOKEN_PRIVILEGES;
ReturnLength: Cardinal;
begin
Result := True;
// Only for Windows NT/2000/XP and later.
if not (Win32Platform = VER_PLATFORM_WIN32_NT) then Exit;
Result := False;
// obtain the processes token
if OpenProcessToken(GetCurrentProcess(),
TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken) then
begin
try
// Get the locally unique identifier (LUID) .
if LookupPrivilegeValue(nil, PChar(sPrivilege),
TokenPriv.Privileges[0].Luid) then
begin
TokenPriv.PrivilegeCount := 1; // one privilege to set
case bEnabled of
True: TokenPriv.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
False: TokenPriv.Privileges[0].Attributes := 0;
end;
ReturnLength := 0; // replaces a var parameter
PrevTokenPriv := TokenPriv;
// enable or disable the privilege
AdjustTokenPrivileges(hToken, False, TokenPriv, SizeOf(PrevTokenPriv),
PrevTokenPriv, ReturnLength);
end;
finally
CloseHandle(hToken);
end;
end;
// test the return value of AdjustTokenPrivileges.
Result := GetLastError = ERROR_SUCCESS;
if not Result then
raise Exception.Create(SysErrorMessage(GetLastError));
end;
like this :
procedure TMain.Neustart1Click(Sender: TObject);
const
SE_SHUTDOWN_NAME = 'SeShutdownPrivilege';
begin
NTSetPrivilege(SE_SHUTDOWN_NAME, True);
ExitWindowsEx(EWX_REBOOT or EWX_FORCE, 0);
end;
Now it works.
I was looking for a better solution to the one I had done about 5 years ago (posted below), I needed to do some tweaking for it to run on latest Delphi, older Delphi versions simply use Windows.AdjustTokenPrivileges. Code below is tried and tested since windows XP. Be careful - it works, make sure you save your work before running!
//Uses WinApi.Windows on Latest Delphi 10.3.2
function MyExitWindows(RebootParam: Longword): Boolean;
var
TTokenHd: THandle;
TTokenPvg: TTokenPrivileges;
cbtpPrevious: DWORD;
rTTokenPvg: TTokenPrivileges;
pcbtpPreviousRequired: DWORD;
tpResult: Boolean;
const
SE_SHUTDOWN_NAME = 'SeShutdownPrivilege';
begin
if Win32Platform = VER_PLATFORM_WIN32_NT then
begin
tpResult := OpenProcessToken(GetCurrentProcess(),
TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY,
TTokenHd);
if tpResult then
begin
tpResult := LookupPrivilegeValue(nil,
SE_SHUTDOWN_NAME,
TTokenPvg.Privileges[0].Luid);
TTokenPvg.PrivilegeCount := 1;
TTokenPvg.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
cbtpPrevious := SizeOf(rTTokenPvg);
pcbtpPreviousRequired := 0;
if tpResult then
//Older Delphi - replace the WinApi. to read WinApi.AdjustTokenPrivileges
WinApi.Windows.AdjustTokenPrivileges(TTokenHd,
False,
TTokenPvg,
cbtpPrevious,
rTTokenPvg,
pcbtpPreviousRequired);
end;
end;
Result := ExitWindowsEx(RebootParam, 0);
end;
//Examples
//Shutdown the computer
MyExitWindows(EWX_POWEROFF or EWX_FORCE);
//Reboot the computer
MyExitWindows(EWX_REBOOT or EWX_FORCE);

Permissions error setting recovery option with changeserviceconfig2

I'm installing a service and wanting to set the service recovery options (using admin in an XP environment). I can change the description happily enough, but if the sfa.cActions is anything but zero it fails with a error 87 (parameter error).
//
// Actions to take on service failure
//
{$EXTERNALSYM _SC_ACTION_TYPE}
_SC_ACTION_TYPE = (SC_ACTION_NONE, SC_ACTION_RESTART, SC_ACTION_REBOOT, SC_ACTION_RUN_COMMAND);
{$EXTERNALSYM SC_ACTION_TYPE}
SC_ACTION_TYPE = _SC_ACTION_TYPE;
PServiceAction = ^TServiceAction;
{$EXTERNALSYM _SC_ACTION}
_SC_ACTION = record
aType : SC_ACTION_TYPE;
Delay : DWORD;
end;
{$EXTERNALSYM SC_ACTION}
SC_ACTION = _SC_ACTION;
TServiceAction = _SC_ACTION;
procedure TXyz_Service_Module.SetDescription(const Desc: ansistring);
var
hSCM: SC_HANDLE;
hService: SC_HANDLE;
sd: SERVICE_DESCRIPTION;
begin
hSCM := WinSvc.OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
if hSCM = 0 then Exit;
hService := WinSvc.OpenService(hSCM, PChar(Self.Name), SERVICE_CHANGE_CONFIG);
if hService = 0 then Exit;
sd.lpDescription := PAnsiChar(Desc);
ChangeServiceConfig2(hService, SERVICE_CONFIG_DESCRIPTION, #sd);
WinSvc.CloseServiceHandle(hService);
WinSvc.CloseServiceHandle(hSCM);
end;
procedure TXyz_Service_Module.SetRecovery;
var
hSCM: SC_HANDLE;
hService: SC_HANDLE;
sfa: SERVICE_FAILURE_ACTIONS;
actions: array [0 .. 2] of SC_ACTION;
begin
hSCM := WinSvc.OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
if hSCM = 0 then Exit;
hService := WinSvc.OpenService(hSCM, PChar(Self.Name), SERVICE_ALL_ACCESS);
if hService = 0 then Exit;
sfa.dwResetPeriod := 999; //INFINITE;
sfa.lpCommand := nil;
sfa.lpRebootMsg := nil;
sfa.cActions := 1;
sfa.lpsaActions := #actions[0];
actions[0].aType := SC_ACTION_RESTART;
actions[0].Delay := 5000;
(*actions[1].aType := SC_ACTION_RESTART;
actions[1].Delay := 5000;
actions[2].aType := SC_ACTION_RESTART;
actions[2].Delay := 5000;*)
if not changeserviceconfig2(hservice,SERVICE_CONFIG_FAILURE_ACTIONS,#sfa) then begin
showmessage('Error : '+inttostr(getlasterror));
end;
WinSvc.CloseServiceHandle(hService);
WinSvc.CloseServiceHandle(hSCM);
end;
procedure TXyz_Service_Module.ServiceAfterInstall(Sender: TService);
begin
self.SetDescription('Bananas are yellow');
self.SetRecovery;
end;
From the ChangeServiceConfig2() documentation:
hService [in]
A handle to the service. This handle is returned by the OpenService or CreateService function and must have the SERVICE_CHANGE_CONFIG access right. For more information, see Service Security and Access Rights.
If the service controller handles the SC_ACTION_RESTART action, hService must have the SERVICE_START access right.
So, SetRecovery() will need to use this at a minimum:
hService := WinSvc.OpenService(hSCM, PChar(Self.Name), SERVICE_CHANGE_CONFIG or SERVICE_START);
It's the enumeration value.
_SC_ACTION_TYPE = (SC_ACTION_NONE, SC_ACTION_RESTART, SC_ACTION_REBOOT, SC_ACTION_RUN_COMMAND);
needs to be
{$MinEnumSize=4}
_SC_ACTION_TYPE = (SC_ACTION_NONE, SC_ACTION_RESTART, SC_ACTION_REBOOT, SC_ACTION_RUN_COMMAND);
As recommended in the comments by David Heffernan.

How to get icon for hidden file (like Explorer) for ListView in Delphi?

I useSHGetFileInfo('', 0, aFileInfo, SizeOf(TSHFileInfo), SHGFI_ICON or SHGFI_SYSICONINDEX) to extract an icon list in TImageList and then associate index with TListView. Which flag I must use to get hidden style like Explorer?
To the best of my knowledge, the system does not offer such functionality. You need to create faded icons yourself, based on the original icon. You can use a function along these lines to do that:
function CreateFadedIcon(Icon: HICON): HICON;
type
TRGBA = record
B,G,R,A: Byte
end;
procedure InitialiseBitmapInfoHeader(Width, Height: Integer; var bih: BITMAPINFOHEADER);
begin
bih.biSize := SizeOf(BITMAPINFOHEADER);
bih.biWidth := Width;
bih.biHeight := 2*Height;//height of xor bitmap plus height of and bitmap
bih.biPlanes := 1;
bih.biBitCount := 32;
bih.biCompression := BI_RGB;
end;
procedure CreateXORbitmap(const sbih, dbih: BITMAPINFOHEADER; sptr, dptr: PDWORD);
var
i, j: Integer;
begin
for i := 0 to sbih.biHeight-1 do begin
for j := 0 to sbih.biWidth-1 do begin
dptr^ := sptr^;
TRGBA(dptr^).A := TRGBA(dptr^).A div 3;
inc(dptr);//relies on the fact that no padding is needed for RGBA scanlines
inc(sptr);//likewise
end;
end;
end;
var
IconInfo: TIconInfo;
sBits, xorBits: PDWORD;
xorScanSize, andScanSize: Integer;
xorBitsSize, andBitsSize: Integer;
sbih: BITMAPINFOHEADER;
dbih: ^BITMAPINFOHEADER;
resbitsSize: DWORD;
resbits: Pointer;
begin
Result := 0;
Try
if not GetIconInfo(Icon, IconInfo) then begin
exit;
end;
Try
GetDIBheaderAndBits(IconInfo.hbmColor, sbih, Pointer(sBits));
if Assigned(sBits) then begin
Try
if (sbih.biPlanes<>1) or (sbih.biBitCount<>32) then begin
exit;
end;
xorScanSize := BytesPerScanline(sbih.biWidth, 32, 32);
Assert(xorScanSize=SizeOf(DWORD)*sbih.biWidth);
andScanSize := BytesPerScanline(sbih.biWidth, 1, 32);
xorBitsSize := sbih.biHeight*xorScanSize;
andBitsSize := sbih.biHeight*andScanSize;
resbitsSize := SizeOf(BITMAPINFOHEADER) + xorBitsSize + andBitsSize;
resbits := AllocMem(resbitsSize);//AllocMem zeroises the memory
Try
dbih := resbits;
InitialiseBitmapInfoHeader(sbih.biWidth, sbih.biHeight, dbih^);
xorBits := resbits;
inc(PByte(xorBits), SizeOf(BITMAPINFOHEADER));
CreateXORbitmap(sbih, dbih^, sBits, xorBits);
//don't need to fill in the mask bitmap when using RGBA
Result := CreateIconFromResourceEx(resbits, resbitsSize, True, $00030000, sbih.biWidth, sbih.biHeight, LR_DEFAULTCOLOR);
Finally
FreeMem(resbits);
End;
Finally
FreeMem(sBits);
End;
end;
Finally
if IconInfo.hbmMask<>0 then begin
DeleteObject(IconInfo.hbmMask);
end;
if IconInfo.hbmColor<>0 then begin
DeleteObject(IconInfo.hbmColor);
end;
End;
Finally
DestroyIcon(Icon);
End;
end;

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