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'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.
I have a function that shows a balloon tray in Windows it has a structure too like this:
const
NIF_INFO = $00000010;
NIIF_NONE = $00000000;
NIIF_INFO = $00000001;
NIIF_WARNING = $00000002;
NIIF_ERROR = $00000003;
type
BalloonData = record
cbSize: DWORD;
Wnd: HWND;
uID: UINT;
uFlags: UINT;
uCallbackMessage: UINT;
hIcon: HICON;
szTip: array[0..MAXCHAR] of AnsiChar;
dwState: DWORD;
dwStateMask: DWORD;
szInfo: array[0..MAXBYTE] of AnsiChar;
uTimeout: UINT;
szInfoTitle: array[0..63] of AnsiChar;
dwInfoFlags: DWORD;
end;
type
TBalloonTimeout = 2..30;
TBalloonIconType = (bitNone, bitInfo, bitWarning, bitError);
function DZBalloonTrayIcon(const Window: HWND; const IconID: Byte; const Timeout: TBalloonTimeout; const BalloonText, BalloonTitle: String; const BalloonIconType: TBalloonIconType): Boolean;
const
aBalloonIconTypes : array[TBalloonIconType] of Byte = (NIIF_NONE, NIIF_INFO, NIIF_WARNING, NIIF_ERROR);
var
TheBalloon : BalloonData;
begin
FillChar(TheBalloon, SizeOf(BalloonData), 0);
with TheBalloon do begin
cbSize := SizeOf(BalloonData);
Wnd := Window;
uID := IconID;
uFlags := NIF_INFO;
StrCopy(szInfo, pchar(BalloonText));
uTimeout := Timeout * 1000;
StrCopy(szInfoTitle, pchar(BalloonTitle));
dwInfoFlags := aBalloonIconTypes[BalloonIconType];
end;
Result := Shell_NotifyIcon(NIM_MODIFY, #TheBalloon);
end;
Usage :
procedure MakeBaloonTray;
var
TrayIconData : TNotifyIconData;
begin
DZBalloonTrayIcon(TrayIconData.Wnd, TrayIconData.uID, 2,'Test', 'Test', bitInfo);
end;
then I changed everything to WideString:
const
NIF_INFO = $00000010;
NIIF_NONE = $00000000;
NIIF_INFO = $00000001;
NIIF_WARNING = $00000002;
NIIF_ERROR = $00000003;
type
BalloonData = record
cbSize: DWORD;
Wnd: HWND;
uID: UINT;
uFlags: UINT;
uCallbackMessage: UINT;
hIcon: HICON;
szTip: array[0..MAXCHAR] of WideChar;
dwState: DWORD;
dwStateMask: DWORD;
szInfo: array[0..MAXBYTE] of WideChar;
uTimeout: UINT;
szInfoTitle: array[0..63] of WideChar;
dwInfoFlags: DWORD;
end;
type
TBalloonTimeout = 2..30;
TBalloonIconType = (bitNone, bitInfo, bitWarning, bitError);
function StrLCopyW(Dest, Source: PWideChar; MaxLen: Cardinal): PWideChar;
var
Count: Cardinal;
begin
Result := Dest;
Count := 0;
While (Count < MaxLen) and (Source^ <> #0) do begin
Dest^ := Source^;
Inc(Source);
Inc(Dest);
Inc(Count);
end;
Dest^ := #0;
end;
function StrCopyW(Dest, Source: PWideChar): PWideChar;
begin
Result := StrLCopyW(Dest, Source, MaxInt);
end;
function DZBalloonTrayIcon(const Window: HWND; const IconID: Byte; const Timeout: TBalloonTimeout; const BalloonText, BalloonTitle: WideString; const BalloonIconType: TBalloonIconType): Boolean;
const
aBalloonIconTypes : array[TBalloonIconType] of Byte = (NIIF_NONE, NIIF_INFO, NIIF_WARNING, NIIF_ERROR);
var
TheBalloon : BalloonData;
begin
FillChar(TheBalloon, SizeOf(BalloonData), 0);
with TheBalloon do begin
cbSize := SizeOf(BalloonData);
Wnd := Window;
uID := IconID;
uFlags := NIF_INFO;
StrCopyW(szInfo, pwidechar(BalloonText));
uTimeout := Timeout * 1000;
StrCopyW(szInfoTitle, pwidechar(BalloonTitle));
dwInfoFlags := aBalloonIconTypes[BalloonIconType];
end;
Result := Shell_NotifyIcon(NIM_MODIFY, #TheBalloon);
end;
I also tried:
procedure MakeBaloonTray;
var
TrayIconData : TNotifyIconData;
WideStringTest : WideString;
begin
WideStringTest := 'someunicodechars';
DZBalloonTrayIcon(TrayIconData.Wnd, TrayIconData.uID, 2,UTF8Encode(WideStringTest), UTF8Encode(WideStringTest), bitInfo);
end;
I thought Windows supports UTF8 in Balloons but I got question marks only.
Any Idea how to show a WideString/Unicode in a balloon?
Thank you for your help :)
You need to explicitly use the Shell_NotifyIconW (note the W) function and its related WideString structure, both defined in ShellAPI.pas.
How to download a file from internet with progress bar using threads in Delphi 2009/10 without Indy components?
I don't like to use indy either, my reason is it is too large. You could also use wininet. I have written the following for a small project required small app size.
unit wininetUtils;
interface
uses Windows, WinInet
{$IFDEF KOL}
,KOL
{$ELSE}
,Classes
{$ENDIF}
;
type
{$IFDEF KOL}
_STREAM = PStream;
_STRLIST = PStrList;
{$ELSE}
_STREAM = TStream;
_STRLIST = TStrings;
{$ENDIF}
TProgressCallback = function (ATotalSize, ATotalRead, AStartTime: DWORD): Boolean;
function DownloadToFile(const AURL: String; const AFilename: String;
const AAgent: String = '';
const AHeaders: _STRLIST = nil;
const ACallback: TProgressCallback = nil
) : LongInt;
function DownloadToStream(AURL: String; AStream: _STREAM;
const AAgent: String = '';
const AHeaders: _STRLIST = nil;
const ACallback: TProgressCallback = nil
) : LongInt;
implementation
function DownloadToFile(const AURL: String; const AFilename: String;
const AAgent: String = '';
const AHeaders: _STRLIST = nil;
const ACallback: TProgressCallback = nil
) : LongInt;
var
FStream: _STREAM;
begin
{$IFDEF KOL}
// fStream := NewFileStream(AFilename, ofCreateNew or ofOpenWrite);
// fStream := NewWriteFileStream(AFilename);
fStream := NewMemoryStream;
{$ELSE}
fStream := TFileStream.Create(AFilename, fmCreate);
// _STRLIST = TStrings;
{$ENDIF}
try
Result := DownloadToStream(AURL, FStream, AAgent, AHeaders, ACallback);
fStream.SaveToFile(AFilename, 0, fStream.Size);
finally
fStream.Free;
end;
end;
function StrToIntDef(const S: string; Default: Integer): Integer;
var
E: Integer;
begin
Val(S, Result, E);
if E <> 0 then Result := Default;
end;
function DownloadToStream(AURL: String; AStream: _STREAM;
const AAgent: String = '';
const AHeaders: _STRLIST = nil;
const ACallback: TProgressCallback = nil
) : LongInt;
function _HttpQueryInfo(AFile: HINTERNET; AInfo: DWORD): string;
var
infoBuffer: PChar;
dummy: DWORD;
err, bufLen: DWORD;
res: LongBool;
begin
Result := '';
bufLen := 0;
dummy := 0;
infoBuffer := nil;
res := HttpQueryInfo(AFile, AInfo, infoBuffer, bufLen, dummy);
if not res then
begin
// Probably working offline, or no internet connection.
err := GetLastError;
if err = ERROR_HTTP_HEADER_NOT_FOUND then
begin
// No headers
end else if err = ERROR_INSUFFICIENT_BUFFER then
begin
GetMem(infoBuffer, bufLen);
try
HttpQueryInfo(AFile, AInfo, infoBuffer, bufLen, dummy);
Result := infoBuffer;
finally
FreeMem(infoBuffer);
end;
end;
end;
end;
procedure ParseHeaders;
begin
end;
const
BUFFER_SIZE = 16184;
var
buffer: array[1..BUFFER_SIZE] of byte;
Totalbytes, Totalread, bytesRead, StartTime: DWORD;
hInet: HINTERNET;
reply: String;
hFile: HINTERNET;
begin
Totalread := 0;
Result := 0;
hInet := InternetOpen(PChar(AAgent), INTERNET_OPEN_TYPE_PRECONFIG, nil,nil,0);
if hInet = nil then Exit;
try
hFile := InternetOpenURL(hInet, PChar(AURL), nil, 0, 0, 0);
if hFile = nil then Exit;
StartTime := GetTickCount;
try
if AHeaders <> nil then
begin
AHeaders.Text := _HttpQueryInfo(hFile, HTTP_QUERY_RAW_HEADERS_CRLF);
ParseHeaders;
end;
Totalbytes := StrToIntDef(_HttpQueryInfo(hFile,
HTTP_QUERY_CONTENT_LENGTH), 0);
reply := _HttpQueryInfo(hFile, HTTP_QUERY_STATUS_CODE);
if reply = '200' then
// File exists, all ok.
result := 200
else if reply = '401' then
// Not authorised. Assume page exists,
// but we can't check it.
result := 401
else if reply = '404' then
// No such file.
result := 404
else if reply = '500' then
// Internal server error.
result := 500
else
Result := StrToIntDef(reply, 0);
repeat
InternetReadFile(hFile, #buffer, SizeOf(buffer), bytesRead);
if bytesRead > 0 then
begin
AStream.Write(buffer, bytesRead);
Inc(Totalread, bytesRead);
if Assigned(ACallback) then
begin
if not ACallback(TotalBytes, Totalread, StartTime) then Break;
end;
Sleep(10);
end;
// BlockWrite(localFile, buffer, bytesRead);
until bytesRead = 0;
finally
InternetCloseHandle(hFile);
end;
finally
InternetCloseHandle(hInet);
end;
end;
end.
This uses the clever internet suite to handle the download, I haven't so much as checked it in the IDE so I wouldn't expect it to compile and no doubt it's full of errors but it should be enough to get you started.
I don't know why you don't want to use Indy but I would strongly advise getting some components to help with the Http download... there really is no need to reinvent the wheel.
interface
type
TMyDownloadThread= Class(TThread)
private
FUrl: String;
FFileName: String;
FProgressHandle: HWND;
procedure GetFile (Url: String; Stream: TStream; ReceiveProgress: TclSocketProgressEvent);
procedure OnReceiveProgress(Sender: TObject; ABytesProceed, ATotalBytes: Integer);
procedure SetPercent(Percent: Double);
protected
Procedure Execute; Override;
public
Constructor Create(Url, FileName: String; PrograssHandle: HWND);
End;
implementation
constructor TMyDownloadThread.Create(Url, FileName: String; PrograssHandle: HWND);
begin
Inherited Create(True);
FUrl:= Url;
FFileName:= FileName;
FProgressHandle:= PrograssHandle;
Resume;
end;
procedure TMyDownloadThread.GetFile(Url: String; Stream: TStream; ReceiveProgress: TclSocketProgressEvent);
var
Http: TclHttp;
begin
Http := TclHTTP.Create(nil);
try
try
Http.OnReceiveProgress := ReceiveProgress;
Http.Get(Url, Stream);
except
end;
finally
Http.Free;
end;
end;
procedure TMyDownloadThread.OnReceiveProgress(Sender: TObject; ABytesProceed, ATotalBytes: Integer);
begin
SetPercent((ABytesProceed / ATotalBytes) * 100);
end;
procedure TMyDownloadThread.SetPercent(Percent: Double);
begin
PostMessage(FProgressHandle, AM_DownloadPercent, LowBytes(Percent), HighBytes(Percent));
end;
procedure TMyDownloadThread.Execute;
var
FileStream: TFileStream;
begin
FileStream := TFileStream.Create(FFileName, fmCreate);
try
GetFile(FUrl, FileStream, OnReceiveProgress);
finally
FileStream.Free;
end;
end;
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.