Related
I have the process ID (PID), how can I get its full command line (path and arguments)?
I recently had to do this; needed to terminate known applications, perform a task, then restart them with the same command line parameters they started with.
Of all the methods that I explored that can achieve getting command line parameters for each running process, WMI proved to be the safest and least painful way.
Add the 2 units pasted below, then call GetProcessList() and loop through the objects in the TObjectList. In your application, ensure you call CoInitialize(nil) on start up, and CoUninitialize() before it's closed. Code tested in Delphi 6.
unit uWmi;
interface
uses
Classes, Contnrs,
Variants, ActiveX, ComObj;
const
WMI_RESULT_OK = 0;
WMI_RESULT_NO_RECORDS = 1;
WMI_RESULT_NULL = 2;
WMI_RESULT_INVALID_PROPERTY = 3;
WMI_RESULT_ERROR_EXEC_QUERY = 4;
WMI_RESULT_UNKNOWN_ERROR = 5;
WMI_RESULT_STRINGS: array [0..5] of string = (
'OK',
'No records',
'Property value is null',
'Invalid property',
'Error executing query',
'Unknown error'
);
type
TWmi = class
private
FService: OleVariant;
function ExecWmiQuery(const AWMIQuery: string; var AItems: OleVariant; var AEnum: IEnumVariant): Boolean;
public
constructor Create;
class function GetWmiObject(const objectName: string): IDispatch;
class function GetWmiSelectQuery(const AWMIClass: string; const ASelectAll: Boolean; const AWMIProperties: TStrings = nil; const AWMIProperty: string = ''): string;
class function GetWmiPropertyValue(const AItem: OleVariant; const AProperty: string; var AValue: string): Integer;
class procedure AddWmiPropertyValueToList(const AValue: string; AResult: Integer; AValues: TStrings); overload;
class procedure AddWmiPropertyValueToList(const AItem: OleVariant; const AProperty: string; AValues: TStrings); overload;
function GetFirstRecordSinglePropertyValue(const AWMIClass, AWMIProperty: string; var AValue: string;
const ASelectAll: Boolean): Integer; overload;
function GetFirstRecordSinglePropertyValue(const AWMIProperty: string; var AValue: string;
const AWMIQuery: string): Integer; overload;
function GetAllRecordsSinglePropertyValues(const AWMIClass, AWMIProperty: string; AValues: TStrings;
const ASelectAll: Boolean): Integer; overload;
function GetAllRecordsSinglePropertyValues(const AWMIProperty: string; AValues: TStrings;
const AWMIQuery: string): Integer; overload;
function GetAllRecordsMultiplePropertiesValues(const AWMIClass: string; AProperties: TStrings;
ARecords: TObjectList; const ASelectAll: Boolean): Integer; overload;
function GetAllRecordsMultiplePropertiesValues(AProperties: TStrings; ARecords: TObjectList;
const AWMIQuery: string): Integer; overload;
function GetAllRecordsMultiplePropertiesValues(const AWMIClass: string; const AProperties: array of string;
ARecords: TObjectList; const ASelectAll: Boolean): Integer; overload;
function GetAllRecordsMultiplePropertiesValues(const AProperties: array of string;
ARecords: TObjectList; const AWMIQuery: string): Integer; overload;
end;
implementation
uses
SysUtils, uStringUtils;
const
wbemFlagForwardOnly = $00000020;
{ TWmi }
function TWmi.ExecWmiQuery(const AWMIQuery: string; var AItems: OleVariant; var AEnum: IEnumVariant): Boolean;
begin
try
AItems := FService.ExecQuery(AWMIQuery, 'WQL', wbemFlagForwardOnly);
AEnum := IUnknown(AItems._NewEnum) as IEnumVariant;
Result := True;
except
Result := False;
end;
end;
constructor TWmi.Create;
{$IFDEF USE_LOCATOR}
const
USER = '';
PASSWORD = '';
COMPUTER = 'localhost';
var
locator: OleVariant;
{$ENDIF}
begin
{$IFDEF USE_LOCATOR}
locator := CreateOleObject('WbemScripting.SWbemLocator');
FService := locator.ConnectServer(COMPUTER, 'root\CIMV2', USER, PASSWORD);
{$ELSE}
FService := GetWmiObject('winmgmts:\\localhost\root\cimv2');
{$ENDIF}
end;
class function TWmi.GetWmiObject(const objectName: string): IDispatch;
var
chEaten: Integer;
BindCtx: IBindCtx;
Moniker: IMoniker;
begin
OleCheck(CreateBindCtx(0, bindCtx));
OleCheck(MkParseDisplayName(BindCtx, StringToOleStr(objectName), chEaten, Moniker));
OleCheck(Moniker.BindToObject(BindCtx, nil, IDispatch, Result));
end;
class function TWmi.GetWmiSelectQuery(const AWMIClass: string; const ASelectAll: Boolean;
const AWMIProperties: TStrings = nil; const AWMIProperty: string = ''): string;
var
props: string;
i: Integer;
begin
if ASelectAll then
props := '*'
else
if AWMIProperties = nil then
props := AWMIProperty
else
for i := 0 to AWMIProperties.Count - 1 do
if props = '' then
props := AWMIProperties[i]
else
props := props + ',' + AWMIProperties[i];
Result := Format('SELECT %s FROM %s', [props, AWMIClass]);
end;
class function TWmi.GetWmiPropertyValue(const AItem: OleVariant; const AProperty: string; var AValue: string): Integer;
var
v: OleVariant;
begin
try
v := AItem.Properties_.Item(AProperty).Value;
except
Result := WMI_RESULT_INVALID_PROPERTY;
AValue := '';
Exit;
end;
if VarIsNull(v) then
begin
Result := WMI_RESULT_NULL;
AValue := '';
Exit;
end;
AValue := Trim(v);
Result := WMI_RESULT_OK;
end;
class procedure TWmi.AddWmiPropertyValueToList(const AValue: string; AResult: Integer; AValues: TStrings);
begin
AValues.AddObject(AValue, TObject(AResult));
end;
class procedure TWmi.AddWmiPropertyValueToList(const AItem: OleVariant; const AProperty: string; AValues: TStrings);
var
value: string;
r: Integer;
begin
r := GetWmiPropertyValue(AItem, AProperty, value);
AddWmiPropertyValueToList(value, r, AValues);
end;
function TWmi.GetFirstRecordSinglePropertyValue(const AWMIClass, AWMIProperty: string; var AValue: string;
const ASelectAll: Boolean): Integer;
begin
Result := GetFirstRecordSinglePropertyValue(AWMIProperty, AValue,
GetWmiSelectQuery(AWMIClass, ASelectAll, nil, AWMIProperty));
end;
function TWmi.GetFirstRecordSinglePropertyValue(const AWMIProperty: string; var AValue: string;
const AWMIQuery: string): Integer;
var
items, item: OleVariant;
enum: IEnumVariant;
value: Cardinal;
begin
try
if not ExecWmiQuery(AWMIQuery, items, enum) then
begin
Result := WMI_RESULT_ERROR_EXEC_QUERY;
Exit;
end;
if enum.Next(1, item, value) <> 0 then
Result := WMI_RESULT_NO_RECORDS
else
try
Result := GetWmiPropertyValue(item, AWMIProperty, AValue);
finally
item := Unassigned;
end;
except {on: EOleException do Writeln(e.Source, ' ', e.ErrorCode, ' ', e.Message);}
Result := WMI_RESULT_UNKNOWN_ERROR;
end;
end;
function TWmi.GetAllRecordsSinglePropertyValues(const AWMIClass, AWMIProperty: string; AValues: TStrings;
const ASelectAll: Boolean): Integer;
begin
Result := GetAllRecordsSinglePropertyValues(AWMIProperty, AValues,
GetWmiSelectQuery(AWMIClass, ASelectAll, nil, AWMIProperty));
end;
function TWmi.GetAllRecordsSinglePropertyValues(const AWMIProperty: string; AValues: TStrings; const AWMIQuery: string): Integer;
var
items, item: OleVariant;
enum: IEnumVariant;
value: Cardinal;
begin
try
if not ExecWmiQuery(AWMIQuery, items, enum) then
begin
Result := WMI_RESULT_ERROR_EXEC_QUERY;
Exit;
end;
AValues.Clear;
while enum.Next(1, item, value) = 0 do
try
AddWmiPropertyValueToList(item, AWMIProperty, AValues);
finally
item := Unassigned;
end;
if AValues.Count = 0 then
Result := WMI_RESULT_NO_RECORDS
else
Result := WMI_RESULT_OK;
except {on: EOleException do Writeln(e.Source, ' ', e.ErrorCode, ' ', e.Message);}
Result := WMI_RESULT_UNKNOWN_ERROR;
AValues.Clear;
end;
end;
function TWmi.GetAllRecordsMultiplePropertiesValues(const AWMIClass: string; AProperties: TStrings;
ARecords: TObjectList; const ASelectAll: Boolean): Integer;
begin
Result := GetAllRecordsMultiplePropertiesValues(AProperties, ARecords,
GetWmiSelectQuery(AWMIClass, ASelectAll, AProperties));
end;
function TWmi.GetAllRecordsMultiplePropertiesValues(AProperties: TStrings; ARecords: TObjectList;
const AWMIQuery: string): Integer;
var
items, item: OleVariant;
enum: IEnumVariant;
value: Cardinal;
values: TStrings;
i: Integer;
begin
try
if not ExecWmiQuery(AWMIQuery, items, enum) then
begin
Result := WMI_RESULT_ERROR_EXEC_QUERY;
Exit;
end;
ARecords.Clear;
while enum.Next(1, item, value) = 0 do
try
values := TStringList.Create;
ARecords.Add(values);
for i := 0 to AProperties.Count - 1 do
AddWmiPropertyValueToList(item, AProperties[i], values);
finally
item := Unassigned;
end;
if ARecords.Count = 0 then
Result := WMI_RESULT_NO_RECORDS
else
Result := WMI_RESULT_OK;
except {on: EOleException do Writeln(e.Source, ' ', e.ErrorCode, ' ', e.Message);}
Result := WMI_RESULT_UNKNOWN_ERROR;
ARecords.Clear;
end;
end;
function TWmi.GetAllRecordsMultiplePropertiesValues(const AWMIClass: string; const AProperties: array of string;
ARecords: TObjectList; const ASelectAll: Boolean): Integer;
var
props: TStringList;
begin
props := CreateStringList(AProperties);
try
Result := GetAllRecordsMultiplePropertiesValues(AWMIClass, props, ARecords, ASelectAll);
finally
props.Free;
end;
end;
function TWmi.GetAllRecordsMultiplePropertiesValues(const AProperties: array of string;
ARecords: TObjectList; const AWMIQuery: string): Integer;
var
props: TStrings;
begin
props := CreateStringList(AProperties);
try
Result := GetAllRecordsMultiplePropertiesValues(props, ARecords, AWMIQuery);
finally
props.Free;
end;
end;
{initialization
CoInitialize(nil);
finalization
CoUninitialize;}
end.
unit uWmiProcess;
interface
uses
Contnrs;
type
TProcessInfo = class
public
Name: string;
ProcessId: Cardinal;
ExecutablePath: string;
CommandLine: string;
SessionId: Integer;
CreationDate: string;
end;
function GetProcessList: TObjectList{<TProcessInfo>};
implementation
uses
SysUtils, Classes, uWmi;
function GetProcessList: TObjectList{<TProcessInfo>};
var
wmi: TWmi;
processInfo: TProcessInfo;
records: TObjectList;
values: TStringList;
i: Integer;
function CallWmi(const AProps: array of string): Boolean;
begin
Result := wmi.GetAllRecordsMultiplePropertiesValues('Win32_Process', AProps, records, False) = uWmi.WMI_RESULT_OK;
end;
begin
Result := TObjectList.Create(True);
try
records := TObjectList.Create(True);
try
wmi := TWmi.Create;
try
if not CallWmi(['Name', 'ProcessId', 'ExecutablePath', 'CommandLine', 'SessionId', 'CreationDate']) then
Exit;
for i := 0 to records.Count - 1 do
begin
processInfo := TProcessInfo.Create;
Result.Add(processInfo);
values := TStringList(records[i]);
processInfo.Name := values[0];
processInfo.ProcessId := StrToInt(values[1]);
processInfo.ExecutablePath := values[2];
processInfo.CommandLine := values[3];
processInfo.SessionId := StrToInt(values[4]);
processInfo.CreationDate := values[5];
end;
finally
wmi.Free;
end;
finally
records.Free;
end;
except
//FreeAndNil(Result);
Result.Free;
raise;
end;
end;
end.
unit uStringUtils;
interface
uses
Classes;
procedure SplitString(const ASource: string; const ASeparator: Char; AValues: TStrings); overload;
function SplitString(const ASource: string; const ASeparator: Char): TStringList; overload;
function JoinStrings(const ASeparator: string; AValues: TStrings): string;
function CopyRange(const ASource: string; const AIndexFrom, AIndexTo: Integer): string;
type
TStringsHelper = class //poor man's helper :) ToDo should be other way around, naked routines calling the static class?
public
class procedure SplitString(const ASource: string; const ASeparator: Char; AValues: TStrings); overload;
class function SplitString(const ASource: string; const ASeparator: Char): TStringList; overload;
class function JoinStrings(const ASeparator: string; AValues: TStrings): string;
end;
type
TStringArray = array of string;
procedure FillStringList(const AValues: array of string; AStrings: TStrings);
function CreateStringList(const AValues: array of string): TStringList;
function CreateStringArray(const AStrings: array of string): TStringArray;
implementation
function CopyRange(const ASource: string; const AIndexFrom, AIndexTo: Integer): string;
begin
Result := Copy(ASource, AIndexFrom, AIndexTo - AIndexFrom + 1);
end;
procedure SplitString(const ASource: string; const ASeparator: Char; AValues: TStrings);
var
i, lastDelimPos: Integer;
begin
AValues.Clear;
lastDelimPos := 0;
for i := 1 to Length(ASource) do
if ASource[i] = ASeparator then
begin
if lastDelimPos = 0 then
AValues.Add(CopyRange(ASource, 1, i - 1))
else
AValues.Add(CopyRange(ASource, lastDelimPos + 1, i - 1));
lastDelimPos := i;
end;
if lastDelimPos = 0 then
AValues.Add(ASource)
else
AValues.Add(CopyRange(ASource, lastDelimPos + 1, MaxInt));
end;
function SplitString(const ASource: string; const ASeparator: Char): TStringList;
begin
Result := TStringList.Create;
SplitString(ASource, ASeparator, Result);
end;
function JoinStrings(const ASeparator: string; AValues: TStrings): string;
var
s: string;
i, len: Integer;
p: PChar;
begin
case AValues.Count of
0:
Result := '';
1:
Result := AValues[0];
else
len := (AValues.Count - 1) * Length(ASeparator);
for i := 0 to AValues.Count - 1 do
Inc(len, Length(AValues[i]));
SetLength(Result, len);
p := PChar(Result);
for i := 0 to AValues.Count - 1 do
begin
if i = 0 then
s := AValues[i]
else
s := ASeparator + AValues[i];
Move(PChar(s)^, p^, Length(s));
Inc(p, Length(s));
end;
end;
end;
{ TStringsHelper }
class procedure TStringsHelper.SplitString(const ASource: string;
const ASeparator: Char; AValues: TStrings);
begin
uStringUtils.SplitString(ASource, ASeparator, AValues); //Note the explicit unit reference
end;
class function TStringsHelper.SplitString(const ASource: string;
const ASeparator: Char): TStringList;
begin
Result := uStringUtils.SplitString(ASource, ASeparator); //Note the explicit unit reference
end;
class function TStringsHelper.JoinStrings(const ASeparator: string;
AValues: TStrings): string;
begin
Result := uStringUtils.JoinStrings(ASeparator, AValues); //Note the explicit unit reference
end;
procedure FillStringList(const AValues: array of string; AStrings: TStrings);
var
i: Integer;
begin
AStrings.Clear;
AStrings.Capacity := Length(AValues);
for i := 0 to Length(AValues) - 1 do
AStrings.Add(AValues[i]);
end;
function CreateStringList(const AValues: array of string): TStringList;
begin
Result := TStringList.Create;
FillStringList(AValues, Result);
end;
function CreateStringArray(const AStrings: array of string): TStringArray;
var
i: Integer;
begin
SetLength(Result, Length(AStrings));
for i := 0 to Length(AStrings) - 1 do
Result[i] := AStrings[i];
end;
end.
i want to working with service (WSDL IMPORTER) in delphi but i can not do this because raised error 'access violation at address...' when i call this Codes...
interface:
SendLetterService = interface(IInvokable)
['{FFACC70E-33A0-5413-E720-F5421944C864}']
function sendLetters(const parameters: sendLetters):sendLettersResponse; stdcall;
function getLetterType(const parameters: getLetterType):getLetterTypeResponse; stdcall;
function getOrgLetterType(const parameters: getOrgLetterType):getOrgLetterTypeResponse; stdcall;
function getOrgForms(const parameters: getOrgForms):getOrgFormsResponse; stdcall;
end;
function GetSendLetterService(UseWSDL: Boolean=System.False; Addr: string=''; HTTPRIO: THTTPRIO = nil): SendLetterService;
implementation
function GetSendLetterService(UseWSDL: Boolean; Addr: string;HTTPRIO:THTTPRIO): SendLetterService;
const
defWSDL = 'E:\delphi\TSN0\sendletter.xml';
defURL = 'http://10.0.233.254/ebox/sendletter?wsdl';
defSvc = 'SendLetterServicePortBindingQSService';
defPrt = 'SendLetterServicePortBindingQSPort';
var
RIO: THTTPRIO;
begin
Result := nil;
if (Addr = '') then
begin
if UseWSDL then
Addr := defWSDL
else
Addr := defURL;
end;
if HTTPRIO = nil then
RIO := THTTPRIO.Create(nil)
else
RIO := HTTPRIO;
try
if UseWSDL then
begin
RIO.WSDLLocation := Addr;
RIO.Service := defSvc;
RIO.Port := defPrt;
end
else
RIO.URL := Addr;
Result := (RIO as SendLetterService);
finally
if (Result = nil) and (HTTPRIO = nil) then
RIO.Free;
end;
end;
******* My Code for call Method *******
procedure TForm1.btnRcvLetterTypesClick(Sender: TObject);
var
Response : getLetterTypeResponse;
glt : getLetterType;
Srv : SendLetterService;
begin
Response := getLetterTypeResponse.Create;
glt := getLetterType.Create;
try
Srv := GetSendLetterService(True,'');
if Assigned(Srv) then
{======= Access Violation?????? ===========}
Response := Srv.getLetterType(glt);
{======= Access Violation?????? ===========}
finally
Response.Free;
glt.Free;
end;
end;
when then button click this code runing but raised error on {===} section...
please Help me...
Complete Code:
the interface that WSDL importes created:
type
sendLetterAttach = class;
Array_Of_sendLetterAttach = array of sendLetterAttach;
sendLetterAttach = class(TRemotable)
private
FfileData: TByteDynArray;
FfileData_Specified: boolean;
FfileName: string;
FfileName_Specified: boolean;
procedure SetfileData(Index: Integer; const ATByteDynArray: TByteDynArray);
function fileData_Specified(Index: Integer): boolean;
procedure SetfileName(Index: Integer; const Astring: string);
function fileName_Specified(Index: Integer): boolean;
published
property fileData: TByteDynArray Index (IS_OPTN or IS_UNQL) read FfileData
write SetfileData stored fileData_Specified;
property fileName: string Index (IS_OPTN or IS_UNQL) read FfileName
write SetfileName stored fileName_Specified;
end;
getLetterTypeResponseType = array of string;
SendLetterService = interface(IInvokable)
['{FFACC70E-33A0-5413-E720-F5421944C864}']
function sendLetters(const orgCode: string; const orgUser: string;
const orgUserPassword: string; const letterTypeCode: string;
const orgLetterTypeCode: string; const letterSubject: string;
const letterText: string; const letterOfficialNO: string;
const letterOfficialDate: string; const letterCanDelete: Int64;
const letterCanReply: Int64; const lettterReplyDueDate: string;
const letterPaymentNo: string; const formCode: string;
const InPersonAuthentication: Int64;
const people: getLetterTypeResponseType;
const attachments: Array_Of_sendLetterAttach): string; stdcall;
function getLetterType(const orgCode: string; const orgUser: string;
const orgUserPassword: string): getLetterTypeResponseType; stdcall;
function getOrgLetterType(const orgCode: string; const orgUser: string;
const orgUserPassword: string;
const letterTypeCode: string):getLetterTypeResponseType; stdcall;
function getOrgForms(const orgCode: string; const orgUser: string;
const orgUserPassword: string): getLetterTypeResponseType; stdcall;
end;
function GetSendLetterService(UseWSDL: Boolean=System.False; Addr: string='';
HTTPRIO: THTTPRIO = nil): SendLetterService;
implementation
uses SysUtils;
function GetSendLetterService(UseWSDL: Boolean; Addr: string; HTTPRIO:
THTTPRIO): SendLetterService;
const
defWSDL = 'http://10.0.233.254/ebox/sendletter?wsdl';
defURL = 'http://10.0.233.254/ebox/sendletter';
defSvc = 'SendLetterServicePortBindingQSService';
defPrt = 'SendLetterServicePortBindingQSPort';
var
RIO: THTTPRIO;
begin
Result := nil;
if (Addr = '') then
begin
if UseWSDL then
Addr := defWSDL
else
Addr := defURL;
end;
if HTTPRIO = nil then
RIO := THTTPRIO.Create(nil)
else
RIO := HTTPRIO;
try
Result := (RIO as SendLetterService);
if UseWSDL then
begin
RIO.WSDLLocation := Addr;
RIO.Service := defSvc;
RIO.Port := defPrt;
end else
RIO.URL := Addr;
finally
if (Result = nil) and (HTTPRIO = nil) then
RIO.Free;
end;
end;
and my code to call method:
procedure TForm1.btnRcvLetterTypesClick(Sender: TObject);
var
Response: getLetterTypeResponseType;
I: Integer;
Srv : SendLetterService;
begin
try
Srv := GetSendLetterService(True);
srv.getLetterType('Code','UserName','Pass');
finally
end;
end;
I have a working hook dll code for a win32 application which I developed in Delphi 2007. Since then I have ported the application to Delphi xe3 but now the hook dll or the injection function doesn't work. The hook dll replaces winsock data send and retrieve functions for UDP and TCP. Please guide.
Injection Function
Function InjectDll(Process: dword; ModulePath: PChar): boolean;
var
Memory:pointer;
Code: dword;
BytesWritten: size_t;
ThreadId: dword;
hThread: dword;
hKernel32: dword;
Inject: packed record
PushCommand:byte;
PushArgument:DWORD;
CallCommand:WORD;
CallAddr:DWORD;
PushExitThread:byte;
ExitThreadArg:dword;
CallExitThread:word;
CallExitThreadAddr:DWord;
AddrLoadLibrary:pointer;
AddrExitThread:pointer;
LibraryName:array[0..MAX_PATH] of char;
end;
begin
Result := false;
Memory := VirtualAllocEx(Process, nil, sizeof(Inject),
MEM_COMMIT, PAGE_EXECUTE_READWRITE);
if Memory = nil then Exit;
Code := dword(Memory);
Inject.PushCommand := $68;
inject.PushArgument := code + $1E;
inject.CallCommand := $15FF;
inject.CallAddr := code + $16;
inject.PushExitThread := $68;
inject.ExitThreadArg := 0;
inject.CallExitThread := $15FF;
inject.CallExitThreadAddr := code + $1A;
hKernel32 := GetModuleHandle('kernel32.dll');
inject.AddrLoadLibrary := GetProcAddress(hKernel32, 'LoadLibraryA');
inject.AddrExitThread := GetProcAddress(hKernel32, 'ExitThread');
lstrcpy(#inject.LibraryName, ModulePath);
WriteProcessMemory(Process, Memory, #inject, sizeof(inject), BytesWritten);
hThread := CreateRemoteThread(Process, nil, 0, Memory, nil, 0, ThreadId);
if hThread = 0 then Exit;
CloseHandle(hThread);
Result := True;
end;
Hook DLL
unit uMain;
interface
implementation
uses
windows, SysUtils,
advApiHook,
Winsock2b;
const
ModuleName = 'Main Dll Unit';
var
// >> Replaced functions for intercepting UDP messages
TrueSendTo : function (s: TSocket; Buf : Pointer; len, flags: Integer; var addrto: TSockAddr;
tolen: Integer): Integer; stdcall;
TrueWsaRecvFrom : function (s: TSocket; lpBuffers: PWSABUF; dwBufferCount: DWORD;
lpNumberOfBytesRecvd: PDWORD; lpFlags: PDWORD; lpFrom: psockaddr;
lpFromlen: PInt; lpOverlapped: LPWSAOVERLAPPED;
lpCompletionRoutine: PWSAOVERLAPPED_COMPLETION_ROUTINE): u_int; stdcall;
// <<
// >> Replaced functions for intercepting TCP messages
TrueConnect : function (s: TSocket; name: PSockAddr; namelen: Integer): Integer; stdcall;
TrueSend : function (s: TSocket; Buf : Pointer; len, flags: UINT): Integer; stdcall;
TrueWsaRecv : function (s: TSocket; lpBuffers : PWSABUF; dwBufferCount : DWORD;
lpNumberOfBytesSent : LPDWORD; dwFlags : PDWORD; lpOverlapped : POVERLAPPED;
lpCompletionRoutine : Pointer ): Integer; stdcall;
// <<
// >> Other replaced functions; just for logging now
TrueRecv : function (s: TSocket; var Buf; len, flags: Integer): Integer; stdcall;
TrueRecvfrom : function (s: TSocket; var Buf; len, flags: Integer; var from: TSockAddr;
var fromlen: Integer): Integer; stdcall;
TrueWsaSend : function (s: TSocket; lpBuffers : PWSABUF; dwBufferCount : DWORD;
lpNumberOfBytesSent : LPDWORD; dwFlags : DWORD; lpOverlapped : POVERLAPPED;
lpCompletionRoutine : Pointer ): Integer; stdcall;
TrueGethostbyname : function (name: PChar): PHostEnt; stdcall;
TrueAccept : function (s: TSocket; addr: PSockAddr; var addrlen: Integer): TSocket; stdcall;
TrueWsaAccept : function (s: TSOCKET; addr: psockaddr; addrlen: PINT; lpfnCondition: PCONDITIONPROC;
dwCallbackData: DWORD): TSOCKET; stdcall;
// <<
function NewSendTo(s: TSocket; Buf : Pointer; len, flags: Integer; var addrto: TSockAddr;
tolen: Integer): Integer; stdcall;
var
addrtoNew : TSockAddr;
buffer : array of byte;
dst : word;
begin
// determine destination address
if addrto.sin_addr.S_addr = u_long($FFFFFFFF) then
dst := $FFFF
else if (addrto.sin_addr.S_un_w.s_w1 = $000A) then
dst := addrto.sin_addr.S_un_w.s_w2
else
begin
// weird situation... just emulate standard behavior
result := TrueSendTo(s, Buf, len, flags, addrto, tolen);
exit;
end;
// initialize structure for new address
Move(addrto, addrtoNew, sizeOf(TSockAddr));
// change destination ip
addrtoNew.sin_addr.S_addr := $0100007F; // = 127.0.0.1
// change destination port
addrtoNew.sin_port := $E117;
// create new data with additional destination address in it
SetLength(buffer, len+2);
Move(Buf^, buffer[0], len);
Move(dst, buffer[len], 2);
// send modified package
result := TrueSendTo(s, #buffer[0], len+2, flags, addrtoNew, tolen);
end;
function NewWSARecvFrom(s: TSocket; lpBuffers: PWSABUF; dwBufferCount: DWORD;
lpNumberOfBytesRecvd: PDWORD; lpFlags: PDWORD; lpFrom: psockaddr;
lpFromlen: PInt; lpOverlapped: LPWSAOVERLAPPED;
lpCompletionRoutine: PWSAOVERLAPPED_COMPLETION_ROUTINE): u_int; stdcall;
begin
result := TrueWsaRecvFrom(s, lpBuffers, dwBufferCount, lpNumberOfBytesRecvd, lpFlags, lpFrom,
lpFromlen, lpOverlapped, lpCompletionRoutine);
// ignore recevies with optional lpFrom
if (lpFrom = nil) or (lpFromlen = nil) or (lpFromlen^ = 0) then
exit;
// change only our packages
if lpFrom.sin_addr.S_addr <> $0100007F then
begin
log(ModuleName, 'Unknown package sender');
exit;
end;
// replace source ip
lpFrom.sin_addr.S_un_w.s_w1 := $000A;
move(PByteArray(lpBuffers.buf)[lpNumberOfBytesRecvd^ - 2], lpFrom.sin_addr.S_un_w.s_w2, 2);
// data size should be smaller by 2 bytes (without source id)
lpNumberOfBytesRecvd^ := lpNumberOfBytesRecvd^ - 2;
end;
function NewConnect(s: TSocket; name: PSockAddr; namelen: Integer): Integer; stdcall;
var
newName : TSockAddr;
dst : word;
dstFile : TextFile;
begin
// determine destination address
if (name.sin_addr.S_un_w.s_w1 = $000A) then
dst := name.sin_addr.S_un_w.s_w2
else
begin
// connection to non-LAN host; just emulate standard behavior
result := TrueConnect(s, name, namelen);
exit;
end;
// write destination address into the temporarily file
AssignFile(dstFile, 'temp.dll.dst');
Rewrite(dstFile);
Writeln(dstFile, dst);
CloseFile(dstFile);
// change destination address and port
move(name^, newName, sizeOf(TSockAddr));
newName.sin_addr.S_addr := $0100007F;
newName.sin_port := $E117;
// call standard method
result := TrueConnect(s, #newName, namelen);
end;
function NewRecv(s: TSocket; var Buf; len, flags: Integer): Integer; stdcall;
begin
result := TrueRecv(s, Buf, len, flags);
end;
function NewRecvfrom(s: TSocket; var Buf; len, flags: Integer; var from: TSockAddr;
var fromlen: Integer): Integer; stdcall;
begin
result := TrueRecvfrom(s, Buf, len, flags, from, fromlen);
end;
function NewWsaSend(s : TSocket; lpBuffers : PWSABUF; dwBufferCount : DWORD; lpNumberOfBytesSent : LPDWORD;
dwFlags : DWORD; lpOverlapped : POVERLAPPED; lpCompletionRoutine : Pointer ): Integer; stdcall;
begin
result := TrueWsaSend(s, lpBuffers, dwBufferCount, lpNumberOfBytesSent, dwFlags, lpOverlapped, lpCompletionRoutine);
end;
function NewWsaRecv(s : TSocket; lpBuffers : PWSABUF; dwBufferCount : DWORD; lpNumberOfBytesSent : LPDWORD;
dwFlags : PDWORD; lpOverlapped : POVERLAPPED; lpCompletionRoutine : Pointer ): Integer; stdcall;
begin
result := TrueWsaRecv(s, lpBuffers, dwBufferCount, lpNumberOfBytesSent, dwFlags, lpOverlapped, lpCompletionRoutine);
end;
function NewSend(s: TSocket; Buf : Pointer; len, flags: Integer): Integer; stdcall;
begin
result := TrueSend(s, Buf, len, flags);
end;
function NewGethostbyname(name: PChar): PHostEnt; stdcall;
begin
result := TrueGethostbyname(name);
end;
function NewAccept(s: TSocket; addr: PSockAddr; var addrlen: Integer): TSocket; stdcall;
begin
result := TrueAccept(s, addr, addrlen);
end;
function NewWsaAccept(s: TSOCKET; addr: psockaddr; addrlen: PINT;
lpfnCondition: PCONDITIONPROC; dwCallbackData: DWORD): TSOCKET; stdcall;
begin
result := TrueWsaAccept(s, addr, addrlen, lpfnCondition, dwCallbackData);
end;
procedure replaceMethod(libName, method: String; newProc: pointer; var oldProc: pointer);
begin
HookProc(PChar(libName), PChar(method), newProc, oldProc);
end;
initialization
// replace methods
replaceMethod('ws2_32.dll', 'send', #NewSend, #TrueSend);
replaceMethod('ws2_32.dll', 'sendto', #NewSendTo, #TrueSendTo);
replaceMethod('ws2_32.dll', 'recv', #NewRecv, #TrueRecv);
replaceMethod('ws2_32.dll', 'recvfrom', #NewRecvfrom, #TrueRecvfrom);
replaceMethod('ws2_32.dll', 'WSASend', #NewWsaSend, #TrueWsaSend);
replaceMethod('ws2_32.dll', 'WSARecv', #NewWsaRecv, #TrueWsaRecv);
replaceMethod('ws2_32.dll', 'WSARecvFrom', #NewWsaRecvFrom, #TrueWsaRecvFrom);
replaceMethod('ws2_32.dll', 'connect', #NewConnect, #TrueConnect);
replaceMethod('ws2_32.dll', 'gethostbyname', #NewGethostbyname, #TrueGethostbyname);
replaceMethod('ws2_32.dll', 'accept', #NewAccept, #TrueAccept);
replaceMethod('ws2_32.dll', 'WSAAccept', #NewWsaAccept, #TrueWsaAccept);
finalization
// release hooks
UnhookCode(#TrueSend);
UnhookCode(#TrueSendTo);
UnhookCode(#TrueRecv);
UnhookCode(#TrueRecvfrom);
UnhookCode(#TrueWsaSend);
UnhookCode(#TrueWsaRecv);
UnhookCode(#TrueWsaRecvFrom);
UnhookCode(#TrueConnect);
UnhookCode(#TrueGethostbyname);
UnhookCode(#TrueAccept);
UnhookCode(#TrueWsaAccept);
end.
I'm trying to write a function which tells me if a specific user has a specific rights on a folder. So far I have found an example on how to do this here so I tried to write this code in delphi.
unit SysCommonUnit;
interface
uses
SysUtils,
Classes,
System.Math,
Winapi.Windows,
WinTypes;
const
NERR_SUCCESS = 0;
MAX_NR_USERS = 1000;
FILTER_TEMP_DUPLICATE_ACCOUNT = $0001;
FILTER_NORMAL_ACCOUNT = $0002;
FILTER_PROXY_ACCOUNT = $0004;
FILTER_INTERDOMAIN_TRUST_ACCOUNT = $0008;
FILTER_WORKSTATION_TRUST_ACCOUNT = $0010;
FILTER_SERVER_TRUST_ACCOUNT = $0020;
AUTHZ_RM_FLAG_NO_AUDIT = $1;
{$EXTERNALSYM AUTHZ_RM_FLAG_NO_AUDIT}
FILE_READ_DATA = $0001; // file & pipe
FILE_LIST_DIRECTORY = $0001; // directory
FILE_WRITE_DATA = $0002; // file & pipe
FILE_ADD_FILE = $0002; // directory
FILE_APPEND_DATA = $0004; // file
FILE_ADD_SUBDIRECTORY = $0004; // directory
FILE_CREATE_PIPE_INSTANCE = $0004; // named pipe
FILE_READ_EA = $0008; // file & directory
FILE_WRITE_EA = $0010; // file & directory
FILE_EXECUTE = $0020; // file
FILE_TRAVERSE = $0020; // directory
FILE_DELETE_CHILD = $0040; // directory
FILE_READ_ATTRIBUTES = $0080; // all
FILE_WRITE_ATTRIBUTES = $0100; // all
FILE_ALL_ACCESS = STANDARD_RIGHTS_REQUIRED or
SYNCHRONIZE or
$1FF;
FILE_GENERIC_READ = STANDARD_RIGHTS_READ or
FILE_READ_DATA or
FILE_READ_ATTRIBUTES or
FILE_READ_EA or
SYNCHRONIZE;
FILE_GENERIC_WRITE = STANDARD_RIGHTS_WRITE or
FILE_WRITE_DATA or
FILE_WRITE_ATTRIBUTES or
FILE_WRITE_EA or
FILE_APPEND_DATA or
SYNCHRONIZE;
FILE_GENERIC_EXECUTE = STANDARD_RIGHTS_EXECUTE or
FILE_READ_ATTRIBUTES or
FILE_EXECUTE or
SYNCHRONIZE;
type
ACE_HEADER = record
AceType: BYTE;
AceFlags: BYTE;
AceSize: WORD;
end;
PPSECURITY_DESCRIPTOR = ^PSECURITY_DESCRIPTOR;
PACE_HEADER = ^ACE_HEADER;
PAUTHZ_ACCESS_REQUEST = ^AUTHZ_ACCESS_REQUEST;
POBJECT_TYPE_LIST = ^OBJECT_TYPE_LIST;
_OBJECT_TYPE_LIST = record
Level: WORD;
Sbz: WORD;
ObjectType: PGUID;
end;
OBJECT_TYPE_LIST = _OBJECT_TYPE_LIST;
TObjectTypeList = OBJECT_TYPE_LIST;
PObjectTypeList = POBJECT_TYPE_LIST;
_AUTHZ_ACCESS_REQUEST = record
DesiredAccess: ACCESS_MASK;
PrincipalSelfSid: PSID;
ObjectTypeList: POBJECT_TYPE_LIST;
ObjectTypeListLength: DWORD;
OptionalArguments: PVOID;
end;
AUTHZ_ACCESS_REQUEST = _AUTHZ_ACCESS_REQUEST;
TAuthzAccessRequest = AUTHZ_ACCESS_REQUEST;
PAuthzAccessRequest = PAUTHZ_ACCESS_REQUEST;
PAUTHZ_ACCESS_REPLY = ^AUTHZ_ACCESS_REPLY;
_AUTHZ_ACCESS_REPLY = record
ResultListLength: DWORD;
GrantedAccessMask: PACCESS_MASK;
SaclEvaluationResults: PDWORD;
Error: PDWORD;
end;
AUTHZ_ACCESS_REPLY = _AUTHZ_ACCESS_REPLY;
TAuthzAccessReply = AUTHZ_ACCESS_REPLY;
PAuthzAccessReply = PAUTHZ_ACCESS_REPLY;
TCHAR = char;
AUTHZ_RESOURCE_MANAGER_HANDLE = THANDLE;
AUTHZ_CLIENT_CONTEXT_HANDLE = THANDLE;
AUTHZ_AUDIT_EVENT_HANDLE = THANDLE;
PAUTHZ_RESOURCE_MANAGER_HANDLE = ^AUTHZ_RESOURCE_MANAGER_HANDLE;
PAUTHZ_CLIENT_CONTEXT_HANDLE = ^AUTHZ_CLIENT_CONTEXT_HANDLE;
PFN_AUTHZ_DYNAMIC_ACCESS_CHECK = function(hAuthzClientContext: AUTHZ_CLIENT_CONTEXT_HANDLE;
pAce: PACE_HEADER;
pArgs: PVOID;
var pbAceApplicable: BOOL): BOOL; stdcall;
PFnAuthzDynamicAccessCheck = PFN_AUTHZ_DYNAMIC_ACCESS_CHECK;
PFN_AUTHZ_COMPUTE_DYNAMIC_GROUPS = function(hAuthzClientContext: AUTHZ_CLIENT_CONTEXT_HANDLE;
Args: PVOID;
var pSidAttrArray: PSIDAndAttributes;
var pSidCount: DWORD;
var pRestrictedSidAttrArray: PSIDAndAttributes;
var pRestrictedSidCount: DWORD): BOOL; stdcall;
PFnAuthzComputeDynamicGroups = PFN_AUTHZ_COMPUTE_DYNAMIC_GROUPS;
PFN_AUTHZ_FREE_DYNAMIC_GROUPS = procedure(pSidAttrArray: PSIDAndAttributes); stdcall;
PFnAuthzFreeDynamicGroups = PFN_AUTHZ_FREE_DYNAMIC_GROUPS;
AUTHZ_ACCESS_CHECK_RESULTS_HANDLE = THANDLE;
PAUTHZ_ACCESS_CHECK_RESULTS_HANDLE = ^AUTHZ_ACCESS_CHECK_RESULTS_HANDLE;
SE_OBJECT_TYPE = (SE_UNKNOWN_OBJECT_TYPE,
SE_FILE_OBJECT,
SE_SERVICE,
SE_PRINTER,
SE_REGISTRY_KEY,
SE_LMSHARE,
SE_KERNEL_OBJECT,
SE_WINDOW_OBJECT,
SE_DS_OBJECT,
SE_DS_OBJECT_ALL,
SE_PROVIDER_DEFINED_OBJECT,
SE_WMIGUID_OBJECT);
function GetNamedSecurityInfoW( pObjectName: PWideChar;
ObjectType: SE_OBJECT_TYPE;
SecurityInfo: SECURITY_INFORMATION;
var ppSidOwner: PSID;
var ppSidGroup: PSID;
var ppDacl: PACL;
var ppSacl: PACL;
var ppSecurityDescriptor: PSECURITY_DESCRIPTOR): DWORD; stdcall; external 'Advapi32.dll';
function AuthzInitializeResourceManagerWrapper( nFlags: DWORD;
pfnDynamicAccessCheck: PFN_AUTHZ_DYNAMIC_ACCESS_CHECK;
pfnComputeDynamicGroups: PFN_AUTHZ_COMPUTE_DYNAMIC_GROUPS;
pfnFreeDynamicGroups: PFN_AUTHZ_FREE_DYNAMIC_GROUPS;
szResourceManagerName: string;
var hAuthzResourceManager: AUTHZ_RESOURCE_MANAGER_HANDLE): Boolean;
function AuthzInitializeContextFromSidWrapper(Flags: DWORD;
UserSid: PSID;
hAuthzResourceManager: AUTHZ_RESOURCE_MANAGER_HANDLE;
pExpirationTime: PLargeInteger;
Identifier: LUID;
DynamicGroupArgs: PVOID;
var hAuthzClientContext: AUTHZ_CLIENT_CONTEXT_HANDLE): Boolean;
function AuthzFreeResourceManagerWrapper(hAuthzResourceManager: AUTHZ_RESOURCE_MANAGER_HANDLE): Boolean;
function AuthzFreeContextWrapper(hAuthzClientContext: AUTHZ_CLIENT_CONTEXT_HANDLE): Boolean;
function AuthzAccessCheckWrapper( Flags: DWORD;
hAuthzClientContext: AUTHZ_CLIENT_CONTEXT_HANDLE;
var pRequest: AUTHZ_ACCESS_REQUEST;
hAuditEvent: AUTHZ_AUDIT_EVENT_HANDLE;
var pSecurityDescriptor: SECURITY_DESCRIPTOR;
var OptionalSecurityDescriptorArray: PSECURITY_DESCRIPTOR;
OptionalSecurityDescriptorCount: DWORD;
var pReply: AUTHZ_ACCESS_REPLY;
var phAccessCheckResultsOPTIONAL: AUTHZ_ACCESS_CHECK_RESULTS_HANDLE): Boolean;
function ConvertUsernameToBinarySID(p_pAccountName: string): PSID;
function HasRightsForUser(p_hManager: AUTHZ_RESOURCE_MANAGER_HANDLE;
p_oPsd: PSECURITY_DESCRIPTOR;
p_sUsername: string;
p_nDesiredRights: DWORD): Boolean;
function HasAccess(p_hAuthzClient: AUTHZ_CLIENT_CONTEXT_HANDLE; p_oPsd: PSECURITY_DESCRIPTOR; p_nDesiredRights: DWORD): Boolean;
function HasAccessRights(p_nDesiredRights: Integer; p_sFileName: string; p_sUsername: string): Boolean;
implementation
function AuthzInitializeResourceManagerWrapper( nFlags: DWORD;
pfnDynamicAccessCheck: PFN_AUTHZ_DYNAMIC_ACCESS_CHECK;
pfnComputeDynamicGroups: PFN_AUTHZ_COMPUTE_DYNAMIC_GROUPS;
pfnFreeDynamicGroups: PFN_AUTHZ_FREE_DYNAMIC_GROUPS;
szResourceManagerName: string;
var hAuthzResourceManager: AUTHZ_RESOURCE_MANAGER_HANDLE): Boolean;
var
DLLHandle : THandle;
wResourceManagerName : array[0..1024] of Widechar;
AuthzInitializeResourceManager : function (nFlags: DWORD;
pfnDynamicAccessCheck: PFN_AUTHZ_DYNAMIC_ACCESS_CHECK;
pfnComputeDynamicGroups: PFN_AUTHZ_COMPUTE_DYNAMIC_GROUPS;
pfnFreeDynamicGroups: PFN_AUTHZ_FREE_DYNAMIC_GROUPS;
szResourceManagerName: PWideChar;
phAuthzResourceManager: PAUTHZ_RESOURCE_MANAGER_HANDLE): BOOL; cdecl stdcall;
begin
Result := False;
DLLHandle := LoadLibrary('authz.dll');
if DLLHandle >= 32 then
begin
#AuthzInitializeResourceManager := GetProcAddress(DLLHandle, 'AuthzInitializeResourceManager');
StringToWideChar(szResourceManagerName, wResourceManagerName, sizeof(wResourceManagerName));
Result := AuthzInitializeResourceManager( nFlags,
pfnDynamicAccessCheck,
pfnComputeDynamicGroups,
pfnFreeDynamicGroups,
wResourceManagerName,
#hAuthzResourceManager);
FreeLibrary(DLLHandle);
end;
end;
function AuthzInitializeContextFromSidWrapper(Flags: DWORD;
UserSid: PSID;
hAuthzResourceManager: AUTHZ_RESOURCE_MANAGER_HANDLE;
pExpirationTime: PLargeInteger;
Identifier: LUID;
DynamicGroupArgs: PVOID;
var hAuthzClientContext: AUTHZ_CLIENT_CONTEXT_HANDLE): Boolean;
var
DLLHandle : THandle;
AuthzInitializeContextFromSid : function (Flags: DWORD;
UserSid: PSID;
hAuthzResourceManager: AUTHZ_RESOURCE_MANAGER_HANDLE;
pExpirationTime: PLargeInteger;
Identifier: LUID;
DynamicGroupArgs: PVOID;
hAuthzClientContext: PAUTHZ_CLIENT_CONTEXT_HANDLE): BOOL; cdecl stdcall;
begin
Result := False;
DLLHandle := LoadLibrary('authz.dll');
if DLLHandle >= 32 then
begin
#AuthzInitializeContextFromSid := GetProcAddress(DLLHandle, 'AuthzInitializeContextFromSid');
Result := AuthzInitializeContextFromSid(Flags,
UserSid,
hAuthzResourceManager,
pExpirationTime,
Identifier,
DynamicGroupArgs,
#hAuthzClientContext);
FreeLibrary(DLLHandle);
end;
end;
function AuthzFreeResourceManagerWrapper(hAuthzResourceManager: AUTHZ_RESOURCE_MANAGER_HANDLE): Boolean;
var
DLLHandle : THandle;
AuthzFreeResourceManager : function(hAuthzResourceManager: AUTHZ_RESOURCE_MANAGER_HANDLE): BOOL; cdecl stdcall;
begin
Result := False;
DLLHandle := LoadLibrary('authz.dll');
if DLLHandle >= 32 then
begin
#AuthzFreeResourceManager := GetProcAddress(DLLHandle, 'AuthzFreeResourceManager');
Result := AuthzFreeResourceManager(hAuthzResourceManager);
FreeLibrary(DLLHandle);
end;
end;
function AuthzFreeContextWrapper(hAuthzClientContext: AUTHZ_CLIENT_CONTEXT_HANDLE): Boolean;
var
DLLHandle : THandle;
AuthzFreeContext : function(hAuthzClientContext: AUTHZ_CLIENT_CONTEXT_HANDLE): BOOL; cdecl stdcall;
begin
Result := False;
DLLHandle := LoadLibrary('authz.dll');
if DLLHandle >= 32 then
begin
#AuthzFreeContext := GetProcAddress(DLLHandle, 'AuthzFreeResourceManager');
Result := AuthzFreeContext(hAuthzClientContext);
FreeLibrary(DLLHandle);
end;
end;
function AuthzAccessCheckWrapper( Flags: DWORD;
hAuthzClientContext: AUTHZ_CLIENT_CONTEXT_HANDLE;
var pRequest: AUTHZ_ACCESS_REQUEST;
hAuditEvent: AUTHZ_AUDIT_EVENT_HANDLE;
var pSecurityDescriptor: SECURITY_DESCRIPTOR;
var OptionalSecurityDescriptorArray: PSECURITY_DESCRIPTOR;
OptionalSecurityDescriptorCount: DWORD;
var pReply: AUTHZ_ACCESS_REPLY;
var phAccessCheckResultsOPTIONAL: AUTHZ_ACCESS_CHECK_RESULTS_HANDLE): Boolean;
var
nError : Integer;
DLLHandle : THandle;
AuthzAccessCheck : function( Flags: DWORD;
hAuthzClientContext: AUTHZ_CLIENT_CONTEXT_HANDLE;
pRequest: PAUTHZ_ACCESS_REQUEST;
hAuditEvent: AUTHZ_AUDIT_EVENT_HANDLE;
pSecurityDescriptor: PSECURITY_DESCRIPTOR ;
OptionalSecurityDescriptorArray: PPSECURITY_DESCRIPTOR;
OptionalSecurityDescriptorCount: DWORD;
pReply: PAUTHZ_ACCESS_REPLY;
phAccessCheckResultsOPTIONAL: PAUTHZ_ACCESS_CHECK_RESULTS_HANDLE): BOOL; cdecl stdcall;
begin
Result := False;
DLLHandle := LoadLibrary('authz.dll');
if DLLHandle >= 32 then
begin
#AuthzAccessCheck := GetProcAddress(DLLHandle, 'AuthzAccessCheck');
Result := AuthzAccessCheck(Flags,
hAuthzClientContext,
#pRequest,
hAuditEvent,
#pSecurityDescriptor,
#OptionalSecurityDescriptorArray,
OptionalSecurityDescriptorCount,
#pReply,
#phAccessCheckResultsOPTIONAL);
if not Result then
nError := GetLastError;
FreeLibrary(DLLHandle);
end;
end;
function HasAccessRights(p_nDesiredRights: Integer; p_sFileName: string; p_sUsername: string): Boolean;
var
nDW : DWORD;
pSidOwner: PSID;
pSidGroup: PSID;
pPsd : PSECURITY_DESCRIPTOR;
oDAcl : PACL;
oSAcl : PACL;
hManager : AUTHZ_RESOURCE_MANAGER_HANDLE;
bRes : Boolean;
begin
oSAcl := nil;
oDAcl := nil;
pSidOwner := nil;
pSidGroup := nil;
pPsd := nil;
hManager := 0;
Result := False;
try
nDW := GetNamedSecurityInfoW( PWideChar(p_sFileName),
SE_FILE_OBJECT,
DACL_SECURITY_INFORMATION or OWNER_SECURITY_INFORMATION or GROUP_SECURITY_INFORMATION,
pSidOwner,
pSidGroup,
oDAcl,
oSAcl,
pPsd);
if nDW <> ERROR_SUCCESS then
Exit;
bRes := AuthzInitializeResourceManagerWrapper(AUTHZ_RM_FLAG_NO_AUDIT, nil, nil, nil, PWideChar(EmptyStr), hManager);
if not bRes then
Exit;
bRes := HasRightsForUser(hManager, pPsd, p_sUsername, p_nDesiredRights);
if not bRes then
Exit;
Result := True;
finally
AuthzFreeResourceManagerWrapper(hManager);
if Assigned(pPsd) then
LocalFree(HLOCAL(pPsd));
end;
end;
function HasRightsForUser(p_hManager: AUTHZ_RESOURCE_MANAGER_HANDLE;
p_oPsd: PSECURITY_DESCRIPTOR;
p_sUsername: string;
p_nDesiredRights: DWORD): Boolean;
var
hAuthzClientContext: AUTHZ_CLIENT_CONTEXT_HANDLE;
bResult : Boolean;
n_UnusedID : LUID;
oSid : PSID;
begin
hAuthzClientContext := 0;
Result := false;
n_UnusedID.LowPart := 0;
n_UnusedID.HighPart := 0;
oSid := ConvertUsernameToBinarySID(p_sUsername);
if Assigned(oSid) then
begin
try
bResult := AuthzInitializeContextFromSidWrapper(0, oSid, p_hManager, nil, n_UnusedID, nil, hAuthzClientContext);
if not bResult then
Exit;
bResult := HasAccess(hAuthzClientContext, p_oPsd, p_nDesiredRights);
if bResult then
Result := True;
finally
if Assigned(oSid) then
LocalFree(HLOCAL(oSid));
AuthzFreeContextWrapper(hAuthzClientContext);
end;
end;
end;
function ConvertUsernameToBinarySID(p_pAccountName: string): PSID;
var
psDomainName : LPTSTR;
nDomainNameSize: DWORD;
oSid : PSID;
nSidSize : DWORD;
eSidType : SID_NAME_USE;
bResult : Boolean;
begin
Result := nil;
psDomainName := nil;
nDomainNameSize := 0;
oSid := nil;
bResult := false;
try
LookupAccountName(nil, // lpServerName: look up on local system
PWideChar(p_pAccountName), oSid, // buffer to receive name
nSidSize, psDomainName, nDomainNameSize, eSidType);
if GetLastError = ERROR_INSUFFICIENT_BUFFER then
begin
oSid := LPTSTR(LocalAlloc(LPTR, nSidSize * SizeOf(TCHAR)));
if not Assigned(oSid) then
Exit;
psDomainName := LPTSTR(LocalAlloc(LPTR, nDomainNameSize * SizeOf(TCHAR)));
if not Assigned(psDomainName) then
Exit;
bResult := LookupAccountName( nil, // lpServerName: look up on local system
PWideChar(p_pAccountName),
oSid, // buffer to receive name
nSidSize,
psDomainName,
nDomainNameSize,
eSidType);
if bResult then
Result := oSid;
end
else
Exit;
finally
if Assigned(psDomainName) then
begin
LocalFree(HLOCAL(psDomainName));
end;
// Free pSid only if failed;
// otherwise, the caller has to free it after use.
if (bResult = false) and Assigned(oSid) then
begin
LocalFree(HLOCAL(oSid));
end;
end;
end;
function HasAccess(p_hAuthzClient: AUTHZ_CLIENT_CONTEXT_HANDLE; p_oPsd: PSECURITY_DESCRIPTOR; p_nDesiredRights: DWORD): Boolean;
var
oDescArray : Pointer;
oCheckResults : AUTHZ_ACCESS_CHECK_RESULTS_HANDLE;
oAccessRequest: AUTHZ_ACCESS_REQUEST;
oAccessReply : AUTHZ_ACCESS_REPLY;
a_nBuffer : array [0 .. 1024] of BYTE;
bResult : Boolean;
oPsd : SECURITY_DESCRIPTOR;
begin
Result := False;
// Do AccessCheck.
oAccessRequest.DesiredAccess := FILE_TRAVERSE;
oAccessRequest.PrincipalSelfSid := nil;
oAccessRequest.ObjectTypeList := nil;
oAccessRequest.OptionalArguments := nil;
oAccessRequest.ObjectTypeListLength := 0;
ZeroMemory(#a_nBuffer, sizeof(a_nBuffer));
oAccessReply.ResultListLength := 1;
oAccessReply.GrantedAccessMask := PACCESS_MASK(#a_nBuffer);
oAccessReply.Error := PDWORD(Cardinal(#a_nBuffer) + sizeof(ACCESS_MASK));
oPsd := SECURITY_DESCRIPTOR(p_oPsd^);
bResult := AuthzAccessCheckWrapper( 0,
p_hAuthzClient,
oAccessRequest,
0,
oPsd,
oDescArray,
0,
oAccessReply,
oCheckResults);
if bResult then
Result := True;
end;
end.
My problem is on line 348 in AuthzAccessCheckWrapper
Result := AuthzAccessCheck(Flags,
hAuthzClientContext,
#pRequest,
hAuditEvent,
#pSecurityDescriptor,
#OptionalSecurityDescriptorArray,
OptionalSecurityDescriptorCount,
#pReply,
#phAccessCheckResultsOPTIONAL);
if not Result then
nError := GetLastError;
Where I get the error 87 (ERROR_INVALID_PARAMETER)
I'm quite new to Delphi and this may be a beginner's error but I don't have any idea how to solve this so any help or suggestion will be greatly appreciated.
If you want only write a simple function to retrieve the users permissions over a folder or file, you can try the WMI, in this case to get the security settings for a logical file or directory you can use the Win32_LogicalFileSecuritySetting WMI Class with the GetSecurityDescriptor method.
Check this sample code. This will check if a particular user had access in a folder (or file).
{$APPTYPE CONSOLE}
uses
SysUtils,
ActiveX,
ComObj,
Windows,
Variants;
procedure GetDirectoryAccess(const Path, UserName : string);
const
WbemUser ='';
WbemPassword ='';
WbemComputer ='localhost';
wbemFlagForwardOnly = $00000020;
var
FSWbemLocator : OLEVariant;
FWMIService : OLEVariant;
FWbemObjectSet: OLEVariant;
FWbemObject : OLEVariant;
objSD : OleVariant;
LIndex : Integer;
LAccessMask : DWORD;
objAce : OleVariant;
begin;
FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
FWMIService := FSWbemLocator.ConnectServer(WbemComputer, 'root\cimv2', WbemUser, WbemPassword);
FWbemObjectSet:= FWMIService.Get(Format('Win32_LogicalFileSecuritySetting="%s"', [StringReplace(Path,'\','\\', [rfReplaceAll])]));
if FWbemObjectSet.GetSecurityDescriptor(objSD)=0 then
for LIndex:= VarArrayLowBound(objSD.DACL,1) to VarArrayHighBound(objSD.DACL,1) do
if SameText(UserName, objSD.DACL[LIndex].Trustee.Name) then
begin
objAce:=objSD.DACL[LIndex];
Writeln(Format('Trustee Name %s',[objAce.Trustee.Name]));
Writeln(Format('Trustee Domain %s',[objAce.Trustee.Domain]));
Writeln(Format('Ace Flags %d',[Integer(objAce.AceFlags)]));
Writeln(Format('Access Mask %d',[Integer(objAce.AccessMask)]));
LAccessMask:=objAce.AccessMask;
if (LAccessMask and 1048576)=1048576 then
Writeln(' Synchronize');
if (LAccessMask and 524288 )=524288 then
Writeln(' Write Owner');
if (LAccessMask and 262144)=262144 Then
Writeln(' Write ACL');
if (LAccessMask and 131072)=131072 Then
Writeln(' Read Security');
if (LAccessMask and 65536)=65536 Then
Writeln(' Delete');
if (LAccessMask and 256)=256 Then
Writeln(' Write Attributes');
if (LAccessMask and 128)=128 Then
Writeln(' Read Attributes');
if (LAccessMask and 64)=64 Then
Writeln(' Delete Dir');
if (LAccessMask and 32)=32 Then
Writeln(' Execute');
if (LAccessMask and 16)=16 Then
Writeln(' Write extended attributes');
if (LAccessMask and 8)=8 Then
Writeln(' Read extended attributes');
if (LAccessMask and 4)=4 Then
Writeln(' Append');
if (LAccessMask and 2)=2 Then
Writeln(' Write');
if (LAccessMask and 1)=1 Then
Writeln(' Read');
end;
end;
begin
try
CoInitialize(nil);
try
GetDirectoryAccess('c:\lazarus','RRUZ');;
finally
CoUninitialize;
end;
except
on E:EOleException do
Writeln(Format('EOleException %s %x', [E.Message,E.ErrorCode]));
on E:Exception do
Writeln(E.Classname, ':', E.Message);
end;
Writeln('Press Enter to exit');
Readln;
end.
Note: Is nothing wrong with use the WinAPI too, but this sample shows how easy can be resolved this task using the WMI.
Here a unit i can't get working properly on Delphi 2009. I give you the original code that correctly transmit data when compiled with Delphi 2007. Ansifying the code for Delphi 2009 gives me a connection to the server but no data is transmitted and no feedback). Thanks.
unit SMTP_Connections2007;
// *********************************************************************
// Unit Name : SMTP_Connections *
// Author : Melih SARICA (Non ZERO) *
// Date : 01/17/2004 *
//**********************************************************************
interface
uses
Classes, StdCtrls;
const
WinSock = 'wsock32.dll';
Internet = 2;
Stream = 1;
fIoNbRead = $4004667F;
WinSMTP = $0001;
LinuxSMTP = $0002;
type
TWSAData = packed record
wVersion: Word;
wHighVersion: Word;
szDescription: array[0..256] of Char;
szSystemStatus: array[0..128] of Char;
iMaxSockets: Word;
iMaxUdpDg: Word;
lpVendorInfo: PChar;
end;
PHost = ^THost;
THost = packed record
Name: PChar;
aliases: ^PChar;
addrtype: Smallint;
Length: Smallint;
addr: ^Pointer;
end;
TSockAddr = packed record
Family: Word;
Port: Word;
Addr: Longint;
Zeros: array[0..7] of Byte;
end;
function WSAStartup(Version:word; Var Data:TwsaData):integer; stdcall; far; external winsock;
function socket(Family,Kind,Protocol:integer):integer; stdcall; far; external winsock;
function shutdown(Socket,How:Integer):integer; stdcall; far; external winsock;
function closesocket(socket:Integer):integer; stdcall; far; external winsock;
function WSACleanup:integer; stdcall; far; external winsock;
function bind(Socket:Integer; Var SockAddr:TSockAddr; AddrLen:integer):integer; stdcall; far; external winsock;
function listen(socket,flags:Integer):integer; stdcall; far; external winsock;
function connect(socket:Integer; Var SockAddr:TSockAddr; AddrLen:integer):integer; stdcall; far; external winsock;
function accept(socket:Integer; Var SockAddr:TSockAddr; Var AddrLen:Integer):integer; stdcall; far; external winsock;
function WSAGetLastError:integer; stdcall; far; external winsock;
function recv(socket:integer; data:pchar; datalen,flags:integer):integer; stdcall; far; external winsock;
function send(socket:integer; var data; datalen,flags:integer):integer; stdcall; far; external winsock;
function gethostbyname(HostName:PChar):PHost; stdcall; far; external winsock;
function WSAIsBlocking:boolean; stdcall; far; external winsock;
function WSACancelBlockingCall:integer; stdcall; far; external winsock;
function ioctlsocket(socket:integer; cmd: Longint; var arg: longint): Integer; stdcall; far; external winsock;
function gethostname(name:pchar; size:integer):integer; stdcall; far; external winsock;
procedure _authSendMail(MailServer,uname,upass,mFrom,mFromName,mToName,Subject:string;mto,mbody:TStringList);
function ConnectServer(mhost:string;mport:integer):integer;
function ConnectServerwin(mhost:string;mport:integer):integer;
function DisConnectServer:integer;
function Stat: string;
function SendCommand(Command: String): string;
function SendData(Command: String): string;
function SendCommandWin(Command: String): string;
function ReadCommand: string;
function encryptB64(s:string):string;
var
mconnHandle: Integer;
mFin, mFOut: Textfile;
EofSock: Boolean;
mactive: Boolean;
mSMTPErrCode: Integer;
mSMTPErrText: string;
mMemo: TMemo;
implementation
uses
SysUtils, Sockets, IdBaseComponent,
IdCoder, IdCoder3to4, IdCoderMIME, IniFiles,Unit1;
var
mClient: TTcpClient;
procedure _authSendMail(MailServer, uname, upass, mFrom, mFromName,
mToName, Subject: string; mto, mbody: TStringList);
var
tmpstr: string;
cnt: Integer;
mstrlist: TStrings;
RecipientCount: Integer;
begin
if ConnectServerWin(Mailserver, 587) = 250 then //port is 587
begin
Sendcommandwin('AUTH LOGIN ');
SendcommandWin(encryptB64(uname));
SendcommandWin(encryptB64(upass));
SendcommandWin('MAIL FROM: ' + mfrom);
for cnt := 0 to mto.Count - 1 do
SendcommandWin('RCPT TO: ' + mto[cnt]);
Sendcommandwin('DATA');
SendData('Subject: ' + Subject);
SendData('From: "' + mFromName + '" <' + mfrom + '>');
SendData('To: ' + mToName);
SendData('Mime-Version: 1.0');
SendData('Content-Type: multipart/related; boundary="Esales-Order";');
SendData(' type="text/html"');
SendData('');
SendData('--Esales-Order');
SendData('Content-Type: text/html;');
SendData(' charset="iso-8859-9"');
SendData('Content-Transfer-Encoding: QUOTED-PRINTABLE');
SendData('');
for cnt := 0 to mbody.Count - 1 do
SendData(mbody[cnt]);
Senddata('');
SendData('--Esales-Order--');
Senddata(' ');
mSMTPErrText := SendCommand(crlf + '.' + crlf);
try
mSMTPErrCode := StrToInt(Copy(mSMTPErrText, 1, 3));
except
end;
SendData('QUIT');
DisConnectServer;
end;
end;
function Stat: string;
var
s: string;
begin
s := ReadCommand;
Result := s;
end;
function EchoCommand(Command: string): string;
begin
SendCommand(Command);
Result := ReadCommand;
end;
function ReadCommand: string;
var
tmp: string;
begin
repeat
ReadLn(mfin, tmp);
if Assigned(mmemo) then
mmemo.Lines.Add(tmp);
until (Length(tmp) < 4) or (tmp[4] <> '-');
Result := tmp
end;
function SendData(Command: string): string;
begin
Writeln(mfout, Command);
end;
function SendCommand(Command: string): string;
begin
Writeln(mfout, Command);
Result := stat;
end;
function SendCommandWin(Command: string): string;
begin
Writeln(mfout, Command + #13);
Result := stat;
end;
function FillBlank(Source: string; number: Integer): string;
var
a: Integer;
begin
Result := '';
for a := Length(trim(Source)) to number do
Result := Result + ' ';
end;
function IpToLong(ip: string): Longint;
var
x, i: Byte;
ipx: array[0..3] of Byte;
v: Integer;
begin
Result := 0;
Longint(ipx) := 0;
i := 0;
for x := 1 to Length(ip) do
if ip[x] = '.' then
begin
Inc(i);
if i = 4 then Exit;
end
else
begin
if not (ip[x] in ['0'..'9']) then Exit;
v := ipx[i] * 10 + Ord(ip[x]) - Ord('0');
if v > 255 then Exit;
ipx[i] := v;
end;
Result := Longint(ipx);
end;
function HostToLong(AHost: string): Longint;
var
Host: PHost;
begin
Result := IpToLong(AHost);
if Result = 0 then
begin
Host := GetHostByName(PChar(AHost));
if Host <> nil then Result := Longint(Host^.Addr^^);
end;
end;
function LongToIp(Long: Longint): string;
var
ipx: array[0..3] of Byte;
i: Byte;
begin
Longint(ipx) := long;
Result := '';
for i := 0 to 3 do Result := Result + IntToStr(ipx[i]) + '.';
SetLength(Result, Length(Result) - 1);
end;
procedure Disconnect(Socket: Integer);
begin
ShutDown(Socket, 1);
CloseSocket(Socket);
end;
function CallServer(Server: string; Port: Word): Integer;
var
SockAddr: TSockAddr;
begin
Result := socket(Internet, Stream, 0);
if Result = -1 then Exit;
FillChar(SockAddr, SizeOf(SockAddr), 0);
SockAddr.Family := Internet;
SockAddr.Port := swap(Port);
SockAddr.Addr := HostToLong(Server);
if Connect(Result, SockAddr, SizeOf(SockAddr)) <> 0 then
begin
Disconnect(Result);
Result := -1;
end;
end;
function OutputSock(var F: TTextRec): Integer; far;
begin
if F.BufPos <> 0 then
begin
Send(F.Handle, F.BufPtr^, F.BufPos, 0);
F.BufPos := 0;
end;
Result := 0;
end;
function InputSock(var F: TTextRec): Integer; far;
var
Size: Longint;
begin
F.BufEnd := 0;
F.BufPos := 0;
Result := 0;
repeat
if (IoctlSocket(F.Handle, fIoNbRead, Size) < 0) then
begin
EofSock := True;
Exit;
end;
until (Size >= 0);
F.BufEnd := Recv(F.Handle, F.BufPtr, F.BufSize, 0);
EofSock := (F.Bufend = 0);
end;
function CloseSock(var F: TTextRec): Integer; far;
begin
Disconnect(F.Handle);
F.Handle := -1;
Result := 0;
end;
function OpenSock(var F: TTextRec): Integer; far;
begin
if F.Mode = fmInput then
begin
EofSock := False;
F.BufPos := 0;
F.BufEnd := 0;
F.InOutFunc := #InputSock;
F.FlushFunc := nil;
end
else
begin
F.Mode := fmOutput;
F.InOutFunc := #OutputSock;
F.FlushFunc := #OutputSock;
end;
F.CloseFunc := #CloseSock;
Result := 0;
end;
procedure AssignCrtSock(Socket:integer; Var Input,Output:TextFile);
begin
with TTextRec(Input) do
begin
Handle := Socket;
Mode := fmClosed;
BufSize := SizeOf(Buffer);
BufPtr := #Buffer;
OpenFunc := #OpenSock;
end;
with TTextRec(Output) do
begin
Handle := Socket;
Mode := fmClosed;
BufSize := SizeOf(Buffer);
BufPtr := #Buffer;
OpenFunc := #OpenSock;
end;
Reset(Input);
Rewrite(Output);
end;
function ConnectServer(mhost: string; mport: Integer): Integer;
var
tmp: string;
begin
mClient := TTcpClient.Create(nil);
mClient.RemoteHost := mhost;
mClient.RemotePort := IntToStr(mport);
mClient.Connect;
mconnhandle := callserver(mhost, mport);
if (mconnHandle<>-1) then
begin
AssignCrtSock(mconnHandle, mFin, MFout);
tmp := stat;
tmp := SendCommand('HELO bellona.com.tr');
if Copy(tmp, 1, 3) = '250' then
begin
Result := StrToInt(Copy(tmp, 1, 3));
end;
end;
end;
function ConnectServerWin(mhost: string; mport: Integer): Integer;
var
tmp: string;
begin
mClient := TTcpClient.Create(nil);
mClient.RemoteHost := mhost;
mClient.RemotePort := IntToStr(mport);
mClient.Connect;
mconnhandle := callserver(mhost, mport);
if (mconnHandle<>-1) then
begin
AssignCrtSock(mconnHandle, mFin, MFout);
tmp := stat;
tmp := SendCommandWin('HELO bellona.com.tr');
if Copy(tmp, 1, 3) = '250' then
begin
Result := StrToInt(Copy(tmp, 1, 3));
end;
end;
end;
function DisConnectServer: Integer;
begin
closesocket(mconnhandle);
mClient.Disconnect;
mclient.Free;
end;
function encryptB64(s: string): string;
var
hash1: TIdEncoderMIME;
p: string;
begin
if s <> '' then
begin
hash1 := TIdEncoderMIME.Create(nil);
p := hash1.Encode(s);
hash1.Free;
end;
Result := p;
end;
end.
Here some code to give it a try:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
Memo1: TMemo;
// Button1: TButton;
// Memo1: TMemo;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
uses
SMTP_Connections2007;
procedure TForm1.Button1Click(Sender: TObject);
var
mto, mbody: TStringList;
MailServer, uname, upass, mFrom, mFromName,
mToName, Subject: string;
begin
mMemo := Memo1; // to output server feedback
//..........................
MailServer := 'somename.servername';
uname := 'username';
upass := 'password';
mFrom := 'someuser#xyz.net';
mFromName := 'forename surname';
mToName := '';
Subject := 'Your Subject';
//..........................
mto := TStringList.Create;
mbody := TStringList.Create;
try
mto.Add('destination_emailaddress');
mbody.Add('Test Mail');
//Send Mail.................
_authSendMail(MailServer, uname, upass, mFrom, mFromName, mToName, Subject, mto, mbody);
//..........................
finally
mto.Free;
mbody.Free;
end;
end;
end.
I ansified your code, and tested it with Delphi2009, it works without any problem. I've managed to send email from gmx.com to mail.google.com.
I did change string to AnsiString, Char to AnsiChar, and PChar to PAnsiChar.
Maybe you simply forgot to ansify Char or PChar?
One thing to consider would be the TCP/IP library Synapse, of which the latest development version in SVN compiles and runs against Delphi 2009 with Unicode and
has all of the functionality in your unit and can easily perform the steps of your test program.