Local con As Adodb.Connection, rs As Adodb.Recordset con = Createobject('Adodb.Connection') con.Provider = "ADsDSOObject" *!* con.Properties('User ID') = "admin" *!* con.Properties('Password') = "adminpwd" *!* con.Properties('Encrypt Password') = .F. con.Open("Active Directory Provider") *lcUrl = "server.myDomain.com" * or x.x.x.x:389 where x.x.x.x represents IP address * 389 is default LDAP port *strFrom = 'LDAP://'+m.lcURL+'/OU=...,DC=...,DC=...,DC=...,DC=...' strFrom = 'LDAP://localhost/OU=ADAM Users,o=Microsoft,c=US' rs = con.Execute([SELECT displayName,givenName,sn,telephoneNumber,homePhone FROM ']+strFrom+[']+; [Where objectClass = 'user' And objectCategory='Person']) lcTemp = Sys(2015)+'.xml' rs.Save(m.lcTemp,1) con.Close RsXML2VFPCursor(m.lcTemp) Erase (m.lcTemp) Select myCursor Browse Function RsXML2VFPCursor Lparameters tcXML Local lcXML m.lcXML = Filetostr(m.tcXML) m.lcXML = ; [<?xml version = "1.0" encoding="Windows-1252" standalone="yes"?>]+Chr(13)+Chr(10)+; [<VFPData>]+Chr(13)+Chr(10)+; Strtran(Strextract(m.lcXML,'<rs:data>','</rs:data>',1,1),'<z:row','<row',1,-1,3)+Chr(13)+Chr(10)+; [</VFPData>] _cliptext = m.lcXML Xmltocursor(m.lcXML,'myCursor') endfunc
*** LDAPClass.prg *** LDAP.h #Define ADS_SCOPE_BASE 0 #Define ADS_SCOPE_ONELEVEL 1 #Define ADS_SCOPE_SUBTREE 2 #Define ADS_SECURE_AUTHENTICATION 0x1 #Define ADS_USE_ENCRYPTION 0x2 #Define ADS_USE_SSL 0x2 #Define ADS_READONLY_SERVER 0x4 #Define ADS_PROMPT_CREDENTIALS 0x8 #Define ADS_NO_AUTHENTICATION 0x10 #Define ADS_FAST_BIND 0x20 #Define ADS_USE_SIGNING 0x40 #Define ADS_USE_SEALING 0x80 #Define ADS_USE_DELEGATION 0x100 #Define ADS_SERVER_BIND 0x200 #Define ADS_AUTH_RESERVED 0x80000000 #Define ADSTYPE_INVALID 0 #Define ADSTYPE_DN_STRING 1 #Define ADSTYPE_CASE_EXACT_STRING 2 #Define ADSTYPE_CASE_IGNORE_STRING 3 #Define ADSTYPE_PRINTABLE_STRING 4 #Define ADSTYPE_NUMERIC_STRING 5 #Define ADSTYPE_BOOLEAN 6 #Define ADSTYPE_INTEGER 7 #Define ADSTYPE_OCTET_STRING 8 #Define ADSTYPE_UTC_TIME 9 #Define ADSTYPE_LARGE_INTEGER 10 #Define ADSTYPE_PROV_SPECIFIC 11 #Define ADSTYPE_OBJECT_CLASS 12 #Define ADSTYPE_CASEIGNORE_LIST 13 #Define ADSTYPE_OCTET_LIST 14 #Define ADSTYPE_PATH 15 #Define ADSTYPE_POSTALADDRESS 16 #Define ADSTYPE_TIMESTAMP 17 #Define ADSTYPE_BACKLINK 18 #Define ADSTYPE_TYPEDNAME 19 #Define ADSTYPE_HOLD 20 #Define ADSTYPE_NETADDRESS 21 #Define ADSTYPE_REPLICAPOINTER 22 #Define ADSTYPE_FAXNUMBER 23 #Define ADSTYPE_EMAIL 24 #Define ADSTYPE_NT_SECURITY_DESCRIPTOR 25 #Define ADSTYPE_UNKNOWN 26 #Define ADSTYPE_DN_WITH_BINARY 27 #Define ADSTYPE_DN_WITH_STRING 28 *** LDAP.h o = Newobject('LDAPUI','LDAPClass.Prg') o.cRoot = 'o=Microsoft,c=US' o.NetworkAuthentication = .t. *!* oRS = o.LDAPQuery("adsPath,distinguishedName",; *!* " objectCategory='group' or"+; *!* " objectCategory='container' or"+; *!* " objectCategory='organizationalUnit'", 'base', o.cRoot) oRS = o.LDAPQuery("adsPath,distinguishedName",'', 'base', o.cRoot) ShowMe(oRS) Function ShowMe Lparameters toRecordset Public oForm oForm = Createobject('myForm', toRecordset) oForm.Show Endfunc Define Class myform As Form Height = 450 Width = 750 Name = "Form1" Add Object hflex As OleControl With ; Top = 10, Left = 10, Height = 430, Width = 730, Name = "Hflex", ; OleClass = 'MSHierarchicalFlexGridLib.MSHFlexGrid' Procedure Init Lparameters toRecordset This.hflex.Datasource = toRecordset This.hflex.AllowUSerResizing = 3 Endproc EndDefine Define Class LDAPUI As Custom cServer = "localhost" nPort = 389 cRoot = "" cAdmin = "" cAdminPwd = "" cSchemacursor = "crsSchema" cGroupsCursor = "crsGroups" cMapCursor = "crsLDAPMap" lConnectionValid = .F. NetworkAuthentication = .T. UseSSL = .F. Dimension aGroups[1] oCon = .Null. nGroups = 0 cSuffix = '' cError = '' Procedure QueryRoot(tcServer As String) Local lcRootName With This .cServer = Iif(!Empty(m.tcServer), Trim(m.tcServer), .cServer) If !.GetRootName(.cServer) .cRoot = .FindRootName( .cServer ) If Empty(.cRoot) .cRoot = Inputbox("Please provide LDAP domain root",; "rootDSE does not support defaultNamingContext",; "DC=node,DC=AD,DC=yourdomain,DC=com") Endif Endif Return !Empty(.cRoot) Endwith Endproc Procedure TryConnection(tcServer As String, ; tnPort As Integer,; tcRoot As String,; tcAdmin As String, ; tcAdminPwd As String,; tlUseSSL As Boolean) With This If .lConnectionValid And ; !.NewHost(tcServer, tnPort, tcRoot, tcAdmin, tcAdminPwd) Return Else .ResetDefaults() Endif .cServer = Iif(!Empty(m.tcServer), Trim(m.tcServer), .cServer) .nPort = Iif(!Empty(m.tnPort), m.tnPort, .nPort) .cAdmin = Iif(!Empty(m.tcAdmin), Trim(m.tcAdmin), .cAdmin) .cAdminPwd = Iif(!Empty(m.tcAdminPwd), Trim(m.tcAdminPwd), .cAdminPwd) .cRoot = Iif(!Empty(m.tcRoot), Trim(m.tcRoot), .cRoot) .NetworkAuthentication = Empty(.cAdmin) And Empty(.cAdminPwd) .UseSSL = m.tlUseSSL If Empty(.cRoot) And !.QueryRoot(.cServer) .cError = 'Cannot connect to server with given parameters - root unknown!' Return .F. Endif .lConnectionValid = .TestRoot() && .GetGroups() And .GetSuffix() .cError = Iif( .lConnectionValid, ; 'Connection succeeded', ; 'Cannot connect to server with given parameters!' ) Return .lConnectionValid Endwith Endproc Procedure ResetDefaults With This .cServer = "localhost" .nPort = 389 .cRoot = "" .cAdmin = "" .cAdminPwd = "" .cSchemacursor = "crsSchema" .cGroupsCursor = "crsGroups" .lConnectionValid = .F. .NetworkAuthentication = .F. .cError = '' Dimension .aGroups[1] .aGroups = "" .oCon = .Null. .nGroups = 0 Endwith Endproc Procedure NewHost(tcServer As String, ; tnPort As Integer,; tcRoot As String,; tcAdmin As String, ; tcAdminPwd As String) With This Return ; Iif(Empty(m.tcServer),.cServer,m.tcServer) # .cServer ; or ; Iif(Empty(m.tnPort),.nPort,m.tnPort) # .nPort ; or ; Iif(Empty(m.tcRoot),.cRoot,m.tcRoot) # .cRoot ; or ; Iif(Empty(m.tcAdmin),.cAdmin,m.tcAdmin) # .cAdmin ; or ; Iif(Empty(m.tcAdminPwd),.cAdminPwd,m.tcAdminPwd) # .cAdminPwd Endwith Endproc Procedure GetGroups Local oRS As Adodb.Recordset, ix As Integer, lHadError As Boolean With This Local oParser oParser = Createobject("Pathname") oRS = .LDAPQuery("adsPath,distinguishedName",; "objectCategory='group' or"+; " objectCategory='container' or"+; " objectCategory='organizationalUnit'", 'subtree', .cRoot) lHadError = Isnull(oRS) If ( !m.lHadError ) Local lcGroupName,lcGroupDN,lnGroupRow Dimension .aGroups[32500,2] && assumption - there shouldn't be more .aGroups='' .nGroups = 0 oRS.MoveFirst Do While !oRS.Eof lcGroup = oRS.Fields("adsPath").Value oParser.Set(lcGroup, 1) .nGroups = .nGroups + 1 .aGroups[.nGroups,1] = oParser.Retrieve(3) .aGroups[.nGroups,2] = oRS.Fields("distinguishedName").Value oRS.MoveNext Enddo Dimension .aGroups[.nGroups,2] Endif .oCon.Close() If ( m.lHadError ) Return .F. Endif Endwith Endproc Procedure GetSchema(tcCursorName As String) Local loSchema, sc, mp, op, pr, lcSchemaCursor, lHadError lcSchemaCursor = Sys(2015) With This .cSchemacursor = Iif(!Empty(m.tcCursorName), m.tcCursorName, .cSchemacursor ) Create Cursor (m.lcSchemaCursor) ; (PropName c(100), PropType c(30), IsSingle L, Mandatory L) objLDAP = Getobject("LDAP:") On Error lHadError = .T. If .NetworkAuthentication loSchema = Getobject("LDAP://" + .cServer + "/schema/user") Else loSchema = objLDAP.OpenDSObject("LDAP://" + .cServer + ":" + Ltrim(Str(.nPort)) + "/schema/user", ; .cAdmin, .cAdminPwd, 0) Endif On Error If m.lHadError Return .F. Endif sc = Getobject(loSchema.Parent) *Mandatory Properties: For Each mp In loSchema.MandatoryProperties pr = sc.Getobject("Property",mp) Insert Into (m.lcSchemaCursor) ; (PropName, PropType, IsSingle, Mandatory) ; values ; (pr.Name,pr.Syntax,pr.IsSingleValued, .T.) Endfor *Optional Properties: For Each op In loSchema.OptionalProperties pr = sc.Getobject("Property",op) Insert Into (m.lcSchemaCursor) ; (PropName, PropType, IsSingle) ; values ; (pr.Name,pr.Syntax,pr.IsSingleValued) Endfor If LDAPVALENCIA Insert Into (m.lcSchemaCursor) ; (PropName, PropType, IsSingle, Mandatory) ; values ; ('uid','DirectoryString',.T.,.F.) Endif Select * From (m.lcSchemaCursor) ; where PropType='DirectoryString' ; and IsSingle ; order By PropName ; into Cursor (.cSchemacursor) Use In (m.lcSchemaCursor) Endwith Endproc * GroupsToCursor - Get groups nto a cursor suitable for treeview Procedure GroupsToCursor(tcGroupsCursor As String) Local oParser,ix With This .cGroupsCursor = Iif( !Empty(m.tcGroupsCursor),m.tcGroupsCursor,.cGroupsCursor ) Asort(.aGroups,1) && Sort on path Create Cursor (.cGroupsCursor) (ParentID c(6),NodeID c(6),DN m,myDN m) For ix=1 To Alen(.aGroups,1) lnParentRow = Ascan(.aGroups,Justpath(.aGroups[m.ix,1]),1,-1,1,15) Insert Into (.cGroupsCursor) ; (ParentID,NodeID, DN, myDN) Values (; Padl(m.lnParentRow,6,'_'),; Padl(m.ix,6,'_'), ; .aGroups[m.ix,2], ; Strtran(.aGroups[m.ix,2],; Iif(m.lnParentRow=0,'',','+.aGroups[m.lnParentRow,2]),'') ) Endfor Endwith Endproc Procedure LDAPQueryFrom(tcFieldList As String, ; tcFilter As String, ; tcScope As String, ; tcFrom As String, ; tnSizeLimit As Integer) Local con As Adodb.Connection, ; rs As Adodb.Recordset, ; rs1 As Adodb.Recordset, ; com As Adodb.Command ; lnScope As Integer, ; lHadError As Boolean Local Array arrScope[3] arrScope[1]='base' arrScope[2]='onelevel' arrScope[3]='subtree' lnScope = Ascan(arrScope, Iif( Empty(m.tcScope),'subtree', m.tcScope ),1,-1,1,1)-1 lHadError = .F. With This m.tcFrom = Iif(Empty(m.tcFrom), 'LDAP://'+.cServer+':'+Ltrim(Str(.nPort)), m.tcFrom) .oCon = Createobject('Adodb.Connection') With .oCon .Provider = "ADsDSOObject" If !This.NetworkAuthentication .Properties('User ID') = This.cAdmin .Properties('Password') = This.cAdminPwd .Properties('Encrypt Password') = This.UseSSL Endif .Open("Active Directory Provider") Endwith com = Createobject('Adodb.command') com.ActiveConnection = .oCon com.Properties("searchscope") = m.lnScope If !Empty(m.tnSizeLimit) com.Properties("Size Limit") = m.tnSizeLimit Endif com.CommandText = [SELECT ]+m.tcFieldList+[ FROM ']+m.tcFrom+[']+; Iif(Empty(m.tcFilter),[],[ Where ]+m.tcFilter) On Error lHadError=.T. rs = com.Execute() On Error Endwith Return Iif(m.lHadError Or rs.Eof(),.Null.,rs) Endproc Procedure LDAPQuery(tcFieldList As String, ; tcFilter As String, ; tcScope As String, ; tcContainer As String, ; tnSizeLimit As Integer) Local con As Adodb.Connection, ; rs As Adodb.Recordset, ; rs1 As Adodb.Recordset, ; com As Adodb.Command ; strFrom As String, ; lnScope As Integer, ; lHadError As Boolean Local Array arrScope[3] arrScope[1]='base' arrScope[2]='onelevel' arrScope[3]='subtree' lnScope = Ascan(arrScope, Iif( Empty(m.tcScope),'subtree', m.tcScope ),1,-1,1,1)-1 lHadError = .F. With This m.tcContainer = Iif(Empty(m.tcContainer), .cRoot, m.tcContainer) .oCon = Createobject('Adodb.Connection') With .oCon .Provider = "ADsDSOObject" If !This.NetworkAuthentication .Properties('User ID') = This.cAdmin .Properties('Password') = This.cAdminPwd .Properties('Encrypt Password') = This.UseSSL Endif .Open("Active Directory Provider") Endwith com = Createobject('Adodb.command') com.ActiveConnection = .oCon com.Properties("searchscope") = m.lnScope If !Empty(m.tnSizeLimit) com.Properties("Size Limit") = m.tnSizeLimit Endif strFrom = 'LDAP://'+.cServer+':'+Ltrim(Str(.nPort))+'/'+m.tcContainer com.CommandText = [SELECT ]+m.tcFieldList+[ FROM ']+strFrom+[']+; Iif(Empty(m.tcFilter),[],[ Where ]+m.tcFilter) On Error lHadError=.T. rs = com.Execute() On Error Endwith Return Iif(m.lHadError Or rs.Eof(),.Null.,rs) Endproc Procedure GetRootName(tcServer As String) With This .cServer = Iif(!Empty(m.tcServer), Trim(m.tcServer), .cServer) Local oRoot, lNotSupported On Error lNotSupported = .T. oRoot = Getobject("LDAP://" + .cServer + "/rootDSE") .cRoot = oRoot.Get("defaultNamingContext") On Error Endwith Return !m.lNotSupported Endproc Procedure LDAPPath(tcContainer As String) Return "LDAP://" + ; This.cServer + ":" + ; Ltrim(Str(This.nPort)) + "/" + ; m.tcContainer + "," + This.cRoot Endproc Procedure FindRootName(tcServer As String) Local objMember,ix,lcRoot,lHadError Local Array arrNaming[1] arrNaming = "" On Error lHadError = .T. objMember = Getobject("LDAP://"+Trim(m.tcServer)+"/RootDSE") arrNaming = objMember.Get("namingContexts") On Error If m.lHadError Return "" Endif For ix = 1 To Alen(arrNaming) If Atc('schema',arrNaming[m.ix]) + ; Atc('configuration',arrNaming[m.ix]) = 0 lcRoot = arrNaming[m.ix] If This.TestRoot(m.tcServer,lcRoot) Return m.lcRoot Endif Endif Endfor Return "" Endproc Procedure TestRoot(tcServer As String, tcRoot As String, tnPort As Integer) This.cServer = Iif(Empty(m.tcServer),This.cServer,Trim(m.tcServer)) This.cRoot = Iif(Empty(m.tcRoot), This.cRoot, Trim(m.tcRoot)) This.nPort = Iif(Empty(m.tnPort), This.nPort, m.tnPort) Local oRS oRS = This.LDAPQuery("distinguishedName",'','base') This.oCon.Close() If Isnull(oRS) This.cRoot = "" Endif Return !Isnull(oRS) Endproc Procedure ATranspose Lparameters taArray Local ix,jx Local Array aConversion[Alen(taArray,2),Alen(taArray,1)] For ix=1 To Alen(taArray,1) For jx=1 To Alen(taArray,2) aConversion[m.jx,m.ix] = taArray[m.ix,m.jx] Endfor Endfor Dimension taArray[Alen(taArray,2),Alen(taArray,1)] Acopy(aConversion,taArray) Endproc Procedure GetSuffix Local oRS As Adodb.Recordset With This oRS = .LDAPQuery('userPrincipalName',; "objectClass='user' and objectCategory='Person'","","subtree",10) If !Isnull(oRS) Do While !oRS.Eof If ( Type('oRS.Fields(0).Value')='C' And !Empty(oRS.Fields(0).Value) ) .cSuffix = Substr(oRS.Fields(0).Value,At('@',oRS.Fields(0).Value)) Exit Endif Enddo Endif .oCon.Close() Endwith Endproc Procedure CheckMemberShip(toRs,tcMemberOf) If Empty(m.tcMemberOf) && No membership check group set Return .T. Endif tcMemberOf = Alltrim(Upper(m.tcMemberOf)) Local ix Local Array aMemberOf[1] aMemberOf = toRs.Fields('MemberOf').Value If !Isnull(aMemberOf) For ix=1 To Alen(aMemberOf) If Alltrim(Upper(aMemberOf[m.ix])) == m.tcMemberOf && Found Return .T. Endif Endfor Endif Return .F. && Not a member Endproc EnddefinePS: As I remember, you can download and use ADAM from Microsoft for local testing.