This file I originally found on the Borland Community. I fixed a few
problems.
unit Linldap;
interface
uses
{$IFDEF WIN32}
Windows;
{$ELSE}
Wintypes, WinProcs;
{$ENDIF}
type
ULONG = longword;
UCHAR = byte;
LONG = longint;
PVOID = pointer;
USHORT = word;
PWCHAR = pwidechar;
INT = integer;
PPWCHAR = ^PWCHAR;
PPCHAR = ^PCHAR;
PULONG = ^ULONG;
const
LDAP_PORT = 389;
LDAP_SSL_PORT = 636;
LDAP_VERSION1 = 1;
LDAP_VERSION2 = 2;
LDAP_VERSION3 = 3;
LDAP_VERSION = LDAP_VERSION3;
LDAP_BIND_CMD = $60; // application + constructed
LDAP_UNBIND_CMD = $42; // application + primitive
LDAP_SEARCH_CMD = $63; // application + constructed
LDAP_MODIFY_CMD = $66; // application + constructed
LDAP_ADD_CMD = $68; // application + constructed
LDAP_DELETE_CMD = $4a; // application + primitive
LDAP_MODRDN_CMD = $6c; // application + constructed
LDAP_COMPARE_CMD = $6e; // application + constructed
LDAP_ABANDON_CMD = $50; // application + primitive
LDAP_SESSION_CMD = $71; // application + constructed
LDAP_EXTENDED_CMD = $77; // application + constructed
LDAP_RES_BIND = $61; // application + constructed
LDAP_RES_SEARCH_ENTRY = $64; // application + constructed
LDAP_RES_SEARCH_RESULT = $65; // application + constructed
LDAP_RES_MODIFY = $67; // application + constructed
LDAP_RES_ADD = $69; // application + constructed
LDAP_RES_DELETE = $6b; // application + constructed
LDAP_RES_MODRDN = $6d; // application + constructed
LDAP_RES_COMPARE = $6f; // application + constructed
LDAP_RES_SESSION = $72; // application + constructed
LDAP_RES_REFERRAL = $73; // application + constructed
LDAP_RES_EXTENDED = $78; // application + constructed
LDAP_RES_ANY = -1;
LDAP_INVALID_CMD = $ff;
LDAP_INVALID_RES = $ff;
LDAP_SUCCESS = $00;
LDAP_OPERATIONS_ERROR = $01;
LDAP_PROTOCOL_ERROR = $02;
LDAP_TIMELIMIT_EXCEEDED = $03;
LDAP_SIZELIMIT_EXCEEDED = $04;
LDAP_COMPARE_FALSE = $05;
LDAP_COMPARE_TRUE = $06;
LDAP_AUTH_METHOD_NOT_SUPPORTED = $07;
LDAP_STRONG_AUTH_REQUIRED = $08;
LDAP_REFERRAL_V2 = $09;
LDAP_PARTIAL_RESULTS = $09;
LDAP_REFERRAL = $0a;
LDAP_ADMIN_LIMIT_EXCEEDED = $0b;
LDAP_UNAVAILABLE_CRIT_EXTENSION = $0c;
LDAP_NO_SUCH_ATTRIBUTE = $10;
LDAP_UNDEFINED_TYPE = $11;
LDAP_INAPPROPRIATE_MATCHING = $12;
LDAP_CONSTRAINT_VIOLATION = $13;
LDAP_ATTRIBUTE_OR_VALUE_EXISTS = $14;
LDAP_INVALID_SYNTAX = $15;
LDAP_NO_SUCH_OBJECT = $20;
LDAP_ALIAS_PROBLEM = $21;
LDAP_INVALID_DN_SYNTAX = $22;
LDAP_IS_LEAF = $23;
LDAP_ALIAS_DEREF_PROBLEM = $24;
LDAP_INAPPROPRIATE_AUTH = $30;
LDAP_INVALID_CREDENTIALS = $31;
LDAP_INSUFFICIENT_RIGHTS = $32;
LDAP_BUSY = $33;
LDAP_UNAVAILABLE = $34;
LDAP_UNWILLING_TO_PERFORM = $35;
LDAP_LOOP_DETECT = $36;
LDAP_NAMING_VIOLATION = $40;
LDAP_OBJECT_CLASS_VIOLATION = $41;
LDAP_NOT_ALLOWED_ON_NONLEAF = $42;
LDAP_NOT_ALLOWED_ON_RDN = $43;
LDAP_ALREADY_EXISTS = $44;
LDAP_NO_OBJECT_CLASS_MODS = $45;
LDAP_RESULTS_TOO_LARGE = $46;
LDAP_AFFECTS_MULTIPLE_DSAS = $47;
LDAP_OTHER = $50;
LDAP_SERVER_DOWN = $51;
LDAP_LOCAL_ERROR = $52;
LDAP_ENCODING_ERROR = $53;
LDAP_DECODING_ERROR = $54;
LDAP_TIMEOUT = $55;
LDAP_AUTH_UNKNOWN = $56;
LDAP_FILTER_ERROR = $57;
LDAP_USER_CANCELLED = $58;
LDAP_PARAM_ERROR = $59;
LDAP_NO_MEMORY = $5a;
type
LDAP_RETCODE = integer;
const
LDAP_AUTH_SIMPLE = $80;
LDAP_AUTH_SASL = $83;
LDAP_AUTH_OTHERKIND = $86;
LDAP_AUTH_SICILY =(LDAP_AUTH_OTHERKIND or $0200);
LDAP_AUTH_MSN =(LDAP_AUTH_OTHERKIND or $0800);
LDAP_AUTH_NTLM =(LDAP_AUTH_OTHERKIND or $1000);
LDAP_AUTH_DPA =(LDAP_AUTH_OTHERKIND or $2000);
LDAP_AUTH_NEGOTIATE =(LDAP_AUTH_OTHERKIND or $0400);
LDAP_AUTH_SSPI =LDAP_AUTH_NEGOTIATE;
LDAP_FILTER_AND = $a0; // context specific + constructed -
SET OF Filters.
LDAP_FILTER_OR = $a1; // context specific + constructed -
SET OF Filters.
LDAP_FILTER_NOT = $a2; // context specific + constructed -
Filter
LDAP_FILTER_EQUALITY = $a3; // context specific + constructed -
AttributeValueAssertion.
LDAP_FILTER_SUBSTRINGS = $a4; // context specific + constructed -
SubstringFilter
LDAP_FILTER_GE = $a5; // context specific + constructed -
AttributeValueAssertion.
LDAP_FILTER_LE = $a6; // context specific + constructed -
AttributeValueAssertion.
LDAP_FILTER_PRESENT = $87; // context specific + primitive -
AttributeType.
LDAP_FILTER_APPROX = $a8; // context specific + constructed -
AttributeValueAssertion.
LDAP_SUBSTRING_INITIAL = $80; // class context specific
LDAP_SUBSTRING_ANY = $81; // class context specific
LDAP_SUBSTRING_FINAL = $82; // class context specific
LDAP_DEREF_NEVER = 0;
LDAP_DEREF_SEARCHING = 1;
LDAP_DEREF_FINDING = 2;
LDAP_DEREF_ALWAYS = 3;
LDAP_NO_LIMIT = 0;
LDAP_OPT_DNS = $00000001; // utilize DN & DNS
LDAP_OPT_CHASE_REFERRALS = $00000002; // chase referrals
LDAP_OPT_RETURN_REFS = $00000004; // return referrals to
calling app
LDAP_OPT_PROTOCOL_VERSION = $00000011; // Set LDAP Version
SEC_WINNT_AUTH_IDENTITY_ANSI = $1;
SEC_WINNT_AUTH_IDENTITY_UNICODE = $2;
{$ALIGN ON}
type
PLDAP = ^LDAP;
LDAP = record
ld_sb: record
sb_sd: ULONG;
Reserved1: array [0..(10*sizeof(ULONG))] of UCHAR;
sb_naddr: ULONG; // notzero implies CLDAP available
Reserved2: array [0..(6*sizeof(ULONG))] of UCHAR;
end;
ld_host: PCHAR;
ld_version: ULONG;
ld_lberoptions: UCHAR;
ld_deref: ULONG;
ld_timelimit: ULONG;
ld_sizelimit: ULONG;
ld_errno: ULONG;
ld_matched: PCHAR;
ld_error: PCHAR;
ld_msgid: ULONG;
Reserved3: array [0..(6*sizeof(ULONG))] of UCHAR;
ld_cldaptries: ULONG;
ld_cldaptimeout: ULONG;
ld_refhoplimit: ULONG;
ld_options: ULONG;
end;
PLDAP_TIMEVAL = ^LDAP_TIMEVAL;
LDAP_TIMEVAL = record
tv_sec: LONG;
tv_usec: LONG;
end;
PPLDAP_BERVAL = ^PLDAP_BERVAL;
PLDAP_BERVAL = ^LDAP_BERVAL;
LDAP_BERVAL = record
bv_len: ULONG;
bv_val: PCHAR;
end;
PPLDAPMessage = ^PLDAPMessage;
PLDAPMessage = ^LDAPMessage;
LDAPMessage = record
lm_msgid: ULONG; // message number for given connection
lm_msgtype: ULONG; // message type of the form
LDAP_RES_xxx
lm_ber: PVOID; // ber form of message
lm_chain: PLDAPMessage; // pointer to next result value
lm_next: PLDAPMessage; // pointer to next message
lm_time: ULONG;
Connection: PLDAP; // connection from which we received
response
Request: PVOID; // owning request(opaque structure)
lm_returncode: ULONG; // server's return code
lm_hopcount: USHORT; // hop count for number of referrals
followed
end;
const
LDAP_MOD_ADD = $00;
LDAP_MOD_DELETE = $01;
LDAP_MOD_REPLACE = $02;
LDAP_MOD_NOCHANGE = $0F;
LDAP_MOD_BVALUES = $80;
type
PLDAPMod = ^LDAPMod;
LDAPMod = record
mod_op: ULONG;
mod_type: PCHAR;
modv_strvals: array of PChar;
// modvals: record
// case integer of
// 0:(modv_strvals: ^PCHAR);
// 1:(modv_bvals: ^PLDAP_BERVAL);
// end;
end;
// XXX #pragma pack(pop)
{$ALIGN OFF}
//
// macros compatible with reference implementation...
//
function LDAP_IS_CLDAP(ld: PLDAP): boolean;
function NAME_ERROR(n: integer): boolean;
function ldap_open(HostName: PCHAR; PortNumber: ULONG): PLDAP; cdecl;
function ldap_init(HostName: PCHAR; PortNumber: ULONG): PLDAP; cdecl;
function ldap_sslinit(HostName: PCHAR; PortNumber: ULONG; secure:
integer): PLDAP; cdecl;
function ldap_connect (ld: PLDAP; timeout : PLDAP_TIMEVAL) : ULONG;
cdecl;
function cldap_open(HostName: PCHAR; PortNumber: ULONG): PLDAP; cdecl;
function ldap_unbind(ld: PLDAP): ULONG; cdecl;
function ldap_unbind_s(ld: PLDAP): ULONG; cdecl; // calls ldap_unbind
function ldap_get_option(ld: PLDAP; option: integer; outvalue: pointer):
ULONG; cdecl;
function ldap_set_option(ld: PLDAP; option: integer; invalue: pointer):
ULONG; cdecl;
const
LDAP_OPT_DESC = $01;
LDAP_OPT_DEREF = $02;
LDAP_OPT_SIZELIMIT = $03;
LDAP_OPT_TIMELIMIT = $04;
LDAP_OPT_THREAD_FN_PTRS = $05;
LDAP_OPT_REBIND_FN = $06;
LDAP_OPT_REBIND_ARG = $07;
LDAP_OPT_REFERRALS = $08;
LDAP_OPT_RESTART = $09;
LDAP_OPT_IO_FN_PTRS = $0a;
LDAP_OPT_CACHE_FN_PTRS = $0c;
LDAP_OPT_CACHE_STRATEGY = $0d;
LDAP_OPT_CACHE_ENABLE = $0e;
LDAP_OPT_SSL = $0f;
LDAP_OPT_VERSION = $10;
LDAP_OPT_SORTKEYS = $11;
//
// These are new ones that we've defined, not in current RFC draft.
//
LDAP_OPT_HOST_NAME = $30;
LDAP_OPT_ERROR_NUMBER = $31;
LDAP_OPT_ERROR_STRING = $32;
LDAP_OPT_ON = pointer(1);
LDAP_OPT_OFF = pointer(0);
function ldap_simple_bind(ld: PLDAP; dn: PCHAR; passwd: PCHAR): ULONG;
cdecl;
function ldap_simple_bind_s(ld: PLDAP; dn: PCHAR; passwd: PCHAR): ULONG;
cdecl;
function ldap_bind(ld: PLDAP; dn: PCHAR; cred: PCHAR; method: ULONG):
ULONG; cdecl;
function ldap_bind_s(ld: PLDAP; dn: PCHAR; cred: PCHAR; method: ULONG):
ULONG; cdecl;
const
LDAP_SCOPE_BASE = $00;
LDAP_SCOPE_ONELEVEL = $01;
LDAP_SCOPE_SUBTREE = $02;
function ldap_search(
ld: PLDAP;
base: PCHAR; // distinguished name or ""
scope: ULONG; // LDAP_SCOPE_xxxx
filter: PCHAR;
attrs: PCHAR; // pointer to an array of PCHAR
attribute names
attrsonly: ULONG // boolean on whether to only return
attr names
): ULONG; cdecl;
function ldap_search_s(
ld: PLDAP;
base: PCHAR;
scope: ULONG;
filter: PCHAR;
attrs: PCHAR;
attrsonly: ULONG;
res: PPLDAPMessage
): ULONG; cdecl;
function ldap_search_st(
ld: PLDAP;
base: PCHAR;
scope: ULONG;
filter: PCHAR;
attrs: PCHAR;
attrsonly: ULONG;
timeout: PLDAP_TIMEVAL;
res: PPLDAPMessage
): ULONG; cdecl;
function ldap_modify(ld: PLDAP; dn: PCHAR; mods: PLDAPMod): ULONG;
cdecl;
function ldap_modify_s(ld: PLDAP; dn: PCHAR; mods: PLDAPMod): ULONG;
cdecl;
function ldap_modrdn2(
ExternalHandle: PLDAP;
DistinguishedName: PCHAR;
NewDistinguishedName: PCHAR;
DeleteOldRdn: INT
): ULONG; cdecl;
function ldap_modrdn(
ExternalHandle: PLDAP;
DistinguishedName: PCHAR;
NewDistinguishedName: PCHAR
): ULONG; cdecl;
function ldap_modrdn2_s(
ExternalHandle: PLDAP;
DistinguishedName: PCHAR;
NewDistinguishedName: PCHAR;
DeleteOldRdn: INT
): ULONG; cdecl;
function ldap_modrdn_s(
ExternalHandle: PLDAP;
DistinguishedName: PCHAR;
NewDistinguishedName: PCHAR
): ULONG; cdecl;
function ldap_add(ld: PLDAP; dn: PCHAR; attrs: PLDAPMod): ULONG; cdecl;
stdcall
function ldap_add_s(ld: PLDAP; dn: PCHAR; attrs: PLDAPMod): ULONG;
cdecl;
function ldap_compare(ld: PLDAP; dn: PCHAR; attr: PCHAR; value: PCHAR):
ULONG; cdecl;
function ldap_compare_s(ld: PLDAP; dn: PCHAR; attr: PCHAR; value:
PCHAR): ULONG; cdecl;
function ldap_delete(ld: PLDAP; dn: PCHAR): ULONG; cdecl;
function ldap_delete_s(ld: PLDAP; dn: PCHAR): ULONG; cdecl;
function ldap_abandon(ld: PLDAP; msgid: ULONG): ULONG; cdecl;
const
LDAP_MSG_ONE = 0;
LDAP_MSG_ALL = 1;
LDAP_MSG_RECEIVED = 2;
function ldap_result(
ld: PLDAP;
msgid: ULONG;
all: ULONG;
timeout: PLDAP_TIMEVAL;
res: PPLDAPMessage
): ULONG; cdecl;
function ldap_msgfree(res: PLDAPMessage): ULONG; cdecl;
function ldap_result2error(
ld: PLDAP;
res: PLDAPMessage;
freeit: ULONG // boolean.. free the message?
): ULONG; cdecl;
function ldap_err2string(err: ULONG): PCHAR; cdecl;
procedure ldap_perror(ld: PLDAP; msg: PCHAR); cdecl;
function ldap_first_entry(ld: PLDAP; res: PLDAPMessage): PLDAPMessage;
cdecl;
function ldap_next_entry(ld: PLDAP; entry: PLDAPMessage): PLDAPMessage;
cdecl;
function ldap_count_entries(ld: PLDAP; res: PLDAPMessage): ULONG; cdecl;
type
PBerElement = ^BerElement;
BerElement = record
opaque: PCHAR; // this is an opaque structure used just for
// compatibility with reference implementation
end;
const
NULLBER = PBerElement(0);
function ldap_first_attribute(
ld: PLDAP;
entry: PLDAPMessage;
var ptr: PBerElement
): PCHAR; cdecl;
function ldap_next_attribute(
ld: PLDAP;
entry: PLDAPMessage;
ptr: PBerElement
): PCHAR; cdecl;
function ldap_get_values(
ld: PLDAP;
entry: PLDAPMessage;
attr: PCHAR
): PPCHAR; cdecl;
function ldap_get_values_len(
ExternalHandle: PLDAP;
Message: PLDAPMessage;
attr: PCHAR
): PPLDAP_BERVAL; cdecl;
function ldap_count_values(vals: PPCHAR): ULONG; cdecl;
function ldap_count_values_len(vals: PPLDAP_BERVAL): ULONG; cdecl;
function ldap_value_free(vals: PPCHAR): ULONG; cdecl;
function ldap_value_free_len(vals: PPLDAP_BERVAL): ULONG; cdecl;
function ldap_get_dn(ld: PLDAP; entry: PLDAPMessage): PCHAR; cdecl;
function ldap_explode_dn(dn: PCHAR; notypes: ULONG): PPCHAR; cdecl;
function ldap_dn2ufn(dn: PCHAR): PCHAR; cdecl;
procedure ldap_memfree(Block: PCHAR); cdecl;
function ldap_ufn2dn(ufn: PCHAR; pDn: PPCHAR): ULONG; cdecl;
const
LBER_USE_DER = $01;
LBER_USE_INDEFINITE_LEN = $02;
LBER_TRANSLATE_STRINGS = $04;
LAPI_MAJOR_VER1 = 1;
LAPI_MINOR_VER1 = 1;
type
PLDAP_VERSION_INFO = ^LDAP_VERSION_INFO;
LDAP_VERSION_INFO = record
lv_size: ULONG;
lv_major: ULONG;
lv_minor: ULONG;
end;
function ldap_startup(
version: PLDAP_VERSION_INFO
): ULONG; cdecl;
function ldap_cleanup : ULONG; cdecl;
function ldap_escape_filter_element(
sourceFilterElement: PCHAR;
sourceLength: ULONG;
destFilterElement: PCHAR;
destLength: ULONG
): ULONG; cdecl;
function ldap_set_dbg_flags(NewFlags: ULONG): ULONG; cdecl;
implementation
{$IFDEF LINUX}
const
sLDAPLIB = 'libldapssl41.so';
{$ENDIF}
{$IFDEF WIN32}
const
sLDAPLIB = 'wldap32.dll';
{$ENDIF}
function ldap_open; external sLDAPLIB name 'ldap_open';
function ldap_init; external sLDAPLIB name 'ldap_init';
function ldap_sslinit; external sLDAPLIB name 'ldap_sslinit';
function cldap_open; external sLDAPLIB name 'cldap_open';
function ldap_connect; external sLDAPLIB name 'ldap_connect';
function ldap_simple_bind; external sLDAPLIB name 'ldap_simple_bind';
function ldap_simple_bind_s; external sLDAPLIB name
'ldap_simple_bind_s';
function ldap_bind; external sLDAPLIB name 'ldap_bind';
function ldap_bind_s; external sLDAPLIB name 'ldap_bind_s';
function ldap_search; external sLDAPLIB name 'ldap_search';
function ldap_search_s; external sLDAPLIB name 'ldap_search_s';
function ldap_search_st; external sLDAPLIB name 'ldap_search_st';
function ldap_modify; external sLDAPLIB name 'ldap_modify';
function ldap_modify_s; external sLDAPLIB name 'ldap_modify_s';
function ldap_modrdn2; external sLDAPLIB name 'ldap_modrdn2';
function ldap_modrdn; external sLDAPLIB name 'ldap_modrdn';
function ldap_modrdn2_s; external sLDAPLIB name 'ldap_modrdn2_s';
function ldap_modrdn_s; external sLDAPLIB name 'ldap_modrdn_s';
function ldap_add; external sLDAPLIB name 'ldap_add';
function ldap_add_s; external sLDAPLIB name 'ldap_add_s';
function ldap_compare; external sLDAPLIB name 'ldap_compare';
function ldap_compare_s; external sLDAPLIB name 'ldap_compare_s';
function ldap_delete; external sLDAPLIB name 'ldap_delete';
function ldap_delete_s; external sLDAPLIB name 'ldap_delete_s';
function ldap_err2string; external sLDAPLIB name 'ldap_err2string';
function ldap_first_attribute; external sLDAPLIB name
'ldap_first_attribute';
function ldap_next_attribute; external sLDAPLIB name
'ldap_next_attribute';
function ldap_get_values; external sLDAPLIB name 'ldap_get_values';
function ldap_get_values_len; external sLDAPLIB name
'ldap_get_values_len';
function ldap_count_values; external sLDAPLIB name 'ldap_count_values';
function ldap_value_free; external sLDAPLIB name 'ldap_value_free';
function ldap_get_dn; external sLDAPLIB name 'ldap_get_dn';
function ldap_explode_dn; external sLDAPLIB name 'ldap_explode_dn';
function ldap_dn2ufn; external sLDAPLIB name 'ldap_dn2ufn';
procedure ldap_memfree; external sLDAPLIB name 'ldap_memfree';
function ldap_unbind; external sLDAPLIB name 'ldap_unbind';
function ldap_unbind_s; external sLDAPLIB name 'ldap_unbind_s';
function ldap_get_option; external sLDAPLIB name 'ldap_get_option';
function ldap_set_option; external sLDAPLIB name 'ldap_set_option';
function ldap_abandon; external sLDAPLIB name 'ldap_abandon';
function ldap_ufn2dn; external sLDAPLIB name 'ldap_ufn2dn';
function ldap_escape_filter_element; external sLDAPLIB name
'ldap_escape_filter_element';
function ldap_result; external sLDAPLIB name 'ldap_result';
function ldap_msgfree; external sLDAPLIB name 'ldap_msgfree';
function ldap_result2error; external sLDAPLIB name 'ldap_result2error';
procedure ldap_perror; external sLDAPLIB name 'ldap_perror';
function ldap_first_entry; external sLDAPLIB name 'ldap_first_entry';
function ldap_next_entry; external sLDAPLIB name 'ldap_next_entry';
function ldap_count_entries; external sLDAPLIB name
'ldap_count_entries';
function ldap_count_values_len; external sLDAPLIB name
'ldap_count_entries_len';
function ldap_value_free_len; external sLDAPLIB name
'ldap_value_free_len';
function ldap_startup; external sLDAPLIB name 'ldap_startup';
function ldap_cleanup; external sLDAPLIB name 'ldap_cleanup';
function ldap_set_dbg_flags; external sLDAPLIB name
'ldap_set_dbg_flags';
function LDAP_IS_CLDAP(ld: PLDAP): boolean;
begin
Result :=(ld^.ld_sb.sb_naddr > 0);
end;
function NAME_ERROR(n: integer): boolean;
begin
Result :=((n and $f0) = $20);
end;
end.
This is my wrapper class for using LDAP.
unit CEAADS;
interface
uses
SysUtils, Classes, Controls, ActiveX, {ActiveDS_TLB,} Dialogs,
Variants,
GenUtils, LinLDAP;
const
// LDAP_SERVER = '172.28.2.3'; // Production IP
LDAP_SERVER = 'LDAP';
LDAP_PORT = 389;
LDAP_ROOT = 'DC=chugachelectric,DC=com';
LDAP_EMPLOYEE_ID = 'employeeID';
LDAP_USER = '[EMAIL PROTECTED]';
LDAP_PASSWORD = 'somepassword';
LDAP_FILTER = 'sAMAccountName=';
LDAP_GROUP_ATTRIBUTE = 'memberOf';
LDAP_QUERY_LIMIT = 10;
CR_LF : String = Chr (13) + Chr (10);
type
PCharArray = Array of PChar;
{
TKnownTypes = Array of IADsPropertyValue;
TProviderTypes = Array of IADsPropertyValue2;
}
TCEAADS = class(TWinControl)
private
{ Private declarations }
FConnected : Boolean;
FUserDN : String;
function GetEmployeeID : String;
function GetGroupMembership : String;
function GetAttributeCount : Integer;
function GetAttributeList : Variant;
protected
{ Protected declarations }
FptrLDAP : PLDAP;
// FPropertyList : IADsPropertyList;
FAttributeList : TStringList;
public
{ Public declarations }
Constructor Create(AOwner: TComponent); override;
Destructor Destroy; override;
function MemberOfGroup (Group : String) : Boolean;
function GetAttribute (Attribute : String ) : String;
function GetAttributeValues (Index : Integer) : Variant; overload;
function GetAttributeValues (Attribute : String) : Variant;
overload;
published
{ Published declarations }
property Connected : Boolean read FConnected;
property EmployeeID : String read GetEmployeeID;
property GroupMembership : String read GetGroupMembership;
property UserDN : String read FUserDN;
property AttributeCount : Integer read GetAttributeCount;
property AttributeList : Variant read GetAttributeList;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('CEA Tools', [TCEAADS]);
end;
Constructor TCEAADS.Create(AOwner: TComponent);
var
Res : ULONG;
Version : ULONG;
ptrVersion : PULONG;
Size : ULONG;
ptrSize : PULONG;
Filter : String;
User : String;
NumResults : ULONG;
plmSearch : PLDAPMessage;
plmEntry : PLDAPMessage;
pAttribute : PChar;
pbe : PBerElement;
ppcVals : PPCHAR;
i : Integer;
AttValues : TStringList;
begin
inherited Create (AOwner);
FConnected := False;
FUserDN := '';
FAttributeList := TStringList.Create;
FptrLDAP := ldap_Init (LDAP_SERVER,LDAP_PORT);
Try
Version := LDAP_VERSION3;
ptrVersion := @Version;
Size := LDAP_QUERY_LIMIT;
ptrSize := @Size;
Res := ldap_Set_Option
(FptrLDAP,LDAP_OPT_PROTOCOL_VERSION,ptrVersion);
If Res = LDAP_SUCCESS Then
Res := ldap_Set_Option
(FptrLDAP,LDAP_OPT_SIZELIMIT,ptrSize);
If Res = LDAP_SUCCESS Then
Res := ldap_Connect (FptrLDAP,nil);
If Res = LDAP_SUCCESS Then
Res := ldap_Simple_Bind_S (FptrLDAP,PChar
(LDAP_USER),PChar (LDAP_PASSWORD));
NumResults := 0;
If Res = LDAP_SUCCESS Then
Begin
User := CurrentUser;
Filter := LDAP_FILTER + User;
Res := ldap_Search_S (FptrLDAP,PChar
(LDAP_ROOT),LDAP_SCOPE_SUBTREE,
PChar (Filter),Nil,0,@plmSearch);
If Res = LDAP_SUCCESS Then
Begin
NumResults := ldap_Count_Entries(FptrLDAP,plmSearch);
If NumResults = 0 Then
ShowMessage ('Unable to Find Record for User - ' + User)
Else
Begin
plmEntry := ldap_First_Entry (FptrLDAP,plmSearch);
FUserDN := ldap_Get_DN (FptrLDAP,plmEntry);
pAttribute := ldap_First_Attribute(FptrLDAP, plmEntry, pbe);
While Assigned (pAttribute) Do
Begin
AttValues := TStringList.Create;
FAttributeList.AddObject(pAttribute,AttValues);
ppcVals := ldap_Get_Values(FptrLDAP, plmEntry, pAttribute);
if Assigned(ppcVals) then
Begin
i := 0;
while Assigned(pchararray(ppcVals)[i]) do
begin
AttValues.Add(pchararray(ppcVals)[i]);
i := i + 1;
end;
End;
pAttribute := ldap_Next_Attribute(FptrLDAP, plmEntry, pbe);
End;
End;
End;
End;
If Res = LDAP_SUCCESS Then
FConnected := NumResults > 0
Else
ShowMessage ('Error : ' + IntToStr (Res) + ', ' + ldap_Err2String
(Res));
Except
on E: Exception do
Begin
ShowMessage (E.Message + CR_LF);
End;
End;
end;
Destructor TCEAADS.Destroy;
var
i : Integer;
begin
ldap_Unbind (FptrLDAP);
For i := FAttributeList.Count - 1 DownTo 0 Do
FAttributeList.Objects [i].Free;
FAttributeList.Free;
inherited Destroy;
end;
function TCEAADS.GetAttributeCount : Integer;
begin
Result := FAttributeList.Count;
end;
function TCEAADS.GetAttributeList : Variant;
var
i : Integer;
begin
Result := Null;
If FAttributeList.Count > 0 Then
Begin
Result := VarArrayCreate([0,FAttributeList.Count - 1],
varVariant);
For i := 0 To FAttributeList.Count - 1 Do
Result [i] := FAttributeList.Strings [i];
End;
end;
function TCEAADS.GetAttributeValues (Index : Integer) : Variant;
var
i : Integer;
Values : TStringList;
begin
Result := Null;
If (Index >= 0) And (Index < FAttributeList.Count) Then
Begin
Values := TStringList (FAttributeList.Objects [Index]);
If Values.Count > 0 Then
Begin
Result := VarArrayCreate([0,Values.Count - 1], varVariant);
For i := 0 To Values.Count - 1 Do
Result [i] := Values.Strings [i];
End;
End;
end;
function TCEAADS.GetAttributeValues (Attribute : String) : Variant;
var
i : Integer;
begin
Result := Null;
i := 0;
While (i < FAttributeList.Count) And VarIsNull (Result) Do
Begin
If CompareText (FAttributeList.Strings [i],Attribute) = 0 Then
Result := GetAttributeValues (i);
i := i + 1;
End;
end;
function TCEAADS.GetEmployeeID : String;
begin
Result := GetAttribute (LDAP_EMPLOYEE_ID);
end;
function TCEAADS.GetGroupMembership : String;
var
i : Integer;
ValueList : Variant;
begin
Result := '';
ValueList := GetAttributeValues (LDAP_GROUP_ATTRIBUTE);
If VarIsArray (ValueList) Then
Begin
i := 0;
While i <= VarArrayHighBound (ValueList,1) Do
Begin
If i = 0 Then
Result := ValueList [i]
Else
Result := Result + ';' + ValueList [i];
i := i + 1;
End;
End;
end;
function TCEAADS.GetAttribute (Attribute : String ) : String;
var
ValueList : Variant;
begin
Result := '';
ValueList := GetAttributeValues (Attribute);
If VarIsArray (ValueList) Then
Result := ValueList [0];
end;
function TCEAADS.MemberOfGroup (Group : String) : Boolean;
var
i : Integer;
ValueList : Variant;
begin
Result := False;
ValueList := GetAttributeValues (LDAP_GROUP_ATTRIBUTE);
If VarIsArray (ValueList) Then
Begin
i := 0;
While Not Result And (i <= VarArrayHighBound (ValueList,1)) Do
Begin
If CompareText (Group,ValueList [i]) = 0 Then
Result := True;
i := i + 1;
End;
End;
end;
end.
This is a file of utilities that I have used since Delphi 3 days.
unit GenUtils;
interface
uses Windows, SysUtils, Forms, Dialogs, Controls, Classes, Registry,
CEAStrUtils, ShellAPI, Graphics;
function IsDelphiRunning: Boolean;
function IsModuleRunning(ModuleName: string): Boolean;
function IsRunFromDelphi3IDE: Boolean;
function GetDOSEnvVar(DOSVar: string): string;
function CurrentUser: string;
function CurrentComputer: string;
function ProgramsLoc: string;
function StartMenuLoc: string;
function StartupLoc: string;
function DesktopLoc: string;
function SendToLoc: string;
function TempLoc: string;
function LaunchApp(AppName, Parameters: string; WaitUntilFinished:
Boolean): Boolean;
procedure CenterForm(Form: TForm);
function ColorToText(Value: TColor): string;
function TextToColor(Value: string): TColor;
function StrToFloatDef(Value: string; Default: Extended): Extended;
procedure CopyPhysicalFile (sSourceFileName, sTargetFileName : String);
procedure WriteLogFile (sFileName, sMessage : String);
// Inline iif functions
{$ifdef VER130}
function iif(bCondition: boolean; iTrue, iFalse: integer): integer;
overload;
function iif(bCondition: boolean; sTrue, sFalse: string): string;
overload;
function iif(bCondition: boolean; rTrue, rFalse: real): real; overload;
function iif(bCondition: boolean; objTrue, objFalse: TObject): TObject;
overload;
{$endif}
function iifv(bCondition: boolean; vTrue, vFalse: variant): variant;
implementation
{
IsModuleRunning : Determines if the passed module is running.
}
function IsModuleRunning(ModuleName: string): Boolean;
var
AcModule: array [0..127] of Char;
begin
StrPCopy(AcModule, ModuleName);
IsModuleRunning := GetModuleHandle(AcModule) <> 0;
end;
function IsDelphiRunning: Boolean;
begin
Result:=FindWindow('TAppBuilder', Nil) <> 0;
end;
function GetDOSEnvVar(DOSVar: string): string;
var
pBuffer : PChar;
dwSize : DWORD;
begin
dwSize := 255;
GetMem( pBuffer, dwSize );
try
GetEnvironmentVariable(pchar(DOSVar), pBuffer, dwSize );
Result := pBuffer;
finally
FreeMem( pBuffer );
end;
end;
function CurrentUser: string;
var
pUser: array[0..254] of char;
{$ifdef VER130}
iSize: cardinal;
{$else}
iSize: dword;
{$endif}
begin
iSize:=255;
GetUserName(pUser, iSize);
Result:=pUser;
end;
function CurrentComputer: string;
var
pComputer: array[0..254] of char;
{$ifdef VER130}
iSize: cardinal;
{$else}
iSize: dword;
{$endif}
begin
iSize:=255;
GetComputerName(pComputer, iSize);
Result:=pComputer;
end;
function ProgramsLoc: string;
var
objReg: TRegistry;
begin
objReg:=TRegistry.Create;
try
objReg.RootKey:=HKEY_CURRENT_USER;
objReg.OpenKey('Software',false);
objReg.OpenKey('Microsoft',false);
objReg.OpenKey('Windows',false);
objReg.OpenKey('CurrentVersion',false);
objReg.OpenKey('Explorer',false);
objReg.OpenKey('Shell Folders',false);
try
Result:=objReg.ReadString('Programs');
except
Result:='';
end;
finally
objReg.free;
end;
end;
function StartMenuLoc: string;
var
objReg: TRegistry;
begin
objReg:=TRegistry.Create;
try
objReg.RootKey:=HKEY_CURRENT_USER;
objReg.OpenKey('Software',false);
objReg.OpenKey('Microsoft',false);
objReg.OpenKey('Windows',false);
objReg.OpenKey('CurrentVersion',false);
objReg.OpenKey('Explorer',false);
objReg.OpenKey('Shell Folders',false);
try
Result:=objReg.ReadString('Start Menu');
except
Result:='';
end;
finally
objReg.free;
end;
end;
function StartupLoc: string;
var
objReg: TRegistry;
begin
objReg:=TRegistry.Create;
try
objReg.RootKey:=HKEY_CURRENT_USER;
objReg.OpenKey('Software',false);
objReg.OpenKey('Microsoft',false);
objReg.OpenKey('Windows',false);
objReg.OpenKey('CurrentVersion',false);
objReg.OpenKey('Explorer',false);
objReg.OpenKey('Shell Folders',false);
try
Result:=objReg.ReadString('Startup');
except
Result:='';
end;
finally
objReg.free;
end;
end;
function DesktopLoc: string;
var
objReg: TRegistry;
begin
objReg:=TRegistry.Create;
try
objReg.RootKey:=HKEY_CURRENT_USER;
objReg.OpenKey('Software',false);
objReg.OpenKey('Microsoft',false);
objReg.OpenKey('Windows',false);
objReg.OpenKey('CurrentVersion',false);
objReg.OpenKey('Explorer',false);
objReg.OpenKey('Shell Folders',false);
try
Result:=objReg.ReadString('Desktop');
except
Result:='';
end;
finally
objReg.free;
end;
end;
function SendToLoc: string;
var
objReg: TRegistry;
begin
objReg:=TRegistry.Create;
try
objReg.RootKey:=HKEY_CURRENT_USER;
objReg.OpenKey('Software',false);
objReg.OpenKey('Microsoft',false);
objReg.OpenKey('Windows',false);
objReg.OpenKey('CurrentVersion',false);
objReg.OpenKey('Explorer',false);
objReg.OpenKey('Shell Folders',false);
try
Result:=objReg.ReadString('Sendto');
except
Result:='';
end;
finally
objReg.free;
end;
end;
function IsRunFromDelphi3IDE: Boolean;
var
iWindow: integer;
sCaption, sExe: string;
pBuffer: array[0..255] of char;
begin
Result:=false;
iWindow:=FindWindow('TAppBuilder',Nil);
if iWindow <> 0 then
begin
GetWindowText(iWindow,pBuffer,254);
sCaption:=pBuffer;
sCaption:=Trim(ParseString(sCaption,'-[',2));
sExe:=ExtractFileName(Application.ExeName);
if pos('.',sExe) > 0 then sExe:=copy(sExe,1,pos('.',sExe) - 1);
if uppercase(sExe) = uppercase(sCaption) then Result:=true;
end;
//Result:=FindWindow(Nil, PChar('Delphi 3 - ' + Application.Title + '
[Running]')) <> 0;
end;
function TempLoc: string;
var
iLen: integer;
pBuff: array[0..256] of char;
begin
iLen:=sizeof(pBuff);
GetTempPath(iLen, pBuff);
Result:=pBuff;
end;
function LaunchApp(AppName, Parameters: string; WaitUntilFinished:
Boolean): Boolean;
var
pFile: array[0..254] of char;
pParameters: array[0..254] of char;
si: TStartupInfo;
pi: TProcessInformation;
{$ifdef VER130}
iExitCode: cardinal;
{$else}
iExitCode: dword;
{$endif}
bResult: boolean;
begin
bResult:=False;
if fileexists(AppName) then
begin
strpcopy(pFile, AppName);
strpcopy(pParameters, AppName+' '+Parameters);
zeromemory(@si, sizeof(TStartupInfo));
zeromemory(@pi, sizeof(TProcessInformation));
si.cb:=sizeof(TStartupInfo);
si.dwFlags:=STARTF_USESHOWWINDOW;
si.wShowWindow:=SW_SHOWNORMAL;
createprocess(pFile, pParameters, Nil, Nil, False, 0, Nil, Nil, si,
pi);
if pi.hProcess > 0 then
begin
iExitCode := STILL_ACTIVE;
bResult:=True;
if WaitUntilFinished then
begin
while (iExitCode = STILL_ACTIVE) do
begin
WaitForSingleObject(pi.hProcess, 0);
GetExitCodeProcess(pi.hProcess, iExitCode);
application.ProcessMessages;
end;
end;
end;
end;
Result:=bResult;
end;
procedure CenterForm(Form: TForm);
begin
Form.Left:=(screen.Width - Form.Width) div 2;
Form.Top:=(screen.Height - Form.Height) div 2;
end;
// The following are overloaded inline if functions
{$ifdef VER130}
function iif(bCondition: boolean; iTrue, iFalse: integer): integer;
overload;
begin
if bCondition then
Result:=iTrue
else
Result:=iFalse;
end;
function iif(bCondition: boolean; sTrue, sFalse: string): string;
overload;
begin
if bCondition then
Result:=sTrue
else
Result:=sFalse;
end;
function iif(bCondition: boolean; rTrue, rFalse: real): real; overload;
begin
if bCondition then
Result:=rTrue
else
Result:=rFalse;
end;
function iif(bCondition: boolean; objTrue, objFalse: TObject): TObject;
overload;
begin
if bCondition then
Result:=objTrue
else
Result:=objFalse;
end;
{$endif}
function iifv(bCondition: boolean; vTrue, vFalse: variant): variant;
begin
if bCondition then
Result:=vTrue
else
Result:=vFalse;
end;
function ColorToText(Value: TColor): string;
begin
case Value of
clAqua: Result:='Aqua';
clBlack: Result:='Black';
clBlue: Result:='Blue';
//clDkGray: Result:='Dark Gray'; Same as gray
clFuchsia: Result:='Fuchsia';
clGray: Result:='Gray';
clGreen: Result:='Green';
clLime: Result:='Lime green';
//clLtGray: Result:='Light Gray'; Same as silver
clMaroon: Result:='Maroon';
clNavy: Result:='Navy blue';
clOlive: Result:='Olive green';
clPurple: Result:='Purple';
clRed: Result:='Red';
clSilver: Result:='Silver';
clTeal: Result:='Teal';
clWhite: Result:='White';
clYellow: Result:='Yellow';
clBackground: Result:='Windows Desktop Background';
clActiveCaption: Result:='Active Window Title Bar';
clInactiveCaption: Result:='Inactive Window Title Bar';
clMenu: Result:='Menu Background';
clWindow: Result:='Window Background';
clWindowFrame: Result:='Window Frame';
clMenuText: Result:='Menu Text';
clWindowText: Result:='Window Text';
clCaptionText: Result:='Active Window Title Bar Text';
clActiveBorder: Result:='Active Window Border';
clInactiveBorder: Result:='Inactive Window Border';
clAppWorkSpace: Result:='Application Workspace';
clHighlight:Result:='Selected Text Background';
clHighlightText: Result:='Selected Text';
clBtnFace: Result:='Button Face';
clBtnShadow: Result:='Button Shadow';
clGrayText: Result:='Dimmed Text';
clBtnText: Result:='Button Text';
clInactiveCaptionText: Result:='Inactive Window Title Bar Text';
clBtnHighlight: Result:='Button Highlight';
cl3DDkShadow: Result:='3D Dark Shadow';
cl3DLight: Result:='3D Light Source';
clInfoText: Result:='Tool Tip Text';
clInfoBk: Result:='Tool Tip Background';
end;
end;
function TextToColor(Value: string): TColor;
var
sColor: string;
begin
sColor:=trim(UpperCase(Value));
if sColor = 'AQUA' then
Result:=clAqua
else if sColor = 'BLACK' then
Result:=clBlack
else if sColor = 'BLUE' then
Result:=clBlue
else if sColor = 'DARK GRAY' then
Result:=clDkGray
else if sColor = 'FUCHSIA' then
Result:=clFuchsia
else if sColor = 'GRAY' then
Result:=clGray
else if sColor = 'GREEN' then
Result:=clGreen
else if sColor = 'LIME' then
Result:=clLime
else if sColor = 'LIGHT GRAY' then
Result:=clLtGray
else if sColor = 'MAROON' then
Result:=clMaroon
else if sColor = 'NAVY' then
Result:=clNavy
else if sColor = 'OLIVE' then
Result:=clOlive
else if sColor = 'PURPLE' then
Result:=clPurple
else if sColor = 'RED' then
Result:=clRed
else if sColor = 'SILVER' then
Result:=clSilver
else if sColor = 'TEAL' then
Result:=clTeal
else if sColor = 'WHITE' then
Result:=clWhite
else if sColor = 'YELLOW' then
Result:=clYellow
else
Result:=clWindowText;
end;
function StrToFloatDef(Value: string; Default: Extended): Extended;
begin
try
Result:=StrToFloat(Value);
except
Result:=Default;
end;
end;
procedure CopyPhysicalFile (sSourceFileName, sTargetFileName : String);
const
BLOCK_SIZE = 1024;
var
SourceFile : FILE;
TargetFile : FILE;
iBytesWritten : Integer;
iBytesRead : Integer;
Buffer : Array [1..BLOCK_SIZE] of Char;
begin
AssignFile (SourceFile,sSourceFileName);
Reset (SourceFile,1);
AssignFile (TargetFile,sTargetFileName);
Rewrite (TargetFile,1);
Repeat
BlockRead (SourceFile,Buffer,SizeOf (Buffer),iBytesRead);
BlockWrite (TargetFile,Buffer,iBytesRead,iBytesWritten);
Until (iBytesRead = 0) Or (iBytesWritten <> iBytesRead);
CloseFile (TargetFile);
CloseFile (SourceFile);
end;
procedure WriteLogFile (sFileName, sMessage : String);
var
outFile : TextFile;
begin
AssignFile (outFile,sFileName);
If FileExists (sFileName) Then
Append (outFile)
Else
ReWrite (outFile);
Try
WriteLn (outFile,sMessage);
Finally
CloseFile (outFile);
End;
end;
end.
_______________________________________________
Delphi mailing list -> [email protected]
http://www.elists.org/mailman/listinfo/delphi
