Delphi 11 and WinAPI.WinSvc (function EnumServiceState) - delphi

I used the code below to get a list of Windows services. It works well for Delphi 10.2.3 and earlier:
uses WinSvc;
//-------------------------------------
// Get a list of services
//
// return TRUE if successful
//
// sMachine:
// machine name, ie: \SERVER
// empty = local machine
//
// dwServiceType
// SERVICE_WIN32,
// SERVICE_DRIVER or
// SERVICE_TYPE_ALL
//
// dwServiceState
// SERVICE_ACTIVE,
// SERVICE_INACTIVE or
// SERVICE_STATE_ALL
//
// slServicesList
// TStrings variable to storage
//
function ServiceGetList(
sMachine : string;
dwServiceType,
dwServiceState : DWord;
slServicesList : TStrings )
: boolean;
const
//
// assume that the total number of
// services is less than 4096.
// increase if necessary
cnMaxServices = 4096;
type
TSvcA = array[0..cnMaxServices]
of TEnumServiceStatus;
PSvcA = ^TSvcA;
var
//
// temp. use
j : integer;
//
// service control
// manager handle
schm : SC_Handle;
//
// bytes needed for the
// next buffer, if any
nBytesNeeded,
//
// number of services
nServices,
//
// pointer to the
// next unread service entry
nResumeHandle : DWord;
//
// service status array
ssa : PSvcA;
begin
Result := false;
// connect to the service
// control manager
schm := OpenSCManager(
PChar(sMachine),
Nil,
SC_MANAGER_ALL_ACCESS);
// if successful...
if(schm > 0)then
begin
nResumeHandle := 0;
New(ssa);
EnumServicesStatus(
schm,
dwServiceType,
dwServiceState,
ssa^[0],
SizeOf(ssa^),
nBytesNeeded,
nServices,
nResumeHandle );
//
// assume that our initial array
// was large enough to hold all
// entries. add code to enumerate
// if necessary.
//
for j := 0 to nServices-1 do
begin
slServicesList.
Add( StrPas(
ssa^[j].lpDisplayName ) );
end;
Result := true;
Dispose(ssa);
// close service control
// manager handle
CloseServiceHandle(schm);
end;
end;
To get a list of all Windows services into a ListBox named ListBox1:
ServiceGetList( '',
SERVICE_WIN32,
SERVICE_STATE_ALL,
ListBox1.Items );
I tried to use the same code in Delphi 10.4 and Delphi 11, but there is a problem with the EnumServicesStatus function:
[dcc32 Error] Unit1.pas(145): E2010 Incompatible types: 'LPENUM_SERVICE_STATUSW' and '_ENUM_SERVICE_STATUSW'
When I tried LPENUM_SERVICE_STATUSW instead TEnumServiceStatus:
type
TSvcA = array[0..cnMaxServices]
of LPENUM_SERVICE_STATUSW;// instead TEnumServiceStatus;
I got an 'access violation' error.
Maybe the point is in the external function in Winapi.WinSvc.pas:
function EnumServicesStatus; external advapi32 name 'EnumServicesStatusW';

It is not a good idea to pre-allocate such a large array. You can't assume how many services the PC actually has installed. Let EnumServicesStatus() tell you how much to allocate for the array.
Also, you have to account for the possibility that you may have to call EnumServicesStatus() multiple times to get all of the statuses.
Now, regarding the compiler issue - the actual EnumServiceStatus() API wants a pointer to an array of ENUM_SERVICE_STATUS records (aliased as TEnumServiceStatus in the WinSvc unit), not an array of LPENUM_SERVICE_STATUS pointers. In earlier versions of Delphi, the Winsvc unit declared EnumServiceStatusW() to take a var reference to the 1st ENUM_SERVICE_STATUS in the array. But apparently it has since been re-declared to instead take a pointer to the 1st ENUM_SERVICE_STATUS, to match the actual API.
So, with that said, try something more like this:
uses
WinSvc;
{$IFDEF CONDITIONALEXPRESSIONS}
{$IF CompilerVersion >= 34}
{$DEFINE lpServices_Param_Is_Pointer}
{$IFEND}
{$ENDIF}
function ServiceGetList(
const sMachine : string;
dwServiceType,
dwServiceState : DWord;
slServicesList : TStrings )
: Boolean;
var
j : integer;
schm : SC_Handle;
nBytesNeeded,
nServices,
nResumeHandle : DWord;
buffer : array of Byte;
ssa, ss : PEnumServiceStatus;
begin
Result := False;
schm := OpenSCManager(
PChar(sMachine),
nil,
SC_MANAGER_CONNECT or SC_MANAGER_ENUMERATE_SERVICE);
if (schm <> 0) then
try
nResumeHandle := 0;
if not EnumServicesStatus(
schm,
dwServiceType,
dwServiceState,
{$IFDEF lpServices_Param_Is_Pointer}nil{$ELSE}PEnumServiceStatus(nil)^{$ENDIF},
0,
nBytesNeeded,
nServices,
nResumeHandle) then
begin
if (GetLastError() <> ERROR_INSUFFICIENT_BUFFER) and (GetLastError() <> ERROR_MORE_DATA) then
begin
Exit;
end;
SetLength(buffer, nBytesNeeded);
ssa := PEnumServiceStatus(buffer);
if not EnumServicesStatus(
schm,
dwServiceType,
dwServiceState,
ssa{$IFNDEF lpServices_Param_Is_Pointer}^{$ENDIF},
Length(buffer),
nBytesNeeded,
nServices,
nResumeHandle) then
begin
Exit;
end;
end;
if (nServices > 0) then
begin
ss := ssa;
for j := 0 to nServices-1 do
begin
slServicesList.Add(ss.lpDisplayName);
Inc(ss);
end;
end;
finally
CloseServiceHandle(schm);
end;
Result := True;
end;

Related

WlanAPI WlanGetNetworkBssList returning invalid data

I'm stuck in my debugging efforts with a call to WlanGetNetworkBssList and would appreciate some pointers. My end objective is to construct a Wifi scanner/profiler tool to help me troubleshoot networking issues on remote sites.
I am using the Windows Native Wifi API (link) and Delphi/Pascal interface found here using Delphi Berlin 10.1 Update 2 under Windows 10 (VCL).
I started with a simple and crude test app (VCL) to get a feel for the API and ran into a problem calling WlanGetNetworkBssList so I created a small console app focused on that problem. The issue is that it works in a console app running in a command prompt but not in my VCL test app. The functions are pretty much copy-paste equivalent and stepping through the code side-by-side shows that the data is identical except for the return data from WlanGetNetworkBssList call (pWlanBssList)
Question: Since the call is to an external DLL what steps can I do to further debug this and understand the difference between the VCL and the console app.
Note: The WlanGetNetworkBssList has two modes of operation where an SSID can be supplied to get the BSSID (MAC of the access point) for that specific SSID. By passing NULL instead of an SSID the API will return the BSSIDs of all APs. Passing NULL works on both the VLC and console app. What breaks is when a specific SSID is requested. After verification, the SSID data structure is identical in both apps but the data buffer returned is invalid with the VCL app. How can this be?
Console app:
program CWifiScan;
{$APPTYPE CONSOLE}
uses
Windows,
System.SysUtils,
nduWlanAPI,
nduWlanTypes;
const
WLAN_AVAILABLE_NETWORK_INCLUDE_ALL_ADHOC_PROFILES = $00000001;
var
hWlan: THandle;
guid : TGUID;
dwSupportedVersion: DWORD = 0;
dwClientVersion: DWORD = 1;
i,j : integer;
pInterfaceInfo : Pndu_WLAN_INTERFACE_INFO;
pInterfaceList : Pndu_WLAN_INTERFACE_INFO_LIST;
pAvailableNetworkList : Pndu_WLAN_AVAILABLE_NETWORK_LIST;
procedure GetBSSIDList(clientHandle : THandle;
interfaceGUID : TGUID;
pSSID : Pndu_DOT11_SSID = nil;
SSID_Type : Tndu_DOT11_BSS_Type = dot11_BSS_type_any;
SecurityEnabled : BOOL = True);
var
//to check if interface is connected
pData : Pndu_WLAN_INTERFACE_STATE;
pdwDataSize : DWORD;
isConnected : Boolean;
//to get list of BSSids from available APs
pWlanBssList : Pndu_WLAN_BSS_LIST;
items : integer;
itemIndex : integer;
SSID : string;
MAC : string;
begin
//check if interface is connected
isConnected := False;
if WlanQueryInterface(clientHandle,
#interfaceGUID,
wlan_intf_opcode_interface_state,
nil,
#pdwDataSize,
#pData,
nil) = ERROR_SUCCESS then
begin
isConnected := (pData^ = Tndu_WLAN_INTERFACE_STATE.wlan_interface_state_connected);
end;
//get the list of BSSids for the provided interface
if isConnected then
begin
if WlanGetNetworkBssList(clientHandle,
#interfaceGUID,
pSSID,
SSID_Type,
SecurityEnabled,
nil,
#pWlanBssList) = ERROR_SUCCESS then
begin
items := pWlanBssList^.dwNumberOfItems;
for itemIndex := 0 to items - 1 do
begin
SSID := String(PAnsiChar(#pWlanBssList^.wlanBssEntries[itemIndex].dot11Ssid.ucSSID));
MAC := Format('%.2x:%.2x:%.2x:%.2x:%.2x:%.2x', [
pWlanBssList^.wlanBssEntries[itemIndex].dot11Bssid[0],
pWlanBssList^.wlanBssEntries[itemIndex].dot11Bssid[1],
pWlanBssList^.wlanBssEntries[itemIndex].dot11Bssid[2],
pWlanBssList^.wlanBssEntries[itemIndex].dot11Bssid[3],
pWlanBssList^.wlanBssEntries[itemIndex].dot11Bssid[4],
pWlanBssList^.wlanBssEntries[itemIndex].dot11Bssid[5]]);
Writeln('');
Writeln('SSID: ................ '+SSID);
Writeln('Physical Address: .... '+MAC);
end; {for itemIndex}
Writeln(#10+#13+'Done.');
end; {WlanGetNetworkBssList succeeds}
end; {isConnected}
end;
begin
hWlan := 0;
if WlanOpenHandle(2, nil,#dwSupportedVersion, #hWlan)= ERROR_SUCCESS then
begin
if WlanEnumInterfaces(hWlan, nil, #pInterfaceList) = ERROR_SUCCESS then
begin
try
for i := 0 to pInterfaceList^.dwNumberOfItems-1 do
begin
Writeln('Wifi Adapter - '+GUIDToString( pInterfaceList^.InterfaceInfo[i].InterfaceGuid ) );
Writeln('Scanning: .... '+pInterfaceList^.InterfaceInfo[i].strInterfaceDescription);
guid := pInterfaceList^.InterfaceInfo[i].InterfaceGuid;
//Get all BSSids for this interface
GetBSSIDList(hWlan, guid);
if WlanGetAvailableNetworkList(hWlan,
#guid,
WLAN_AVAILABLE_NETWORK_INCLUDE_ALL_ADHOC_PROFILES,
nil,
pAvailableNetworkList) = ERROR_SUCCESS then
begin
try
for j := 0 to pAvailableNetworkList^.dwNumberOfItems - 1 do
begin
//Get BSSid for this specific SSID
GetBSSIDList(hWlan,
guid,
#pAvailableNetworkList^.Network[j].dot11Ssid,
pAvailableNetworkList^.Network[j].dot11BssType,
pAvailableNetworkList^.Network[j].bSecurityEnabled);
end;
finally
if pAvailableNetworkList<>nil then
WlanFreeMemory(pAvailableNetworkList);
end;
end;
end;
finally
if pInterfaceList<>nil then
WlanFreeMemory(pInterfaceList);
end;
end;
WlanCloseHandle(hWlan, nil);
readln;
end;
end.
The relevant parts of the VCL app are:
uses
... nduWlanAPI, nduWlanTypes, nduWinDot11;
function TForm1.GetBSSID(clientHandle: THandle;
interfaceGuid: TGUID;
pSSID: Pndu_DOT11_SSID = nil;
SSID_Type : Tndu_DOT11_BSS_TYPE = dot11_BSS_type_any;
SecurityEnabled: boolean = true): string;
var
//used to determin if the interface is connected
pData : Pndu_WLAN_INTERFACE_STATE;
isConnected : boolean;
//used to extract a list of BSSIDs for a given interface
pWlanBssList : Pndu_WLAN_BSS_LIST;
lastError : DWORD;
pdwDataSize : DWORD;
items,
itemIndex: Integer;
begin
pData := nil;
pdwDataSize := 0;
isConnected := False;
//check if the interface is connected
lastError := WlanQueryInterface(clientHandle,
#interfaceGuid,
wlan_intf_opcode_interface_state,
nil,
#pdwDataSize,
#pData,
nil);
if (lastError = ERROR_SUCCESS) then
begin
//isConnected := (Tndu_WLAN_INTERFACE_STATE(pData^.isState) = Tndu_WLAN_INTERFACE_STATE.wlan_interface_state_connected);
isConnected := (pData^ = Tndu_WLAN_INTERFACE_STATE.wlan_interface_state_connected);
end
else
DisplayError('Error in WlanQueryInterface() function', lastError);
if isConnected then
begin
pWlanBssList := nil;
lastError := WlanGetNetworkBssList(clientHandle,
#interfaceGuid,
pSSID,
SSID_Type,
SecurityEnabled,
nil,
#pWlanBssList);
try
if (lastError = ERROR_SUCCESS) then
begin
items := pWlanBssList^.dwNumberOfItems;
for itemIndex := 0 to items-1 do
begin
Result := (Format('%.2x:%.2x:%.2x:%.2x:%.2x:%.2x', [
pWlanBssList^.wlanBssEntries[itemIndex].dot11Bssid[0],
pWlanBssList^.wlanBssEntries[itemIndex].dot11Bssid[1],
pWlanBssList^.wlanBssEntries[itemIndex].dot11Bssid[2],
pWlanBssList^.wlanBssEntries[itemIndex].dot11Bssid[3],
pWlanBssList^.wlanBssEntries[itemIndex].dot11Bssid[4],
pWlanBssList^.wlanBssEntries[itemIndex].dot11Bssid[5]]));
end;
end
else
DisplayError('Error in the WlanGetNetworkBssList() function call', lastError);
finally
if pData<>nil then
WlanFreeMemory(pData);
if pWlanBssList<>nil then
WlanFreeMemory(pWlanBssList);
end;
end;
end;
Which is called as follows:
function TForm1.ScanWifi(): THandle;
const
WLAN_AVAILABLE_NETWORK_INCLUDE_ALL_ADHOC_PROFILES = $00000001;
var
hClient : THandle;
dwVersion : DWORD;
lastError : DWORD;
pInterface : Pndu_WLAN_INTERFACE_INFO_LIST;
i : Integer;
j : Integer;
pAvailableNetworkList: Pndu_WLAN_AVAILABLE_NETWORK_LIST;
interfaceGuid : TGUID;
BSSID : string;
begin
lastError:=WlanOpenHandle(NDU_WLAN_API_VERSION, nil, #dwVersion, #hClient);
if lastError<> ERROR_SUCCESS then
begin
//DisplayError('Error in the WlanOpenHandle() function call', lastError);
Result := 0;
Exit;
end;
//L(Format('Requested WLAN interface version [%d], negotiated version [%d]', [NDU_WLAN_API_VERSION, dwVersion]));
Result := hClient;
try
lastError:=WlanEnumInterfaces(hClient, nil, #pInterface);
try
if lastError<> ERROR_SUCCESS then
begin
//DisplayError('Errorin the WlanEnumInterfaces() function call', lastError);
Exit;
end;
for i := 0 to pInterface^.dwNumberOfItems - 1 do
begin
interfaceGuid:= pInterface^.InterfaceInfo[i].InterfaceGuid;
lastError:=WlanGetAvailableNetworkList(hClient,
#interfaceGuid,
WLAN_AVAILABLE_NETWORK_INCLUDE_ALL_ADHOC_PROFILES,
nil,
pAvailableNetworkList);
try
if lastError<> ERROR_SUCCESS then
begin
//DisplayError('Error WlanGetAvailableNetworkList', lastError);
Exit;
end
else
begin
for j := 0 to pAvailableNetworkList^.dwNumberOfItems - 1 do
Begin
BSSID := GetBssid(hClient,
interfaceGuid,
#pAvailableNetworkList^.Network[j].dot11Ssid,
pAvailableNetworkList^.Network[j].dot11BssType,
pAvailableNetworkList^.Network[j].bSecurityEnabled
);
//FAPList.AddOrSetValue(BSSID,J);
end;
end;
finally
if pAvailableNetworkList <> nil then
WlanFreeMemory(pAvailableNetworkList);
end;
end;
finally
if pInterface <> nil then
WlanFreeMemory(pInterface);
end;
finally
WlanCloseHandle(FhClient, nil);
end;
end;
Comparing the data between the two apps the only difference is the result (pWlanBssList) as seen here (left=console, right=VCL):
Looks like compiler bug in boolean conversion, problem is following line in VCL code
SecurityEnabled: boolean = true
you need to change it to
SecurityEnabled: bool = true

Access Violation! Inaccessible Value Serial.pas

I have a problem with my Serial.pas file, as I am trying to access Com Ports, I am getting access violations and then for the variable hCommPort it says its inaccessible value. At the bottom of this post, the very bottom is the code I use to send my com port and baud rate to Serial.pas.
I have looked all over the place to find a solution for it but I can't seem to find or I just don't have the know how to fix it and it seems I have no knowledge about access violations as I have not dealt with them before.
Any help will be greatly appreciated
Here is the whole code for Serial.pas
unit Serial;
interface
uses
Windows, Messages, SysUtils, Classes,
Graphics, Controls, Forms, Dialogs;
// This is the Device Control Block record.
// It is the structure that contains the
// serial port setup parameters. This
// structure must be initialized before the
// serial port can be used. It is declared
// in the windows.pas unit and looks like this:
{type TDCB = record
DCBLength:DWord;
Baudrate:DWord;
Flags:LongInt;
wReserved:Word;
XONLim:Word;
XOFFLim:Word;
ByteSize:Byte;
Parity:Byte;
StopBits:Byte;
XONChar:Char;
XOFFChar:Char;
ErrorChar:Char;
EOFChar:Char;
EvtChar:Char;
wReserved1:Word;
end;}
type
// You can't do anything without a comm port.
TCommPort = (cpCOM1, cpCOM2, cpCOM3, cpCOM4,
cpCOM5, cpCOM6, cpCOM7, cpCOM8, cpCOM9);
// All of the baud rates that the DCB supports.
TBaudRate = (br110, br300, br600, br1200, br2400, br4800, br9600,
br14400, br19200, br38400, br56000, br115200, br128000, br256000, br009600);
// Parity types for parity error checking
TParityType = (pcNone, pcEven, pcOdd, pcMark, pcSpace);
TStopBits = (sbOne, sbOnePtFive, sbTwo);
TDataBits = (db4, db5, db6, db7, db8);
TFlowControl = (fcNone, fcXON_XOFF, fcRTS_CTS, fcDSR_DTR);
// Two new notify events.
TNotifyTXEvent = procedure(Sender : TObject; data : string) of object;
TNotifyRXEvent = procedure(Sender : TObject; data : string) of object;
// Set some constant defaults.
// These are the qquivalent of
// COM2:9600,N,8,1;
const
dflt_CommPort = cpCOM2;
dflt_BaudRate = br9600;
dflt_ParityType = pcNone;
dflt_ParityErrorChecking = False;
dflt_ParityErrorChar = 0;
dflt_ParityErrorReplacement = False;
dflt_StopBits = sbOne;
dflt_DataBits = db8;
dflt_XONChar = $11; {ASCII 11h}
dflt_XOFFChar = $13; {ASCII 13h}
dflt_XONLim = 1024;
dflt_XOFFLim = 2048;
dflt_ErrorChar = 0; // For parity checking.
dflt_FlowControl = fcNone;
dflt_StripNullChars = False;
dflt_EOFChar = 0;
type
TSerialPort = class(TComponent)
private
hCommPort : THandle; // Handle to the serial port.
fCommPort : TCommPort;
fBaudRate : TBaudRate;
fParityType : TParityType;
fParityErrorChecking : Boolean;
fParityErrorChar : Byte;
fParityErrorReplacement : Boolean;
fStopBits : TStopBits;
fDataBits : TDataBits;
fXONChar : byte; {0..255}
fXOFFChar : byte; {0..255}
fXONLim : word; {0..65535}
fXOFFLim : word; {0..65535}
fErrorChar : byte;
fFlowControl : TFlowControl;
fStripNullChars : Boolean; // Strip null chars?
fEOFChar : Byte;
fOnTransmit : TNotifyTXEvent;
fOnReceive : TNotifyRXEvent;
fAfterTransmit : TNotifyTXEvent;
fAfterReceive : TNotifyRXEvent;
ReadBuffer : String; // Where the results from the read goes.
procedure SetCommPort(CP : TCommPort);
procedure SetBaudRate(BR : TBaudRate);
procedure SetParityType(PT : TParityType);
procedure SetParityErrorChecking(SPEC : Boolean);
procedure SetParityErrorChar(PEC : Byte);
procedure SetParityErrorReplacement(PER : Boolean);
procedure SetStopBits(SSB: TStopBits);
procedure SetDataBits(SDB : TDataBits);
procedure SetXONChar(SXC : byte);
procedure SetXOFFChar(SXOC : byte);
procedure SetXONLim(SXOL : word);
procedure SetXOFFLim(SXFL : word);
procedure SetErrorChar(SEC : byte);
procedure SetFlowControl(SFC : TFlowControl);
procedure SetStripNullChars(SSNC : Boolean);
procedure SetEOFChar(SEOFC : Byte);
procedure Initialize_DCB;
protected
public
constructor Create(AOwner : TComponent); override;
destructor Destroy; override;
function OpenPort(MyCommPort : TCommPort) : Boolean;
function ClosePort : boolean;
procedure SendData(data : PChar; size : DWord);
function GetData : String;
function InputBufferCount: LongInt;
function PortIsOpen : boolean;
procedure FlushTX;
procedure FlushRX;
published
property CommPort : TCommport read fCommPort
write SetCommPort
default dflt_CommPort;
property BaudRate : TBaudRate read fBaudRate
write SetBaudRate
default dflt_BaudRate;
property ParityType : TParityType read fParityType
write SetParityType
default dflt_ParityType;
property ParityErrorChecking : Boolean read fParityErrorChecking
write SetParityErrorChecking
default dflt_ParityErrorChecking;
property ParityErrorChar : Byte read fParityErrorChar
write SetParityErrorChar
default dflt_ParityErrorChar;
property ParityErrorReplacement : Boolean read fParityErrorReplacement
write
SetParityErrorReplacement
default
dflt_ParityErrorReplacement;
property StopBits : TStopBits read fStopBits
write SetStopBits
default dflt_StopBits;
property DataBits : TDataBits read fDataBits
write SetDataBits
default dflt_DataBits;
property XONChar : byte read fXONChar
write SetXONChar
default dflt_XONChar;
property XOFFChar : byte read fXOFFChar
write SetXOFFChar
default dflt_XOFFChar;
property XONLim : word read fXONLim
write SetXONLim
default dflt_XONLim;
property XOFFLim : word read fXOFFLim
write SetXOFFLim
default dflt_XOFFLim;
property ErrorChar : byte read fErrorChar
write SetErrorChar
default dflt_ErrorChar;
property FlowControl : TFlowControl read fFlowControl
write SetFlowControl
default dflt_FlowControl;
property StripNullChars : Boolean read fStripNullChars
write SetStripNullChars
default dflt_StripNullChars;
property EOFChar : byte read fEOFChar
write SetEOFChar
default dflt_EOFChar;
property OnTransmit : TNotifyTXEvent read fOnTransmit
write fOnTransmit;
property OnReceive : TNotifyRXEvent read fOnReceive
write fOnReceive;
property AfterTransmit : TNotifyTXEvent read fAfterTransmit
write fAfterTransmit;
property AfterReceive : TNotifyRXEvent read fAfterReceive
write fAfterReceive;
end;
procedure Register;
implementation
// Create method.
constructor TSerialPort.Create(AOwner : TComponent);
begin
inherited Create(AOwner);
// Initalize the handle to the port as
// an invalid handle value. We do this
// because the port hasn't been opened
// yet, and it allows us to test for
// this condition in some functions,
// thereby controlling the behavior
// of the function.
//TSerialPort.Create(AOwner);
hCommPort := INVALID_HANDLE_VALUE;
// Set initial settings. Even though
// the default parameter was specified
// in the property, if you were to
// create a component at runtime, the
// defaults would not get set. So it
// is important to call them again in
// the create of the component.
fCommPort := dflt_CommPort;
fBaudRate := dflt_BaudRate;
fParityType := dflt_ParityType;
fParityErrorChecking := dflt_ParityErrorChecking;
fParityErrorChar := dflt_ParityErrorChar;
fParityErrorReplacement := dflt_ParityErrorReplacement;
fStopBits := dflt_StopBits;
fDataBits := dflt_DataBits;
fXONChar := dflt_XONChar;
fXOFFChar := dflt_XOFFChar;
fXONLim := dflt_XONLim;
fXOFFLim := dflt_XOFFLim;
fErrorChar := dflt_ErrorChar;
fFlowControl := dflt_FlowControl;
fStripNullChars := dflt_StripNullChars;
fEOFChar := dflt_EOFChar;
//fOnTransmit := nil;
//fOnReceive := nil;
end;
// Public method to open the port and
// assign the handle to it.
function TSerialPort.OpenPort(MyCommPort : TCommPort) : Boolean;
var
MyPort : PChar;
begin
// Make sure that the port is Closed first.
ClosePort;
MyPort := PChar('COM' + IntToStr(ord(fCommPort)+1));
hCommPort := CreateFile(MyPort,
GENERIC_READ OR GENERIC_WRITE,
0,
nil,
OPEN_EXISTING,
0,0);
// Initialize the port.
Initialize_DCB;
// Was successful if not and invalid handle.
result := hCommPort <> INVALID_HANDLE_VALUE;
end;
// Public method to Close the port.
function TSerialPort.ClosePort : boolean;
begin
FlushTX;
FlushRX;
// Close the handle to the port.
result := CloseHandle(hCommPort);
hCommPort := INVALID_HANDLE_VALUE;
end;
// Public Send data method.
procedure TSerialPort.SendData(data : PChar; size : DWord);
var
NumBytesWritten : DWord;
begin
if hCommPort = INVALID_HANDLE_VALUE then exit;
if assigned(fOnTransmit) then fONTransmit(self, Data);
WriteFile(hCommPort,
Data^,
Size,
NumBytesWritten,
nil);
// Fire the transmit event.
if assigned(fAfterTransmit) then fAfterTransmit(self, Data);
end;
function TSerialPort.InputBufferCount: LongInt;
var
oStatus: TComStat;
dwErrorCode: DWord;
begin
Result := 0;
if hCommPort = INVALID_HANDLE_VALUE then
Exit;
ClearCommError(hCommPort, dwErrorCode, #oStatus);
Result := oStatus.cbInQue;
end;
// Public Get data method.
function TSerialPort.GetData : String;
var
NumBytesRead : DWord;
// <<cbInQue>> Specifies the number
// of bytes received by the serial
// provider but not yet read by a
// ReadFile operation.
BytesInQueue : LongInt; // Number of bytes in the input buffer
oStatus: TComStat; // Variable for the ComStat structure.
dwErrorCode: DWord; // Variable to put the error codes in.
begin
if hCommPort = INVALID_HANDLE_VALUE then exit;
if assigned(fOnReceive) then fONReceive(self, ReadBuffer);
// Get the total number of bytes that
// are waiting to be read from the
// input buffer.
ClearCommError(hCommPort, dwErrorCode, #oStatus);
BytesInQueue := oStatus.cbInQue;
if BytesInQueue > 0 then begin
SetLength(ReadBuffer, BytesInQueue + 1);
ReadFile(hCommPort,
PChar(ReadBuffer)^,
BytesInQueue,
NumBytesRead,
nil);
SetLength(ReadBuffer, StrLen(PChar(ReadBuffer)));
end;
if assigned(fAfterReceive) then fAfterReceive(self, ReadBuffer);
result := ReadBuffer;
end;
// Destroy method.
destructor TSerialPort.Destroy;
begin
// Close the port first;
ClosePort;
inherited Destroy;
end;
// Initialize the device control block.
procedure TSerialPort.Initialize_DCB;
var
MyDCB : TDCB;
//file://MyCommTimeouts : TCommTimeouts;
begin
// Only want to perform the setup
// if the port has been opened and
// the handle assigned.
if hCommPort = INVALID_HANDLE_VALUE then exit;
// The GetCommState function fills in a
// device-control block (a DCB structure)
// with the current control settings for
// a specified communications device.
// (Win32 Developers Reference)
// Get a default fill of the DCB.
GetCommState(hCommPort, MyDCB);
case fBaudRate of
br110 : MyDCB.BaudRate := 110;
br300 : MyDCB.BaudRate := 300;
br600 : MyDCB.BaudRate := 600;
br1200 : MyDCB.BaudRate := 1200;
br2400 : MyDCB.BaudRate := 2400;
br4800 : MyDCB.BaudRate := 4800;
br9600 : MyDCB.BaudRate := 9600;
br14400 : MyDCB.BaudRate := 14400;
br19200 : MyDCB.BaudRate := 19200;
br38400 : MyDCB.BaudRate := 38400;
br56000 : MyDCB.BaudRate := 56000;
br128000 : MyDCB.BaudRate := 128000;
br256000 : MyDCB.BaudRate := 256000;
end;
// Parity error checking parameters.
case fParityType of
pcNone : MyDCB.Parity := NOPARITY;
pcEven : MyDCB.Parity := EVENPARITY;
pcOdd : MyDCB.Parity := ODDPARITY;
pcMark : MyDCB.Parity := MARKPARITY;
pcSpace : MyDCB.Parity := SPACEPARITY;
end;
if fParityErrorChecking then inc(MyDCB.Flags, $0002);
if fParityErrorReplacement then inc(MyDCB.Flags, $0021);
MyDCB.ErrorChar := char(fErrorChar);
case fStopBits of
sbOne : MyDCB.StopBits := ONESTOPBIT;
sbOnePtFive : MyDCB.StopBits := ONE5STOPBITS;
sbTwo : MyDCB.StopBits := TWOSTOPBITS;
end;
case fDataBits of
db4 : MyDCB.ByteSize := 4;
db5 : MyDCB.ByteSize := 5;
db6 : MyDCB.ByteSize := 6;
db7 : MyDCB.ByteSize := 7;
db8 : MyDCB.ByteSize := 8;
end;
// The 'flags' are bit flags,
// which means that the flags
// either turn on or off the
// desired flow control type.
case fFlowControl of
fcXON_XOFF : MyDCB.Flags := MyDCB.Flags or $0020 or $0018;
fcRTS_CTS : MyDCB.Flags := MyDCB.Flags or $0004 or
$0024*RTS_CONTROL_HANDSHAKE;
fcDSR_DTR : MyDCB.Flags := MyDCB.Flags or $0008 or
$0010*DTR_CONTROL_HANDSHAKE;
end;
if fStripNullChars then inc(MyDCB.Flags,$0022);
MyDCB.XONChar := Char(fXONChar);
MyDCB.XOFFChar := Char(fXONChar);
// The XON Limit is the number of
// bytes that the data in the
// receive buffer must fall below
// before sending the XON character,
// there for resuming the flow
// of data.
MyDCB.XONLim := fXONLim;
// The XOFF limit is the max number
// of bytes that the receive buffer
// can contain before sending the
// XOFF character, therefore
// stopping the flow of data.
MyDCB.XOFFLim := fXOFFLim;
// Character that signals the end of file.
if fEOFChar <> 0 then MyDCB.EOFChar := char(EOFChar);
// The SetCommTimeouts function sets
// the time-out parameters for all
// read and write operations on a
// specified communications device.
// (Win32 Developers Reference)
// The GetCommTimeouts function retrieves
// the time-out parameters for all read
// and write operations on a specified
// communications device.
// GetCommTimeouts(hCommPort, MyCommTimeouts);
// MyCommTimeouts.ReadIntervalTimeout := ...
// MyCommTimeouts.ReadTotalTimeoutMultiplier := ...
// MyCommTimeouts.etc...................
// SetCommTimeouts(hCommPort, MyCommTimeouts);
SetCommState(hCommPort, MyDCB);
end;
// Set the comm port.
procedure TSerialPort.SetCommPort(CP : TCommPort);
begin
if fCommPort <> CP then begin <------------- Here is where access violation happens
fCommPort := CP;
Initialize_DCB;
end;
end;
// Set the baud rate.
procedure TSerialPort.SetBaudRate(BR : TBaudRate);
begin
if fBaudRate <> BR then begin
fBaudRate := BR;
Initialize_DCB;
end;
end;
// Set the parity check type.
procedure TSerialPort.SetParityType(PT : TParityType);
begin
if fParityType <> PT then begin
fParityType := PT;
Initialize_DCB;
end;
end;
// Do we want to do parity error checking?
procedure TSerialPort.SetParityErrorChecking(SPEC : Boolean);
begin
if fParityErrorChecking <> SPEC then begin
fParityErrorChecking := SPEC;
Initialize_DCB;
end;
end;
// Set the parity error char.
procedure TSerialPort.SetParityErrorChar(PEC : Byte);
begin
if fParityErrorChar <> PEC then begin
fParityErrorChar := PEC;
Initialize_DCB;
end;
end;
// Set wether to replace parity errors with error char.
procedure TSerialPort.SetParityErrorReplacement(PER : Boolean);
begin
if fParityErrorReplacement <> PER then begin
fParityErrorReplacement := PER;
Initialize_DCB;
end;
end;
// Set the stop bits.
procedure TSerialPort.SetStopBits(SSB : TStopBits);
begin
if fStopBits <> SSB then begin
fStopBits := SSB;
Initialize_DCB;
end;
end;
// Set the data bits.
procedure TSerialPort.SetDataBits(SDB : TDataBits);
begin
if fDataBits <> SDB then begin
fDataBits := SDB;
Initialize_DCB;
end;
end;
// Set the XON Char.
procedure TSerialPort.SetXONChar(SXC : byte);
begin
if fXONChar <> SXC then begin
fXONChar := SXC;
Initialize_DCB;
end;
end;
// Set the XOFF Char.
procedure TSerialPort.SetXOFFChar(SXOC : byte);
begin
if fXOFFChar <> SXOC then begin
fXOFFChar := SXOC;
Initialize_DCB;
end;
end;
// Set the XON Limit.
procedure TSerialPort.SetXONLim(SXOL : word);
begin
if fXONLim <> SXOL then begin
fXONLim := SXOL;
Initialize_DCB;
end;
end;
// Set the XOFF Limit.
procedure TSerialPort.SetXOFFLim(SXFL : word);
begin
if fXOFFLim <> SXFL then begin
fXOFFLim := SXFL;
Initialize_DCB;
end;
end;
// Set the error character.
procedure TSerialPort.SetErrorChar(SEC : byte);
begin
if fErrorChar <> SEC then begin
fErrorChar := SEC;
Initialize_DCB;
end;
end;
// Set the type of flow control desired.
procedure TSerialPort.SetFlowControl(SFC : TFlowControl);
begin
if fFlowControl <> SFC then begin
fFlowControl := SFC;
Initialize_DCB;
end;
end;
// Do we want to strip off the null characters?
procedure TSerialPort.SetStripNullChars(SSNC : Boolean);
begin
if fStripNullChars <> SSNC then begin
fStripNullChars := SSNC;
Initialize_DCB;
end;
end;
// Set the EOF char.
procedure TSerialPort.SetEOFChar(SEOFC : Byte);
begin
if fEOFChar <> SEOFC then begin
fEOFChar := SEOFC;
Initialize_DCB;
end;
end;
// Public function to check if the port is open.
function TSerialPort.PortIsOpen : boolean;
begin
Result := hCommPort <> INVALID_HANDLE_VALUE;
end;
// Public method to cancel and flush the receive buffer.
procedure TSerialPort.FlushRx;
begin
if hCommPort = INVALID_HANDLE_VALUE then exit;
PurgeComm(hCommPort, PURGE_RXABORT or PURGE_RXCLEAR);
ReadBuffer := '';
end;
// Public method to cancel and flush the transmit buffer.
procedure TSerialPort.FlushTx;
begin
if hCommPort = INVALID_HANDLE_VALUE then exit;
PurgeComm(hCommPort, PURGE_TXABORT or PURGE_TXCLEAR);
end;
// Register the component in its own menu selection.
procedure Register;
begin
RegisterComponents('Misc', [TSerialPort]);
end;
end.
The below information is sent to this Serial.pas:
function TfrmMain.SetCOMPort(Index:Integer;BaudRate:TBaudRate):Boolean;
var
TempPort:TCommPort;
begin
TempPort := cpCOM1;
If Index = 0 then
TempPort:=cpCOM1;
If Index = 1 then
TempPort:=cpCOM2;
If Index = 2 then
TempPort:=cpCOM3;
If Index = 3 then
TempPort:=cpCOM4;
If Index = 4 then
TempPort:=cpCOM5;
If Index = 5 then
TempPort:=cpCOM6;
If Index = 6 then
TempPort:=cpCOM7;
If Index = 7 then
TempPort:=cpCOM8;
If Index = 8 then
TempPort:=cpCOM9;
MySP.CommPort := TempPort;
MySP.BaudRate := BaudRate;
Result := True; <----- don't know if this is correct
end;
if hCommPort = INVALID_HANDLE_VALUE then exit;
An access violation occurs when you attempt to read or write an address that is invalid. In your code the only memory access is the field hCommPort. What this means is that the Self pointer, the instance reference, refers to an invalid address. Common causes for this include the instance reference is nil or refers to an object that has been destroyed.
With the information you provided it is not possible to say any more. You will have to debug your program to work out why Self is not valid.

Delphi - Find primary email address for an Active Directory user

I'm looking for the best* method to find the primary email address for the currently logged in Active Directory user (using GetUserName to get the logged in username)
I have seen How do integrate Delphi with Active Directory? but I couldn't get this to work with Delphi 2010.
(*best method: the eventual application will be run by users who do not have administrative access to the machine)
Edit 1:
Reading up on this, it appears that the email or mail field is probably not the best way to go as it seems it might not be populated, therefore I'd need to use the multivalue field of proxyaddresses
The code below works for me. It is an extract of a class I use in production code. It didn't get the proxyAddresses but I added that and it seems to work, although I get only one alternative e-mail address, looking like smtp: g.trol#mydomain.com. I can't find an example with more that one address, so you may need to test what happens then.
Also, I tested this in Delphi 2007, using a type library I found somewhere, because I had trouble importing it. In the code you see __MIDL_0010, which is a __MIDL___MIDL_itf_ads_0000_0017 record property of the field value. I noticed this was named otherwise in a different version of the type library, so you may need to make some tweaks to this code to suit your exact type library import, an maybe fix some ansi/unicode differences.
uses ActiveX, ComObj, ActiveDs_TLB;
const
NETAPI32DLL = 'netapi32.dll';
const
ACTIVEDSDLL = 'activeds.dll';
ADS_SECURE_AUTHENTICATION = $00000001;
const
// ADSI success codes
S_ADS_ERRORSOCCURRED = $00005011;
S_ADS_NOMORE_ROWS = $00005012;
S_ADS_NOMORE_COLUMNS = $00005013;
// ADSI error codes
E_ADS_BAD_PATHNAME = $80005000;
E_ADS_INVALID_DOMAIN_OBJECT = $80005001;
E_ADS_INVALID_USER_OBJECT = $80005002;
E_ADS_INVALID_COMPUTER_OBJECT = $80005003;
E_ADS_UNKNOWN_OBJECT = $80005004;
E_ADS_PROPERTY_NOT_SET = $80005005;
E_ADS_PROPERTY_NOT_SUPPORTED = $80005006;
E_ADS_PROPERTY_INVALID = $80005007;
E_ADS_BAD_PARAMETER = $80005008;
E_ADS_OBJECT_UNBOUND = $80005009;
E_ADS_PROPERTY_NOT_MODIFIED = $8000500A;
E_ADS_PROPERTY_MODIFIED = $8000500B;
E_ADS_CANT_CONVERT_DATATYPE = $8000500C;
E_ADS_PROPERTY_NOT_FOUND = $8000500D;
E_ADS_OBJECT_EXISTS = $8000500E;
E_ADS_SCHEMA_VIOLATION = $8000500F;
E_ADS_COLUMN_NOT_SET = $80005010;
E_ADS_INVALID_FILTER = $80005014;
type
TNetWkstaGetInfo = function(ServerName: PWideChar; Level: Cardinal;
out BufPtr: Pointer): Cardinal; stdcall;
TADsOpenObject = function (lpszPathName: PWideChar; lpszUserName: PWideChar;
lpszPassword: PWideChar; dwReserved: DWORD; const riid: TGUID;
out pObject): HRESULT; stdcall;
TADsGetObject = function(PathName: PWideChar; const IID: TGUID; out Void):
HRESULT; stdcall;
var
NetLibHandle: THandle;
NetWkstaGetInfo : TNetWkstaGetInfo;
AdsLibHandle: THandle;
_ADsOpenObject : TADsOpenObject;
_ADsGetObject :TADsGetObject;
// VB-like GetObject function
function GetObject(const Name: String): IDispatch;
var
Moniker: IMoniker;
Eaten: integer;
BindContext: IBindCtx;
Dispatch: IDispatch;
begin
OleCheck(CreateBindCtx(0, BindContext));
OleCheck(MkParseDisplayName(BindContext,
PWideChar(WideString(Name)),
Eaten,
Moniker));
OleCheck(Moniker.BindToObject(BindContext, nil, IDispatch, Dispatch));
Result := Dispatch;
end;
// Some network info
type
PWkstaInfo100 = ^TWkstaInfo100;
_WKSTA_INFO_100 = record
wki100_platform_id: DWORD;
wki100_computername: LPWSTR;
wki100_langroup: LPWSTR;
wki100_ver_major: DWORD;
wki100_ver_minor: DWORD;
end;
TWkstaInfo100 = _WKSTA_INFO_100;
WKSTA_INFO_100 = _WKSTA_INFO_100;
function GetCurrentDomain: String;
var
pWI: PWkstaInfo100;
begin
if Win32Platform = VER_PLATFORM_WIN32_NT then
begin
if NetWkstaGetInfo(nil, 100, Pointer(pWI)) = 0 then
Result := String(pWI.wki100_langroup);
end;
end;
// ADs...Object function wrappers
function ADsGetObject(PathName: PWideChar; const IID: TGUID;
out Void): HRESULT;
begin
if Assigned(_ADsGetObject) then
Result := _ADsGetObject(PathName, IID, Void)
else
Result := ERROR_CALL_NOT_IMPLEMENTED;
end;
function ADsOpenObject(lpszPathName, lpszUserName,
lpszPassword: PWideChar; dwReserved: DWORD; const riid: TGUID;
out pObject): HRESULT;
begin
if Assigned(_ADsOpenObject) then
Result := _ADsOpenObject(lpszPathName, lpszUserName, lpszPassword, dwReserved, riid, pObject)
else
Result := ERROR_CALL_NOT_IMPLEMENTED;
end;
// The main function
function GetUserInfo(UserAccountName: string): Boolean;
var
// Domain info: Max password age
RootDSE: Variant;
Domain: Variant;
MaxPwdNanoAge: Variant;
MaxPasswordAge: Int64;
DNSDomain: String;
// User info: User directorysearch to find the user by username
DirectorySearch: IDirectorySearch;
SearchPreferences: array[0..1] of ADS_SEARCHPREF_INFO;
Columns: array[0..6] of PWideChar;
SearchResult: Cardinal;
hr: HRESULT;
ColumnResult: ads_search_column;
// Number of user records found
RecordCount: Integer;
LastSetDateTime: TDateTime;
ExpireDateTime: TDateTime;
i: Integer;
begin
Result := False;
// If no account name is set, reading is impossible. Return false.
if (UserAccountName = '') then
Exit;
try
// Read the maximum password age from the domain.
// To do: Check if this can be done with ADsGetObject instead of the VB-like GetObject
// Get the Root DSE.
RootDSE := GetObject('LDAP://RootDSE');
DNSDomain := RootDSE.Get('DefaultNamingContext');
Domain := GetObject('LDAP://' + DNSDomain);
// Build an array of user properties to receive.
Columns[0] := StringToOleStr('AdsPath');
Columns[1] := StringToOleStr('pwdLastSet');
Columns[2] := StringToOleStr('displayName');
Columns[3] := StringToOleStr('mail');
Columns[4] := StringToOleStr('sAMAccountName');
Columns[5] := StringToOleStr('userPrincipalName');
Columns[6] := StringToOleStr('proxyAddresses');
// Bind to the directorysearch object. For some unspecified reason, the regular
// domain name (yourdomain) needs to be used instead of the AdsPath (office.yourdomain.us)
AdsGetObject(PWideChar(WideString('LDAP://' + GetCurrentDomain)), IDirectorySearch, DirectorySearch);
try
// Set search preferences.
SearchPreferences[0].dwSearchPref := ADS_SEARCHPREF_SEARCH_SCOPE;
SearchPreferences[0].vValue.dwType := ADSTYPE_INTEGER;
SearchPreferences[0].vValue.__MIDL_0010.Integer := ADS_SCOPE_SUBTREE;
DirectorySearch.SetSearchPreference(#SearchPreferences[0], 1);
// Execute search
// Search for SAM account name (g.trol) and User Principal name
// (g.trol#yourdomain.com). This allows the user to enter their username
// in both ways. Add CN=* to filter out irrelevant objects that might
// match the principal name.
DirectorySearch.ExecuteSearch(
PWideChar(WideString(
Format('(&(CN=*)(|(sAMAccountName=%0:s)(userPrincipalName=%0:s)))',
[UserAccountName]))),
nil,
$FFFFFFFF,
SearchResult);
// Get records
RecordCount := 0;
hr := DirectorySearch.GetNextRow(SearchResult);
if (hr <> S_ADS_NOMORE_ROWS) then
begin
// 1 row found
Inc(RecordCount);
// Get the column values for this row.
// To do: This code could use a more general and neater approach!
for i := Low(Columns) to High(Columns) do
begin
hr := DirectorySearch.GetColumn(SearchResult, Columns[i], ColumnResult);
if Succeeded(hr) then
begin
// Get the values for the columns.
{if SameText(ColumnResult.pszAttrName, 'AdsPath') then
Result.UserAdsPath :=
ColumnResult.pADsValues.__MIDL_0010.CaseIgnoreString
else if SameText(ColumnResult.pszAttrName, 'pwdLastSet') then
begin
LastSetDateTime := LDapTimeStampToDateTime(
ColumnResult.pAdsvalues^.__MIDL_0010.LargeInteger) +
GetTimeZoneCorrection;
ExpireDateTime := IncMilliSecond(LastSetDateTime,
LDapIntervalToMSecs(MaxPasswordAge));
Result.UserPasswordExpireDateTime := ExpireDateTime;
end
else if SameText(ColumnResult.pszAttrName, 'displayName') then
Result.UserFullName := ColumnResult.pADsValues.__MIDL_0010.CaseIgnoreString
else if SameText(ColumnResult.pszAttrName, 'mail') then
Result.UserEmail := ColumnResult.pADsValues.__MIDL_0010.CaseIgnoreString
else if SameText(ColumnResult.pszAttrName, 'sAMAccountName') then
Result.UserShortAccountName := ColumnResult.pADsValues.__MIDL_0010.CaseIgnoreString
else if SameText(ColumnResult.pszAttrName, 'userPrincipalName') then
Result.UserFullAccountName := ColumnResult.pADsValues.__MIDL_0010.CaseIgnoreString
else ..}
if SameText(ColumnResult.pszAttrName, 'proxyAddresses') then
ShowMessage(ColumnResult.pADsValues.__MIDL_0010.CaseIgnoreString);
// Free the column result
DirectorySearch.FreeColumn(ColumnResult);
end;
end;
// Small check if this account indeed is the only one found.
// No need to check the exact number. <> 1 = error
Hr := DirectorySearch.GetNextRow(SearchResult);
if (hr <> S_ADS_NOMORE_ROWS) then
Inc(RecordCount);
end;
// Close the search
DirectorySearch.CloseSearchHandle(SearchResult);
// Exactly 1 record found?
if RecordCount = 1 then
Result := True
else
ShowMessageFmt('More than one account found when searching for %s in ' +
'Active Directory.', [UserAccountName]);
finally
DirectorySearch := nil;
end;
except
Result := False;
end;
end;
initialization
NetLibHandle := LoadLibrary(NETAPI32DLL);
if NetLibHandle <> 0 then
#NetWkstaGetInfo := GetProcAddress(NetLibHandle, 'NetWkstaGetInfo');
ADsLibHandle := LoadLibrary(ACTIVEDSDLL);
if ADsLibHandle <> 0 then
begin
#_ADsOpenObject := GetProcAddress(ADsLibHandle, 'ADsOpenObject');
#_ADsGetObject := GetProcAddress(ADsLibHandle, 'ADsGetObject');
end;
finalization
FreeLibrary(ADsLibHandle);
FreeLibrary(NetLibHandle);
end.
Call like this:
GetUserInfo('g.trol' {or g.trol#yourdomain.com});
Download from My dropbox

Enumerate running processes in Delphi

How do I get a list of the running processes (with details of PID, Owner etc) on my machine using Delphi?
EDIT: None of the solutions proposed gives me the user that owns the process, only info such as PID, ExeName etc...
One way is using the Tool Help library (see TlHelp32 unit), or EnumProcesses on Windows NT (see PsAPI unit). Have a look at JclSysInfo.RunningProcessesList in the JCL for an example.
Here's a quick example of how to get the user name of a process:
type
PTokenUser = ^TTokenUser;
TTokenUser = packed record
User: SID_AND_ATTRIBUTES;
end;
function GetProcessUserName(ProcessID: Cardinal; out DomainName, UserName: string): Boolean;
var
ProcessHandle, ProcessToken: THandle;
InfoSize, UserNameSize, DomainNameSize: Cardinal;
User: PTokenUser;
Use: SID_NAME_USE;
_DomainName, _UserName: array[0..255] of Char;
begin
Result := False;
DomainName := '';
UserName := '';
ProcessHandle := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, False, ProcessID);
if ProcessHandle = 0 then
Exit;
try
if not OpenProcessToken(ProcessHandle, TOKEN_QUERY, ProcessToken) then
Exit;
try
GetTokenInformation(ProcessToken, TokenUser, nil, 0, InfoSize);
User := AllocMem(InfoSize * 2);
try
if GetTokenInformation(ProcessToken, TokenUser, User, InfoSize * 2, InfoSize) then
begin
DomainNameSize := SizeOf(_DomainName);
UserNameSize := SizeOf(_UserName);
Result := LookupAccountSid(nil, User^.User.Sid, _UserName, UserNameSize, _DomainName, DomainNameSize, Use);
if Result then
begin
SetString(DomainName, _DomainName, StrLen(_DomainName));
SetString(UserName, _UserName, StrLen(_UserName));
end;
end;
finally
FreeMem(User);
end;
finally
CloseHandle(ProcessToken);
end;
finally
CloseHandle(ProcessHandle);
end;
end;
This is the function we use to check if a process exists, the FProcessEntry32 holds all the info on the process, so you should be able to extend it to what every you need.
it was taken from here
uses TlHelp32
function processExists(exeFileName: string): Boolean;
{description checks if the process is running
URL: http://www.swissdelphicenter.ch/torry/showcode.php?id=2554}
var
ContinueLoop: BOOL;
FSnapshotHandle: THandle;
FProcessEntry32: TProcessEntry32;
begin
FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
FProcessEntry32.dwSize := SizeOf(FProcessEntry32);
ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32);
Result := False;
while Integer(ContinueLoop) <> 0 do
begin
if ((UpperCase(ExtractFileName(FProcessEntry32.szExeFile)) =
UpperCase(ExeFileName)) or (UpperCase(FProcessEntry32.szExeFile) =
UpperCase(ExeFileName))) then
begin
Result := True;
end;
ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32);
end;
CloseHandle(FSnapshotHandle);
end;
The TProcessEntry32 record looks like so:
tagPROCESSENTRY32 = packed record
dwSize: DWORD;
cntUsage: DWORD;
th32ProcessID: DWORD; // this process
th32DefaultHeapID: DWORD;
th32ModuleID: DWORD; // associated exe
cntThreads: DWORD;
th32ParentProcessID: DWORD; // this process's parent process
pcPriClassBase: Longint; // Base priority of process's threads
dwFlags: DWORD;
szExeFile: array[0..MAX_PATH - 1] of Char;// Path
end;
You have to use:
CreateToolhelp32Snapshot Function
Process32First Function
Process32Next Function
PROCESSENTRY32 Structure will contain all the informations that you may need.
The documentation is from MDSN, for C++, but it's the same in Delphi.
This class will give you a list of all open windows (listed below) with PID, caption, dimensions, etc. It's not exactly running processes information, but I've used it to find apps via it.
// Window List Component 1.5 by Jerry Ryle
//
// Aaugh! I accidentally uploaded the wrong source
// which had a nasty bug in the refresh procedure!
// Thanks to Serge, who found my mistake and suggested
// a few other improvements!
//
// This component will enumerate windows and return
// information about them in the Windows property.
// The component currently returns a handle, caption text,
// associated ProcessID, visibility, and dimensions.
// For documentation, please read the accompanying
// WindowList.txt
//
// This component is completely free of course. If you find
// it useful, and are compelled to send me cash, beer, or
// dead things in envelopes, please feel free to do so.
//
// email me if you make it better: gryle#calpoly.edu
unit WindowList;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
type
TWindowObject = record
WinHandle : HWnd; // Window Handle
WinCaption : String; // Window Caption Text (If any)
ProcessID : Integer; // Process the window belongs to
IsVisible : Boolean; // Is the window visible?
IsEnabled : Boolean; // Is the window enabled for mouse/keyboard input?
IsIconic : Boolean; // Is the window minimized?
WindowRect : TRect; // Window Dimensions
// Add more properties here if you like,
// then fill them in at the WindowCallback
// function.
end;
PTWindowObject = ^TWindowObject;
TWindowList = class(TComponent)
private
WindowLst : TList;
FCount : Integer;
protected
Function GetAWindow(Index : Integer) : TWindowObject;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
Procedure Refresh;
Property Windows[Index : Integer]: TWindowObject read GetAWindow;
Property Count : Integer read FCount;
published
// Published declarations
end;
procedure Register;
implementation
// Note that this function is not a member of WindowList.
// Therefore, the list to be filled needs to be passed
// as a pointer. Note that this is passed as a VAR. if you
// don't do this, bad things happen in memory.
Function WindowCallback(WHandle : HWnd; Var Parm : Pointer) : Boolean; stdcall;
// This function is called once for each window
Var MyString : PChar;
MyInt : Integer;
MyWindowPtr : ^TWindowObject;
begin
New(MyWindowPtr);
// Window Handle (Passed by the enumeration)
MyWindowPtr.WinHandle := WHandle;
// Window text
MyString := Allocmem(255);
GetWindowText(WHandle,MyString,255);
MyWindowPtr.WinCaption := String(MyString);
FreeMem(MyString,255);
// Process ID
MyInt := 0;
MyWindowPtr.ProcessID := GetWindowThreadProcessId(WHandle,#MyInt);
// Visiblity
MyWindowPtr.IsVisible := IsWindowVisible(WHandle);
// Enabled
MyWindowPtr.IsEnabled := IsWindowEnabled(WHandle);
// Iconic
MyWindowPtr.IsIconic := IsIconic(WHandle);
// Window Dimensions
MyWindowPtr.WindowRect := Rect(0,0,0,0);
GetWindowRect(WHandle,MyWindowPtr.WindowRect);
// Add the structure to the list. Do not dereference Parm...
// once again, bad things happen.
TList(Parm).Add(MyWindowPtr);
Result := True; // Everything's okay. Continue to enumerate windows
end;
constructor TWindowList.Create(AOwner: TComponent);
var MyWindowPtr : PTWindowObject;
begin
inherited;
WindowLst := TList.Create;
// Thanks Serge, I should've done this from the start :)
// Sloppy me.
If Not ( csDesigning in ComponentState ) Then
Begin
EnumWindows(#WindowCallback,Longint(#WindowLst));
FCount := WindowLst.Count;
End
Else
FCount := 0;
end;
destructor TWindowList.Destroy;
var I : Integer;
begin
If WindowLst.Count > 0 Then
Begin
For I := 0 To (WindowLst.Count - 1) Do
Dispose(PTWindowObject(WindowLst[I]));
End;
WindowLst.Free;
inherited;
end;
procedure TWindowList.Refresh;
begin
WindowLst.Clear; {Clear the list!}
EnumWindows(#WindowCallback,Longint(#WindowLst));
FCount := WindowLst.Count;
end;
function TWindowList.GetAWindow(Index : Integer) : TWindowObject;
begin
Result := PTWindowObject(WindowLst[Index])^;
end;
procedure Register;
begin
RegisterComponents('System', [TWindowList]);
end;
end.
You could look at using the WMISet components ($69 single licence, $199 for site licence, trial version available). The TWmiProcessControl component seems to encapsulate calls to Win32_Process. They also have an example of getting a process owner.
I think Madshi madKernel could be interesting to check out.

How do integrate Delphi with Active Directory?

We need to validate an user on Microsoft's Active Directory using Delphi 7, what is the best way to do that?
We can have two scenarios: the user inputs its network username and password, where the username may include the domain, and we check on active directory if it is a valid, active user. Or we get the current logged user from Windows, and check on AD if it is still valid.
The first scenario requires user validation, while the second one just a simple AD search and locate.
Does anyone know of components or code that do one or both of the scenarios described above?
Here's a unit we wrote and use. Simple and gets the job done.
unit ADSI;
interface
uses
SysUtils, Classes, ActiveX, Windows, ComCtrls, ExtCtrls, ActiveDs_TLB,
adshlp, oleserver, Variants;
type
TPassword = record
Expired: boolean;
NeverExpires: boolean;
CannotChange: boolean;
end;
type
TADSIUserInfo = record
UID: string;
UserName: string;
Description: string;
Password: TPassword;
Disabled: boolean;
LockedOut: boolean;
Groups: string; //CSV
end;
type
TADSI = class(TComponent)
private
FUserName: string;
FPassword: string;
FCurrentUser: string;
FCurrentDomain: string;
function GetCurrentUserName: string;
function GetCurrentDomain: string;
protected
{ Protected declarations }
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property CurrentUserName: string read FCurrentUser;
property CurrentDomain: string read FCurrentDomain;
function GetUser(Domain, UserName: string; var ADSIUser: TADSIUserInfo): boolean;
function Authenticate(Domain, UserName, Group: string): boolean;
published
property LoginUserName: string read FUserName write FUserName;
property LoginPassword: string read FPassword write FPassword;
end;
procedure Register;
implementation
function ContainsValComma(s1,s: string): boolean;
var
sub,str: string;
begin
Result:=false;
if (s='') or (s1='') then exit;
if SameText(s1,s) then begin
Result:=true;
exit;
end;
sub:=','+lowercase(trim(s1))+','; str:=','+lowercase(trim(s))+',';
Result:=(pos(sub, str)>0);
end;
procedure Register;
begin
RegisterComponents('ADSI', [TADSI]);
end;
constructor TADSI.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FCurrentUser:=GetCurrentUserName;
FCurrentDomain:=GetCurrentDomain;
FUserName:='';
FPassword:='';
end;
destructor TADSI.Destroy;
begin
inherited Destroy;
end;
function TADSI.GetCurrentUserName : string;
const
cnMaxUserNameLen = 254;
var
sUserName : string;
dwUserNameLen : DWord;
begin
dwUserNameLen := cnMaxUserNameLen-1;
SetLength(sUserName, cnMaxUserNameLen );
GetUserName(PChar(sUserName), dwUserNameLen );
SetLength(sUserName, dwUserNameLen);
Result := sUserName;
end;
function TADSI.GetCurrentDomain: string;
const
DNLEN = 255;
var
sid : PSID;
sidSize : DWORD;
sidNameUse : DWORD;
domainNameSize : DWORD;
domainName : array[0..DNLEN] of char;
begin
sidSize := 65536;
GetMem(sid, sidSize);
domainNameSize := DNLEN + 1;
sidNameUse := SidTypeUser;
try
if LookupAccountName(nil, PChar(FCurrentUser), sid, sidSize,
domainName, domainNameSize, sidNameUse) then
Result:=StrPas(domainName);
finally
FreeMem(sid);
end;
end;
function TADSI.Authenticate(Domain, UserName, Group: string): boolean;
var
aUser: TADSIUserInfo;
begin
Result:=false;
if GetUser(Domain,UserName,aUser) then begin
if not aUser.Disabled and not aUser.LockedOut then begin
if Group='' then
Result:=true
else
Result:=ContainsValComma(Group, aUser.Groups);
end;
end;
end;
function TADSI.GetUser(Domain, UserName: string; var ADSIUser: TADSIUserInfo): boolean;
var
usr : IAdsUser;
flags : integer;
Enum : IEnumVariant;
grps : IAdsMembers;
grp : IAdsGroup;
varGroup : OleVariant;
Temp : LongWord;
dom1, uid1: string;
//ui: TADSIUserInfo;
begin
ADSIUser.UID:='';
ADSIUser.UserName:='';
ADSIUser.Description:='';
ADSIUser.Disabled:=true;
ADSIUser.LockedOut:=true;
ADSIUser.Groups:='';
Result:=false;
if UserName='' then
uid1:=FCurrentUser
else
uid1:=UserName;
if Domain='' then
dom1:=FCurrentDomain
else
dom1:=Domain;
if uid1='' then exit;
if dom1='' then exit;
try
if trim(FUserName)<>'' then
ADsOpenObject('WinNT://' + dom1 + '/' + uid1, FUserName, FPassword, 1, IADsUser, usr)
else
ADsGetObject('WinNT://' + dom1 + '/' + uid1, IADsUser, usr);
if usr=nil then exit;
ADSIUser.UID:= UserName;
ADSIUser.UserName := usr.FullName;
ADSIUser.Description := usr.Description;
flags := usr.Get('userFlags');
ADSIUser.Password.Expired := usr.Get('PasswordExpired');
ADSIUser.Password.CannotChange := (flags AND ADS_UF_PASSWD_CANT_CHANGE)<>0;
ADSIUser.Password.NeverExpires := (flags and ADS_UF_DONT_EXPIRE_PASSWD)<>0;
ADSIUser.Disabled := usr.AccountDisabled;
ADSIUser.LockedOut := usr.IsAccountLocked;
ADSIUser.Groups:='';
grps := usr.Groups;
Enum := grps._NewEnum as IEnumVariant;
if Enum <> nil then begin
while (Enum.Next(1,varGroup, Temp) = S_OK) do begin
grp := IDispatch(varGroup) as IAdsGroup;
//sGroupType := GetGroupType(grp);
if ADSIUser.Groups<>'' then ADSIUser.Groups:=ADSIUser.Groups+',';
ADSIUser.Groups:=ADSIUser.Groups+grp.Name;
VariantClear(varGroup);
end;
end;
usr:=nil;
Result:=true;
except
on e: exception do begin
Result:=false;
exit;
end;
end;
end;
end.
I'm flattered to see my ADSISearch component mentioned here :-), but in order to simply validate user credentials, you're probably even better off using the "LogonUser" Win32 API. I'm pretty sure (not doing any Delphi work anymore myself) that there's an implementation of that floating around somewhere - probably in the JVCL library or somewhere else.
I've always used the 'ADSISearch.pas' unit for working with AD, with great success. Also, here is some code I used (that uses this unit) to retrieve a user's HOMEDRIVE info from their AD object:
try
ADSISearch1.Filter := WideString('samaccountname=' + GetUserFromWindows());
try
ADSISearch1.Search;
slTemp := ADSISearch1.GetFirstRow();
except
//uh-oh, this is a problem, get out of here
// --- must not have been able to talk to AD
// --- could be the user recently changed pwd and is logged in with
// their cached credentials
// just suppress this exception
bHomeDriveMappingFailed := True;
Result := bSuccess;
Exit;
end;
while (slTemp <> nil) do
begin
for ix := 0 to slTemp.Count - 1 do
begin
curLine := AnsiUpperCase(slTemp[ix]);
if AnsiStartsStr('HOMEDIRECTORY', curLine) then
begin
sADHomeDriveUncPath := AnsiReplaceStr(curLine, 'HOMEDIRECTORY=', '');
//sADHomeDriveUncPath := slTemp[ix];
end
else if AnsiStartsStr('HOMEDRIVE', curLine) then
begin
sADHomeDriveLetter := AnsiReplaceStr(curLine, 'HOMEDRIVE=', '');
//sADHomeDriveLetter := slTemp[ix];
end;
end;
FreeAndNil(slTemp);
slTemp := ADSISearch1.GetNextRow();
end;
except
//suppress this exception
bHomeDriveMappingFailed := True;
Exit;
end;
And without further delay, here is the unit (not written by me):
(* ----------------------------------------------------------------------------
Module: ADSI Searching in Delphi
Author: Marc Scheuner
Date: July 17, 2000
Changes:
Description:
constructor Create(aOwner : TComponent); override;
Creates a new instance of component
destructor Destroy; override;
Frees instance of component
function CheckIfExists() : Boolean;
Checks to see if the object described in the properties exists or not
TRUE: Object exists, FALSE: object does not exist
procedure Search;
Launches the ADSI search - use GetFirstRow and GetNextRow to retrieve information
function GetFirstRow() : TWideStringList;
function GetNextRow() : TWideStringList;
Returns the first row / next row of the result set, as a WideStringList.
The values are stored in the string list as a <name>=<value> pair, so you
can access the values via the FWideStringList.Values['name'] construct.
Multivalued attributes are returned as one per line, in an array index
manner:
objectClass[0]=top
objectClass[1]=Person
objectClass[2]=organizationalPerson
objectClass[3]=user
and so forth. The index is zero-based.
If there are no (more) rows, the return value will be NIL.
It's up to the receiver to free the string list when no longer needed.
property Attributes : WideString
Defines the attributes you want to retrieve from the object. If you leave
this empty, all available attributes will be returned.
You can specify multiple attributes separated by comma:
cn,distinguishedName,name,ADsPath
will therefore retrieve these four attributes for all the objects returned
in the search (if the attributes exist).
property BaseIADs : IADs
If you already have an interface to an IADs object, you can reuse it here
by setting it to the BaseIADs property - in this case, ADSISearch can skip
the step of binding to the ADSI object and will be executing faster.
property BasePath : WideString
LDAP base path for the search - the further down in the LDAP tree you start
searching, the smaller the namespace to search and the quicker the search
will return what you're looking for.
LDAP://cn=Users,dc=stmaarten,dc=qc,dc=rnd
is the well-known LDAP path for the Users container in the stmaarten.qc.rnd
domain.
property ChaseReferrals : Boolean
If set to TRUE, the search might need to connect to other domain controllers
and naming contexts, which is very time consuming.
Set this property to FALSE to limit it to the current naming context, thus
speeding up searches significantly.
property DirSrchIntf : IDirectorySearch
Provides access to the basic Directory Search interface, in case you need
to do some low-level tweaking
property Filter : WideString
LDAP filter expression to search for. It will be ANDed together with a
(objectClass=<ObjectClass>) filter to form the full search filter.
It can be anything that is a valid LDAP search filter - see the appropriate
books or online help files for details.
It can be (among many other things):
cn=Marc*
badPwdCount>=0
countryCode=49
givenName=Steve
and multiple conditions can be ANDed or ORed together using the LDAP syntax.
property MaxRows : Integer
Maximum rows of the result set you want to retrieve.
Default is 0 which means all rows.
property PageSize : Integer
Maximum number of elements to be returned in a paged search. If you set this to 0,
the search will *not* be "paged", e.g. IDirectorySearch will return all elements
found in one big gulp, but there's a limit at 1'000 elements.
With paged searching, you can search and find any number of AD objects. Default is
set to 100 elements. No special need on the side of the developer / user to use
paged searches - just set the PageSize to something non-zero.
property ObjectClass: WideString
ObjectClass of the ADSI object you are searching for. This allows you to
specify e.g. just users, only computers etc.
Be aware that ObjectClass is a multivalued attribute in LDAP, and sometimes
has unexpected hierarchies (e.g."computer" descends from "user" and will therefore
show up if you search for object class "user").
This property will be included in the LDAP search filter passed to the
search engine. If you don't want to limit the objects returned, just leave
it at the default value of *
property SearchScope
Limits the scope of the search.
scBase: search only the base object (as specified by the LDAP path) - not very
useful.....
scOneLevel: search only object immediately contained by the specified base
object (does not include baes object) - limits the depth of
the search
scSubtree: no limit on how "deep" the search goes, below the specified
base object - this is the default.
---------------------------------------------------------------------------- *)
unit ADSISearch;
interface
uses
ActiveX,
ActiveDs_TLB,
Classes,
SysUtils
{$IFDEF UNICODE}
,Unicode
{$ENDIF}
;
type
EADSISearchException = class(Exception);
TSearchScope = (scBase, scOneLevel, scSubtree);
TADSISearch = class(TComponent)
private
FBaseIADs : IADs;
FDirSrchIntf : IDirectorySearch;
FSearchHandle : ADS_SEARCH_HANDLE;
FAttributes,
FFilter,
FBasePath,
FObjectClass : Widestring;
FResult : HRESULT;
FChaseReferrals,
FSearchExecuted : Boolean;
FMaxRows,
FPageSize : Integer;
FSearchScope : TSearchScope;
FUsername: Widestring;
FPassword: Widestring;
{$IFDEF UNICODE}
procedure EnumerateColumns(aStrList : TWideStringList);
{$ELSE}
procedure EnumerateColumns(aStrList : TStringList);
{$ENDIF}
function GetStringValue(oSrchColumn : ads_search_column; Index : Integer) : WideString;
procedure SetBaseIADs(const Value: IADs);
procedure SetBasePath(const Value: WideString);
procedure SetFilter(const Value: WideString);
procedure SetObjectClass(const Value: Widestring);
procedure SetMaxRows(const Value: Integer);
procedure SetPageSize(const Value: Integer);
procedure SetAttributes(const Value: WideString);
procedure SetChaseReferrals(const Value: Boolean);
procedure SetUsername(const Value: WideString);
procedure SetPassword(const Value: WideString);
public
constructor Create(aOwner : TComponent); override;
destructor Destroy; override;
function CheckIfExists() : Boolean;
procedure Search;
{$IFDEF UNICODE}
function GetFirstRow() : TWideStringList;
function GetNextRow() : TWideStringList;
{$ELSE}
function GetFirstRow() : TStringList;
function GetNextRow() : TStringList;
{$ENDIF}
published
// list of attributes to return - empty string equals all attributes
property Attributes : WideString read FAttributes write SetAttributes;
// search base - both as an IADs interface, as well as a LDAP path
property BaseIADs : IADs read FBaseIADs write SetBaseIADs stored False;
property BasePath : WideString read FBasePath write SetBasePath;
// chase possible referrals to other domain controllers?
property ChaseReferrals : Boolean read FChaseReferrals write SetChaseReferrals default False;
// "raw" search interface - for any low-level tweaking necessary
property DirSrchIntf : IDirectorySearch read FDirSrchIntf;
// LDAP filter to limit the search
property Filter : WideString read FFilter write SetFilter;
// maximum number of rows to return - 0 = all rows (no limit)
property MaxRows : Integer read FMaxRows write SetMaxRows default 0;
property ObjectClass : Widestring read FObjectClass write SetObjectClass;
property PageSize : Integer read FPageSize write SetPageSize default 100;
property SearchScope : TSearchScope read FSearchScope write FSearchScope default scSubtree;
property Username : Widestring read FUsername write SetUsername;
property Password : Widestring read FPassword write SetPassword;
end;
const
// ADSI success codes
S_ADS_ERRORSOCCURRED = $00005011;
S_ADS_NOMORE_ROWS = $00005012;
S_ADS_NOMORE_COLUMNS = $00005013;
// ADSI error codes
E_ADS_BAD_PATHNAME = $80005000;
E_ADS_INVALID_DOMAIN_OBJECT = $80005001;
E_ADS_INVALID_USER_OBJECT = $80005002;
E_ADS_INVALID_COMPUTER_OBJECT = $80005003;
E_ADS_UNKNOWN_OBJECT = $80005004;
E_ADS_PROPERTY_NOT_SET = $80005005;
E_ADS_PROPERTY_NOT_SUPPORTED = $80005006;
E_ADS_PROPERTY_INVALID = $80005007;
E_ADS_BAD_PARAMETER = $80005008;
E_ADS_OBJECT_UNBOUND = $80005009;
E_ADS_PROPERTY_NOT_MODIFIED = $8000500A;
E_ADS_PROPERTY_MODIFIED = $8000500B;
E_ADS_CANT_CONVERT_DATATYPE = $8000500C;
E_ADS_PROPERTY_NOT_FOUND = $8000500D;
E_ADS_OBJECT_EXISTS = $8000500E;
E_ADS_SCHEMA_VIOLATION = $8000500F;
E_ADS_COLUMN_NOT_SET = $80005010;
E_ADS_INVALID_FILTER = $80005014;
procedure Register;
(*============================================================================*)
(* IMPLEMENTATION *)
(*============================================================================*)
implementation
uses
Windows;
var
ActiveDSHandle : THandle;
gADsGetObject: function(pwcPathName: PWideChar; const xRIID: TGUID; out pVoid): HResult; stdcall;
gFreeADsMem : function(aPtr : Pointer) : BOOL; stdcall;
// Active Directory API helper functions - implemented in ActiveDs.DLL and
// dynamically loaded at time of initialization of this module
function ADsGetObject(pwcPathName: PWideChar; const xRIID: TGUID; var pVoid): HResult;
begin
Result := gADsGetObject(pwcPathName, xRIID, pVoid);
end;
function FreeADsMem(aPtr : Pointer) : BOOL;
begin
Result := gFreeADsMem(aPtr);
end;
// resource strings for all messages - makes localization so much easier!
resourcestring
rc_CannotLoadActiveDS = 'Cannot load ActiveDS.DLL';
rc_CannotGetProcAddress = 'Cannot GetProcAddress of ';
rc_CouldNotBind = 'Could not bind to object %s (%x)';
rc_CouldNotFreeSH = 'Could not free search handle (%x)';
rc_CouldNotGetIDS = 'Could not obtain IDirectorySearch interface for %s (%x)';
rc_GetFirstFailed = 'GetFirstRow failed (%x)';
rc_GetNextFailed = 'GetNextRow failed (%x)';
rc_SearchFailed = 'Search in ADSI failed (result code %x)';
rc_SearchNotExec = 'Search has not been executed yet';
rc_SetSrchPrefFailed = 'Setting the max row limit failed (%x)';
rc_UnknownDataType = '(unknown data type %d)';
// ---------------------------------------------------------------------------
// Constructor and destructor
// ---------------------------------------------------------------------------
constructor TADSISearch.Create(aOwner : TComponent);
begin
inherited Create(aOwner);
FBaseIADs := nil;
FDirSrchIntf := nil;
FAttributes := '';
FBasePath := '';
FFilter := '';
FObjectClass := '*';
FMaxRows := 0;
FPageSize := 100;
FChaseReferrals := False;
FSearchScope := scSubtree;
FSearchExecuted := False;
end;
destructor TADSISearch.Destroy;
begin
if (FSearchHandle <> 0) then
FResult := FDirSrchIntf.CloseSearchHandle(FSearchHandle);
FBaseIADs := nil;
FDirSrchIntf := nil;
inherited;
end;
// ---------------------------------------------------------------------------
// Set and Get methods
// ---------------------------------------------------------------------------
procedure TADSISearch.SetPassword(const Value: WideString);
begin
if (FPassword <> Value) then
begin
FPassword := Value;
end;
end;
procedure TADSISearch.SetUsername(const Value: WideString);
begin
if (FUsername <> Value) then
begin
FUsername := Value;
end;
end;
procedure TADSISearch.SetAttributes(const Value: WideString);
begin
if (FAttributes <> Value) then begin
FAttributes := Value;
end;
end;
// the methods to set the search base always need to update the other property
// as well, in order to make sure the base IADs interface and the BasePath
// property stay in sync
// setting the search base will require a new search
// therefore set internal flag FSearchExecuted to false
procedure TADSISearch.SetBaseIADs(const Value: IADs);
begin
if (FBaseIADs <> Value) then begin
FBaseIADs := Value;
FBasePath := FBaseIADs.ADsPath;
FSearchExecuted := False;
end;
end;
procedure TADSISearch.SetBasePath(const Value: WideString);
begin
if (FBasePath <> Value) then begin
FBasePath := Value;
FBaseIADs := nil;
FSearchExecuted := False;
end;
end;
procedure TADSISearch.SetChaseReferrals(const Value: Boolean);
begin
if (FChaseReferrals <> Value) then begin
FChaseReferrals := Value;
end;
end;
// setting the filter will require a new search
// therefore set internal flag FSearchExecuted to false
procedure TADSISearch.SetFilter(const Value: WideString);
begin
if (FFilter <> Value) then begin
FFilter := Value;
FSearchExecuted := False;
end;
end;
procedure TADSISearch.SetMaxRows(const Value: Integer);
begin
if (Value >= 0) and (Value <> FMaxRows) then begin
FMaxRows := Value;
end;
end;
procedure TADSISearch.SetPageSize(const Value: Integer);
begin
if (Value >= 0) and (Value <> FPageSize) then begin
FPageSize := Value;
end;
end;
// setting the object category will require a new search
// therefore set internal flag FSearchExecuted to false
procedure TADSISearch.SetObjectClass(const Value: Widestring);
begin
if (FObjectClass <> Value) then begin
if (Value = '') then
FObjectClass := '*'
else
FObjectClass := Value;
FSearchExecuted := False;
end;
end;
// ---------------------------------------------------------------------------
// Private helper methods
// ---------------------------------------------------------------------------
// EnumerateColumns iterates through all the columns in the current row of
// the search results and builds the string list of results
{$IFDEF UNICODE}
procedure TADSISearch.EnumerateColumns(aStrList: TWideStringList);
{$ELSE}
procedure TADSISearch.EnumerateColumns(aStrList: TStringList);
{$ENDIF}
var
ix : Integer;
bMultiple : Boolean;
pwColName : PWideChar;
oSrchColumn : ads_search_column;
wsColName, wsValue : WideString;
begin
// determine name of next column to fetch
FResult := FDirSrchIntf.GetNextColumnName(FSearchHandle, pwColName);
// as long as no error occured and we still do have columns....
while Succeeded(FResult) and (FResult <> S_ADS_NOMORE_COLUMNS) do begin
// get the column from the result set
FResult := FDirSrchIntf.GetColumn(FSearchHandle, pwColName, oSrchColumn);
if Succeeded(FResult) then begin
// check if it's a multi-valued attribute
bMultiple := (oSrchColumn.dwNumValues > 1);
if bMultiple then begin
// if it's a multi-valued attribute, iterate through the values
for ix := 0 to oSrchColumn.dwNumValues-1 do begin
wsColName := Format('%s[%d]', [oSrchColumn.pszAttrName, ix]);
wsValue := GetStringValue(oSrchColumn, ix);
aStrList.Add(wsColName + '=' + wsValue);
end;
end
else begin
// single valued attributes are quite straightforward
wsColName := oSrchColumn.pszAttrName;
wsValue := GetStringValue(oSrchColumn, 0);
aStrList.Add(wsColName + '=' + wsValue);
end;
end;
// free the memory associated with the search column, and the column name
FDirSrchIntf.FreeColumn(oSrchColumn);
FreeADsMem(pwColName);
// get next column name
FResult := FDirSrchIntf.GetNextColumnName(FSearchHandle, pwColName);
end;
end;
// Get string value will turn the supported types of data into a string representation
// for inclusion in the resulting string list
// For a complete list of possible values, see the ADSTYPE_xxx constants in the
// ActiveDs_TLB.pas file
function TADSISearch.GetStringValue(oSrchColumn: ads_search_column; Index: Integer): WideString;
var
wrkPointer : PADSValue;
oSysTime : _SYSTEMTIME;
dtDate,
dtTime : TDateTime;
begin
Result := '';
// advance the value pointer to the correct one of the potentially multiple
// values in the "array of values" for this attribute
wrkPointer := oSrchColumn.pADsValues;
Inc(wrkPointer, Index);
// depending on the type of the value, turning it into a string is more
// or less straightforward
case oSrchColumn.dwADsType of
ADSTYPE_CASE_EXACT_STRING : Result := wrkPointer^.__MIDL_0010.CaseExactString;
ADSTYPE_CASE_IGNORE_STRING : Result := wrkPointer^.__MIDL_0010.CaseIgnoreString;
ADSTYPE_DN_STRING : Result := wrkPointer^.__MIDL_0010.DNString;
ADSTYPE_OBJECT_CLASS : Result := wrkPointer^.__MIDL_0010.ClassName;
ADSTYPE_PRINTABLE_STRING : Result := wrkPointer^.__MIDL_0010.PrintableString;
ADSTYPE_NUMERIC_STRING : Result := wrkPointer^.__MIDL_0010.NumericString;
ADSTYPE_BOOLEAN : Result := IntToStr(wrkPointer^.__MIDL_0010.Boolean);
ADSTYPE_INTEGER : Result := IntToStr(wrkPointer^.__MIDL_0010.Integer);
ADSTYPE_LARGE_INTEGER : Result := IntToStr(wrkPointer^.__MIDL_0010.LargeInteger);
ADSTYPE_UTC_TIME:
begin
// ADS_UTC_TIME maps to a _SYSTEMTIME structure
Move(wrkPointer^.__MIDL_0010.UTCTime, oSysTime, SizeOf(oSysTime));
// create two TDateTime values for the date and the time
dtDate := EncodeDate(oSysTime.wYear, oSysTime.wMonth, oSysTime.wDay);
dtTime := EncodeTime(oSysTime.wHour, oSysTime.wMinute, oSysTime.wSecond, oSysTime.wMilliseconds);
// add the two TDateTime's (really only a Float), and turn into a string
Result := DateTimeToStr(dtDate+dtTime);
end;
else Result := Format(rc_UnknownDataType, [oSrchColumn.dwADsType]);
end;
end;
// ---------------------------------------------------------------------------
// Public methods
// ---------------------------------------------------------------------------
// Check if any object matching the criteria as defined in the properties exists
function TADSISearch.CheckIfExists(): Boolean;
var
{$IFDEF UNICODE}
slTemp : TWideStringList;
{$ELSE}
slTemp : TStringList;
{$ENDIF}
iOldMaxRows : Integer;
wsOldAttributes : WideString;
begin
Result := False;
// save the settings of the MaxRows and Attributes properties
iOldMaxRows := FMaxRows;
wsOldAttributes := FAttributes;
try
// set the attributes to return just one row (that's good enough for
// making sure it exists), and the Attribute of instanceType which is
// one attribute that must exist for any of the ADSI objects
FMaxRows := 1;
FAttributes := 'instanceType';
try
Search;
// did we get any results?? If so, at least one object exists!
slTemp := GetFirstRow();
Result := (slTemp <> nil);
slTemp.Free;
except
on EADSISearchException do ;
end;
finally
// restore the attributes to what they were before
FMaxRows := iOldMaxRows;
FAttributes := wsOldAttributes;
end;
end;
{$IFDEF UNICODE}
function TADSISearch.GetFirstRow(): TWideStringList;
var
slTemp : TWideStringList;
{$ELSE}
function TADSISearch.GetFirstRow(): TStringList;
var
slTemp : TStringList;
{$ENDIF}
begin
slTemp := nil;
try
if FSearchExecuted then begin
// get the first row of the result set
FResult := FDirSrchIntf.GetFirstRow(FSearchHandle);
// did we succeed? ATTENTION: if we don't have any more rows,
// we still get a "success" value back from ADSI!!
if Succeeded(FResult) then begin
// any more rows in the result set?
if (FResult <> S_ADS_NOMORE_ROWS) then begin
// create a string list
{$IFDEF UNICODE}
slTemp := TWideStringList.Create;
{$ELSE}
slTemp := TStringList.Create;
{$ENDIF}
// enumerate all columns into that resulting string list
EnumerateColumns(slTemp);
end;
end
else begin
raise EADSISearchException.CreateFmt(rc_GetFirstFailed, [FResult]);
end;
end
else begin
raise EADSISearchException.Create(rc_SearchNotExec);
end;
finally
Result := slTemp;
end;
end;
{$IFDEF UNICODE}
function TADSISearch.GetNextRow(): TWideStringList;
var
slTemp : TWideStringList;
{$ELSE}
function TADSISearch.GetNextRow(): TStringList;
var
slTemp : TStringList;
{$ENDIF}
begin
slTemp := nil;
try
if FSearchExecuted then begin
// get the next row of the result set
FResult := FDirSrchIntf.GetNextRow(FSearchHandle);
// did we succeed? ATTENTION: if we don't have any more rows,
// we still get a "success" value back from ADSI!!
if Succeeded(FResult) then begin
// any more rows in the result set?
if (FResult <> S_ADS_NOMORE_ROWS) then begin
// create result string list
{$IFDEF UNICODE}
slTemp := TWideStringList.Create;
{$ELSE}
slTemp := TStringList.Create;
{$ENDIF}
// enumerate all columns in result set
EnumerateColumns(slTemp);
end;
end
else begin
raise EADSISearchException.CreateFmt(rc_GetNextFailed, [FResult]);
end;
end
else begin
raise EADSISearchException.Create(rc_SearchNotExec);
end;
finally
Result := slTemp;
end;
end;
// this is the core piece of the component - the actual search method
procedure TADSISearch.Search;
var
ix : Integer;
wsFilter : WideString;
{$IFDEF UNICODE}
slTemp : TWideStringList;
{$ELSE}
slTemp : TStringList;
{$ENDIF}
AttrCount : Cardinal;
AttrArray : array of WideString;
SrchPrefInfo : array of ads_searchpref_info;
DSO :IADsOpenDSObject;
Dispatch:IDispatch;
begin
// check to see if we have assigned an IADs, if not, bind to it
if (FBaseIADs = nil) then begin
ADsGetObject('LDAP:', IID_IADsOpenDSObject, DSO);
Dispatch := DSO.OpenDSObject(FBasePath, FUsername, FPassword, ADS_SECURE_AUTHENTICATION);
FResult := Dispatch.QueryInterface(IID_IADs, FBaseIADs);
//FResult := ADsGetObject(#FBasePath[1], IID_IADs, FBaseIADs);
if not Succeeded(FResult) then begin
raise EADSISearchException.CreateFmt(rc_CouldNotBind, [FBasePath, FResult]);
end;
end;
// get the IDirectorySearch interface from the base object
FDirSrchIntf := (FBaseIADs as IDirectorySearch);
if (FDirSrchIntf = nil) then begin
raise EADSISearchException.CreateFmt(rc_CouldNotGetIDS, [FBasePath, FResult]);
end;
// if we still have a valid search handle => close it
if (FSearchHandle <> 0) then begin
FResult := FDirSrchIntf.CloseSearchHandle(FSearchHandle);
if not Succeeded(FResult) then begin
raise EADSISearchException.CreateFmt(rc_CouldNotFreeSH, [FResult]);
end;
end;
// we are currently setting 3 search preferences
// for a complete list of possible search preferences, please check
// the ADS_SEARCHPREF_xxx values in ActiveDs_TLB.pas
SetLength(SrchPrefInfo, 4);
// Set maximum number of rows to be what is defined in the MaxRows property
SrchPrefInfo[0].dwSearchPref := ADS_SEARCHPREF_SIZE_LIMIT;
SrchPrefInfo[0].vValue.dwType := ADSTYPE_INTEGER;
SrchPrefInfo[0].vValue.__MIDL_0010.Integer := FMaxRows;
// set the "chase referrals" search preference
SrchPrefInfo[1].dwSearchPref := ADS_SEARCHPREF_CHASE_REFERRALS;
SrchPrefInfo[1].vValue.dwType := ADSTYPE_BOOLEAN;
SrchPrefInfo[1].vValue.__MIDL_0010.Boolean := Ord(FChaseReferrals);
// set the "search scope" search preference
SrchPrefInfo[2].dwSearchPref := ADS_SEARCHPREF_SEARCH_SCOPE;
SrchPrefInfo[2].vValue.dwType := ADSTYPE_INTEGER;
SrchPrefInfo[2].vValue.__MIDL_0010.Integer := Ord(FSearchScope);
// set the "page size " search preference
SrchPrefInfo[3].dwSearchPref := ADS_SEARCHPREF_PAGESIZE;
SrchPrefInfo[3].vValue.dwType := ADSTYPE_INTEGER;
SrchPrefInfo[3].vValue.__MIDL_0010.Integer := FPageSize;
// set the search preferences of our directory search interface
FResult := FDirSrchIntf.SetSearchPreference(Pointer(SrchPrefInfo), Length(SrchPrefInfo));
if not Succeeded(FResult) then begin
raise EADSISearchException.CreateFmt(rc_SetSrchPrefFailed,
Google for using ADSI with Delphi, you can find some articles talking about that
Active Directory Service Interfaces
Using ADSI in Delphi
and you can also look at online-admin which they offer components to manage many of windows services including AD

Resources