[Webinar] Streamline your web hosting managementRegister Today

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 3812
  • Last Modified:

Access 2007 using Active directory for domain groups

Does anyone know how to get groups from AD available to my Access 2007 App?  I have seen a few bits of code but can't get anything to work.  I think it is to do with VBA references also.  It could also be that while I have some of the code I don't know how to call the code.  An example of code can be found here but how do I get it to run?
http://www.microsoft.com/technet/technetmag/issues/2006/03/ScriptingGuy/default.aspx
or http://www.adminscripteditor.com/scriptlibrary/view.asp?id=254
0
Joe3Rings
Asked:
Joe3Rings
  • 11
  • 10
2 Solutions
 
omgangCommented:
Not sure exactly what you are looking for but here's a sample function that returns all users from an AD group.  I use it in vbs to output a list of users to a text file so you'll see some commented code to that effect.  I modified it into VBA - you'll see a note to add the MS Scripting Runtime library.

OM Gang
Public Function TestADGroups()
On Error GoTo Err_TestADGroups
 
    Dim objGroup As Object, objUser As Object, objFSO As Object
    Dim objFile As Object, RootDSE As Object, objConnection As Object
    Dim objCommand As Object
    Dim objRecordset As ADODB.Recordset
    Dim strDomain As String, strGroup As String
    Dim strUserName As String, strSearchRoot As String
    Dim strQueryText As String, strFName As String, strLName As String
    
        'Change DomainName to the name of the domain the group is in
    strDomain = "ADDomainName"
        'Change GroupName to the name of the group whose members you want to export
    strGroup = "ADGroupName"
        'set reference to 'Microsoft Scripting Runtime'
    Set objFSO = CreateObject("Scripting.FileSystemObject")
        'On the next line change the name and path of the file that export data will be written to.
    'Set objFile = objFSO.CreateTextFile("C:\temp\GroupOutput.txt")
    Set objGroup = GetObject("WinNT://" & strDomain & "/" & strGroup & ",group")
    For Each objUser In objGroup.Members
        strUserName = objUser.name
 
        Set RootDSE = GetObject("LDAP://RootDSE")
        strSearchRoot = RootDSE.Get("defaultNamingContext")
 
        Set objConnection = CreateObject("ADODB.Connection")
        Set objCommand = CreateObject("ADODB.Command")
        objConnection.Provider = "ADsDSOObject"
        objConnection.Open "Active Directory Provider"
        Set objCommand.ActiveConnection = objConnection
 
        strQueryText = "<LDAP://" & strSearchRoot & ">;(&(objectCategory=Person)(samAccountName=" & strUserName & "));" _
            & "givenName,sn,ADsPath;SubTree"
        objCommand.CommandText = strQueryText
        objCommand.Properties("Page Size") = 2000
        objCommand.Properties("Timeout") = 60
        objCommand.Properties("Cache Results") = False
        Set objRecordset = objCommand.Execute
        If Not objRecordset.EOF Then
            objRecordset.MoveFirst
 
            ' --- Loop through the returned records
            Do Until objRecordset.EOF
                strFName = Nz(objRecordset.Fields("givenName").Value, "")
                strLName = Nz(objRecordset.Fields("sn").Value, "")
                'MsgBox strFName & " " & strLName, 0, "Test"
                objRecordset.MoveNext
            Loop
 
            'objFile.WriteLine strFName & " " & strLName
            Debug.Print strFName & " " & strLName
        End If
    Next
    
Exit_TestADGroups:
    'objFile.Close
    Set objRecordset = Nothing
    Set objCommand = Nothing
    Set objConnection = Nothing
    Set RootDSE = Nothing
    Set objFile = Nothing
    Set objFSO = Nothing
    Set objUser = Nothing
    Set objGroup = Nothing
    Exit Function
    
Err_TestADGroups:
    MsgBox Err.Number & ", " & Err.Description, , "Error"
    Resume Exit_TestADGroups
    
End Function

Open in new window

0
 
Joe3RingsAuthor Commented:
Thanks for that but I get a runtime error.  I have added the MS Scripting Runtime library.  Screen shot attached.  I'm calling the function from the imediate window.  This would work for me if I could feed it the username and group.  I am right is saying I could change the function to accept ther two variables?

Thanks
Error.doc
0
 
omgangCommented:
You need a reference to the ADO library - in my Access 2003 setup it's
Microsoft ActiveX Data Objects 2.1 Library

To pass the variables to the function do this - I am assuming you want to pass the domain name and the group

Public Function TestADGroups(strDomain As String, strGroup As String)
On Error GoTo Err_TestADGroups
 
    Dim objGroup As Object, objUser As Object, objFSO As Object
    Dim objFile As Object, RootDSE As Object, objConnection As Object
    Dim objCommand As Object
    Dim objRecordset As ADODB.Recordset
    'Dim strDomain As String, strGroup As String
    Dim strUserName As String, strSearchRoot As String
    Dim strQueryText As String, strFName As String, strLName As String

If you want to pass the username and retrun all group memberships for that user, like in one of the links you provided, you'll need to make minor modification to the code.

OM Gang
0
Easily manage email signatures in Office 365

Managing email signatures in Office 365 can be a challenging task if you don't have the right tool. CodeTwo Email Signatures for Office 365 will help you implement a unified email signature look, no matter what email client is used by users. Test it for free!

 
Joe3RingsAuthor Commented:
What I'm really trying to do is give it the username and group so I can set up a menu dependant on what group the user is in.
0
 
Joe3RingsAuthor Commented:
I now get this error, Automation error The network path was not found.
Error.doc
0
 
omgangCommented:
On what line is this error occuring?
OM Gang
0
 
Joe3RingsAuthor Commented:
It doesn't say an error line or stop on a row.  It just shows the pop up wondow.  See screen shoot.  Thanks in advance for all your help.
Error.doc
0
 
Joe3RingsAuthor Commented:
This is a screen shot of my current references
references.doc
0
 
omgangCommented:
Put a break-point in your code, like on
strDomain = "....."
Now when you call the function the code will stop on that line and allow you to step through the code one line at a time.
OM Gang
0
 
Joe3RingsAuthor Commented:
I have added what I think is a breakpoint, I'm then pushing f5 to continue.  It stops first time at the break point then goes to the msg box?  See the screen shot attached to last comment.
0
 
omgangCommented:
In the VB editor, click the View menu and then Toolbars.  Click to show the debug toolbar.  On this toolbar you have some buttons for stepping through the code.

Launch your function.  When the code breaks at the break-point you have inserted, click the 'Step Into' toolbar button to step through the code line-by-line.  Move your mouse pointer over the toolbar buttons to see which one is 'Step Into'

OM Gang
0
 
Joe3RingsAuthor Commented:
Okay, it stops at
strGroup = "joebyrne"
 Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objGroup = GetObject("WinNT://" & strDomain & "/" & strGroup & ",group")
    MsgBox Err.Number & ", " & Err.Description, , "Error"

Then I get the error msg box?
0
 
omgangCommented:
Is 'joebyrne' really the name of one of your AD groups?  Looks like a user to me.

Try this one out instead.   I just tested it and it works for what you want
OM Gang
Public Function TestADGroups2(strUserName As String)
On Error GoTo Err_TestADGroups2
  
    Dim objUser As Object, objGroup As Object
    Dim RootDSE As Object
    Dim strSearchRoot As String
    Dim colGroups As Object
 
    Set RootDSE = GetObject("LDAP://RootDSE")
    strSearchRoot = RootDSE.Get("defaultNamingContext")
 
    Set objUser = GetObject("LDAP://CN=" & strUserName & ",OU=OUName," & strSearchRoot)
    Set colGroups = objUser.Groups
    For Each objGroup In colGroups
        Debug.Print objGroup.CN
    Next
    
Exit_TestADGroups2:
    Set RootDSE = Nothing
    Set objGroup = Nothing
    Set colGroups = Nothing
    Set objUser = Nothing
    Exit Function
    
Err_TestADGroups2:
    MsgBox Err.Number & ", " & Err.Description, , "Error"
    Resume Exit_TestADGroups2
    
End Function

Open in new window

0
 
Joe3RingsAuthor Commented:
Sorry that was my mistake but I still get an error.  See attached screen shot.  Am I doing it correctly by using the imediate window to check.  


screen-shot.doc
0
 
omgangCommented:
You left OU=OUName in the code.  You need to change that to whatever the name of the OU is, or names of the OU's are, in your situation, i.e. in my environment it's something like

Set objUser = GetObject("LDAP://CN=" & strUserName & ",OU=Users,OU=Accounting," & strSearchRoot)

OM Gang
0
 
omgangCommented:
you need what's called the DN, or distinguished name, of the AD object you want to bind to
Set objUser = GetObject("LDAP://CN=OM Gang,OU=Users,OU=Puter Fixers,DC=SillyDomain,DC=com)
This refers to the user object OM Gang
in the container (organizational unit) Users
in the container (organizational unit) Puter Fixers
in the domain SillyDomain.com

OM Gang
0
 
omgangCommented:
obviously, in my sample code, strUserName is used to pass the user name and strSearchRoot passes the DC entries.
OM Gang
0
 
Joe3RingsAuthor Commented:
Sorry I am still missing something, I have a OU called SBSUsers, a domain called jbit.local and a user called joebyrne.  See screen shot again, it says object does not exist.
screen-shot.doc
0
 
omgangCommented:
Is joebyrne the actual CN of your AD user object?  We don't want the login acct name; we're looking for the CN which is probably the same as your display name.  Look in AD at the object properties, 'Object' tab, you need to use whatever the actual CN is
In my environment, my login acct is omgang but my CN is Gang, OM (which, incidentally has to be treated special because of the comma
Set objUser = GetObject("LDAP://CN=Gang\, OM,OU=Users,OU=Puter Fixers,DC=SillyDomain,DC=com)

You can try this to confirm that strSearchRoot is returning what you expect (should be DC=jbit, DC=local)

    Set RootDSE = GetObject("LDAP://RootDSE")
    strSearchRoot = RootDSE.Get("defaultNamingContext")

    Debug.Print strSearchRoot                                               <----add
    GoTo Exit_TestADGroups2                                                <----add


You can also comment the Set objUser line and replace with
Set objUser = GetObject("LDAP://CN=joebyrne,OU=SBSUsers,DC=jbit,DC=local)
But remember, if joebyrne is your login username you can't use that (you will receive the exact error message you describe).  Perhaps you  CN is Joe Byrne or Byrne, Joe (in which case you'll have to pass it as "Byrne\, Joe"

OM Gang
0
 
Joe3RingsAuthor Commented:
Here is the solution i used - a class module passed on by a friend and a couple of functions

as you can see it fetches much more than just the user or groups - a lot of which i will find useful as the application develops... :)

Hopefully someone else will find this useful too...

Thanks OM Gang for your solution - though i've no idea if it worked having used this one...

What do i do now Mod?  accept my own solution?






'********>>>>>  saved as a class module called clsUserInfo
 
 
Option Compare Database
Option Explicit
 
'-------------------------------------------------------------------------------
' Author: Graham R Seach
'         Pacific Database Pty Limited
' Phone:  +62 2 9872 9594  Fax: +61 2 9872 9593
' Email:  sales@pacificdb.com.au
'-------------------------------------------------------------------------------
' Date: 06-06-2003
'
' Class to retrieve information about the current user.
'-------------------------------------------------------------------------------
 
'Workstation information type
Private Type WKSTA_USER_INFO_1
    wkui1_username As Long          'Specifies the name of the user currently logged on to the workstation.
    wkui1_logon_domain As Long      'Specifies the name of the domain in which the user is currently logged on.
    wkui1_oth_domains As Long       'Specifies the list of operating system domains browsed by the workstation.
                                    'The domain names are separated by blanks.
    wkui1_logon_server As Long      'Specifies the name of the server that authenticated the user.
End Type
 
'User information type
Private Type USER_INFO_3
    usri3_name As Long              'Pointer to a Unicode string that specifies the name of the user account.
    usri3_password As Long          'Pointer to a Unicode string that specifies the password for the user identified by the usri3_name member.
    usri3_password_age As Long      'Specifies a DWORD value that indicates the number of seconds that have elapsed since the usri3_password member was last changed.
    usri3_priv As Long              'Specifies a DWORD value that indicates the level of privilege assigned to the usri3_name member.
    usri3_home_dir As Long          'Pointer to a Unicode string specifying the path of the home directory of the user specified by the usri3_name member.
    usri3_comment As Long           'Pointer to a Unicode string that contains a comment to associate with the user account.
    usri3_flags As Long             'Specifies a DWORD value that determines several features.
    usri3_script_path As Long       'Pointer to a Unicode string specifying the path for the user's logon script file.
    usri3_auth_flags As Long        'Specifies a DWORD value that contains a set of bit flags defining the user's operator privileges.
    usri3_full_name As Long         'Pointer to a Unicode string that contains the full name of the user.
    usri3_usr_comment As Long       'Pointer to a Unicode string that contains a user comment.
    usri3_parms As Long             'DO NOT MODIFY! Microsoft products use this member to store user configuration information.
                                    'Pointer to a Unicode string that is reserved for use by applications.
    usri3_workstations As Long      'Pointer to a Unicode string that contains the names of workstations from which the user can log on.
    usri3_last_logon As Long        'Specifies a DWORD value that indicates when the last logon occurred.
                                    'This value is stored as the number of seconds that have elapsed since 00:00:00, January 1, 1970, GMT.
    usri3_last_logoff As Long       'Not used. Specifies a DWORD value that indicates when the last logoff occurred.
                                    'This value is stored as the number of seconds that have elapsed since 00:00:00, January 1, 1970, GMT.
    usri3_acct_expires As Long      'Specifies a DWORD value that indicates when the account expires.
                                    'This value is stored as the number of seconds elapsed since 00:00:00, January 1, 1970, GMT.
                                    'A value of TIMEQ_FOREVER indicates that the account never expires.
    usri3_max_storage As Long       'Specifies a DWORD value that indicates the maximum amount of disk space the user can use.
    usri3_units_per_week As Long    'Specifies a DWORD value that indicates the number of equal-length time units into which the week is divided.
                                    'This value is required to compute the length of the bit string in the usri3_logon_hours member.
    usri3_logon_hours As Byte       'Pointer to a 21-byte (168 bits) bit string that specifies the times during which the user can log on.
                                    'Each bit represents a unique hour in the week, in Greenwich Mean Time (GMT).
    usri3_bad_pw_count As Long      'Specifies a DWORD value that indicates the number of times the user tried to log on to the account using an incorrect password.
    usri3_num_logons As Long        'Specifies a DWORD value that indicates the number of times the user logged on successfully to this account.
    usri3_logon_server As Long      'Pointer to a Unicode string that contains the name of the server to which logon requests are sent.
    usri3_country_code As Long      'Specifies a DWORD value that contains the country/region code for the user's language of choice.
    usri3_code_page As Long         'Specifies a DWORD value that contains the code page for the user's language of choice.
    usri3_user_id As Long           'Specifies a DWORD value that contains the relative ID (RID) of the user.
    usri3_primary_group_id As Long  'Specifies a DWORD value that contains the RID of the Primary Global Group for the user.
    usri3_profile As Long           'Pointer to a Unicode string that specifies a path to the user's profile.
    usri3_home_dir_drive As Long    'Pointer to a Unicode string that specifies the drive letter assigned to the user's home directory for logon purposes.
    usri3_password_expired As Long  'Specifies a DWORD value that contains password expiration information.
End Type
 
'General
Private Const MAXCOMMENTSZ = 256
Private Const NERR_SUCCESS = 0
Private Const ERROR_MORE_DATA = 234&
Private Const MAX_CHUNK = 25
Private Const ERROR_SUCCESS = 0&
 
'usri3_units_per_week
Private Const SAM_DAYS_PER_WEEK As Long = 7
Private Const SAM_HOURS_PER_WEEK As Long = 168
Private Const SAM_MINUTES_PER_WEEK As Long = 10080
 
'usri3_auth_flags
Private Const AF_OP_ACCOUNTS As Long = &H8
Private Const AF_OP_COMM As Long = &H2
Private Const AF_OP_PRINT As Long = &H1
Private Const AF_OP_SERVER As Long = &H4
 
'usri3_priv
Private Const USER_MAX_STORAGE_PARMNUM As Long = 18
Private Const USER_PRIV_PARMNUM As Long = 5
Private Const PARMNUM_BASE_INFOLEVEL As Long = 1000
Private Const USER_PRIV_ADMIN As Long = 2
Private Const USER_PRIV_GUEST As Long = 0
Private Const USER_PRIV_INFOLEVEL As Long = (PARMNUM_BASE_INFOLEVEL + USER_PRIV_PARMNUM)
Private Const USER_PRIV_MASK As Long = &H3
Private Const USER_PRIV_USER As Long = 1
 
Private Const USER_MAXSTORAGE_UNLIMITED As Long = -1
Private Const USER_MAX_STORAGE_INFOLEVEL As Long = (PARMNUM_BASE_INFOLEVEL + USER_MAX_STORAGE_PARMNUM)
 
'usri3_flags
Private Const UF_ACCOUNTDISABLE As Long = &H2
Private Const UF_DONT_EXPIRE_PASSWD As Long = &H10000
Private Const UF_DONT_REQUIRE_PREAUTH As Long = &H400000
Private Const UF_ENCRYPTED_TEXT_PASSWORD_ALLOWED As Long = &H80
Private Const UF_HOMEDIR_REQUIRED As Long = &H8
Private Const UF_INTERDOMAIN_TRUST_ACCOUNT As Long = &H800
Private Const UF_LOCKOUT As Long = &H10
Private Const UF_WORKSTATION_TRUST_ACCOUNT As Long = &H1000
Private Const UF_SERVER_TRUST_ACCOUNT As Long = &H2000
Private Const UF_TEMP_DUPLICATE_ACCOUNT As Long = &H100
Private Const UF_SMARTCARD_REQUIRED As Long = &H40000
Private Const UF_TRUSTED_FOR_DELEGATION As Long = &H80000
Private Const UF_USE_DES_KEY_ONLY As Long = &H200000
Private Const UF_MNS_LOGON_ACCOUNT As Long = &H20000
Private Const UF_NORMAL_ACCOUNT As Long = &H200
Private Const UF_NOT_DELEGATED As Long = &H100000
Private Const UF_PASSWD_CANT_CHANGE As Long = &H40
Private Const UF_PASSWD_NOTREQD As Long = &H20
Private Const UF_SCRIPT As Long = &H1
Private Const UF_ACCOUNT_TYPE_MASK As Long = _
             (UF_TEMP_DUPLICATE_ACCOUNT Or _
              UF_NORMAL_ACCOUNT Or _
              UF_INTERDOMAIN_TRUST_ACCOUNT Or _
              UF_WORKSTATION_TRUST_ACCOUNT Or _
              UF_SERVER_TRUST_ACCOUNT)
Private Const UF_MACHINE_ACCOUNT_MASK As Long = _
             (UF_INTERDOMAIN_TRUST_ACCOUNT Or _
              UF_WORKSTATION_TRUST_ACCOUNT Or _
              UF_SERVER_TRUST_ACCOUNT)
Private Const UF_SETTABLE_BITS As Long = _
             (UF_SCRIPT Or _
              UF_ACCOUNTDISABLE Or _
              UF_LOCKOUT Or _
              UF_HOMEDIR_REQUIRED Or _
              UF_PASSWD_NOTREQD Or _
              UF_PASSWD_CANT_CHANGE Or _
              UF_ACCOUNT_TYPE_MASK Or _
              UF_DONT_EXPIRE_PASSWD Or _
              UF_MNS_LOGON_ACCOUNT Or _
              UF_ENCRYPTED_TEXT_PASSWORD_ALLOWED Or _
              UF_SMARTCARD_REQUIRED Or _
              UF_TRUSTED_FOR_DELEGATION Or _
              UF_NOT_DELEGATED Or _
              UF_USE_DES_KEY_ONLY Or _
              UF_DONT_REQUIRE_PREAUTH)
 
'usri3_acct_expires
Private Const TIMEQ_FOREVER As Long = -1
 
'Declares
Private Declare Function NetGetDCName Lib "NETAPI32.DLL" ( _
    ByVal ServerName As Long, _
    ByVal DomainName As Long, _
    bufptr As Long) As Long
 
Private Declare Function NetAPIBufferFree Lib "NETAPI32.DLL" _
    Alias "NetApiBufferFree" ( _
    ByVal buffer As Long) As Long
 
Private Declare Function lstrlenW Lib "kernel32" _
    (ByVal lpString As Long) As Long
 
Private Declare Function NetUserGetInfo Lib "NETAPI32.DLL" _
    (ServerName As Any, UserName As Any, _
    ByVal Level As Long, _
    bufptr As Long) As Long
 
Private Declare Sub RtlMoveMemory Lib "kernel32" ( _
    Destination As Any, _
    Source As Any, _
    ByVal Length As Long)
 
Private Declare Function GetUserName Lib "advapi32.dll" _
    Alias "GetUserNameA" ( _
    ByVal lpBuffer As String, _
    nSize As Long) As Long
 
Private Declare Function NetWkstaUserGetInfo Lib "netapi32" ( _
    ByVal Reserved As Long, _
    ByVal Level As Long, _
    bufptr As Long) As Long
    
Private Declare Function GetComputerName Lib "kernel32" _
    Alias "GetComputerNameA" ( _
    ByVal lpBuffer As String, _
    nSize As Long) As Long
 
Private Declare Function NetUserGetGroups Lib "netapi32" ( _
    lpServer As Any, _
    UserName As Byte, _
    ByVal Level As Long, _
    lpBuffer As Long, _
    ByVal PrefMaxLen As Long, _
    lpEntriesRead As Long, _
    lpTotalEntries As Long) As Long
  
Private Declare Function NetUserGetLocalGroups Lib "NETAPI32.DLL" ( _
    lpServer As Any, _
    UserName As Byte, _
    ByVal Level As Long, _
    ByVal Flags As Long, _
    lpBuffer As Long, _
    ByVal MAXLEN As Long, _
    lpEntriesRead As Long, _
    lpTotalEntries As Long) As Long
 
'Class property variables
Private sPassword As String
Private lPasswordAge As Long
Private lPriv As Long
Private sHomeDir As String
Private sScriptPath As String
Private lAuthFlags As Long
Private sComment As String
Private lFlags As Long
Private sFullName As String
Private sName As String
Private sUsrComment As String
Private sWorkstations As String
Private dteLastLogon As Date
Private dteLastLogoff As Date
Private dteAcctExpires As Date
Private lMaxStorage As Long
Private lUnitsPerWeek As Long
Private lLogonHours As Long
Private lBadPWCount As Long
Private lNumLogons As Long
Private sLogonServer As String
Private lCountryCode As Long
Private lUserID As Long
Private lPrimaryGroupID As Long
Private sHomeDirDrive As String
Private lPasswordExpired As Long
Private sCurrentWS As String
Private sDomain As String
Private sAccessUsername As String
Private colGroups As Collection
Private colAuthFlags As Collection
Private colAcctFlags As Collection
Private colPrivileges As Collection
Private colAccessGroups As Collection
 
Private Sub GetUserInfo(Optional vFirstNameFirst As Variant = False)
    'Populates the property variables with the specified user's details.
    'NT and later only!
    
    Dim bufptr As Long
    Dim dwRec As Long
    Dim usrinfo As USER_INFO_3
    Dim bytPDCName() As Byte
    Dim bytUserName() As Byte
    Dim lReturn As Long
    Dim vReturn As Variant
    Dim strUserName As String
    Dim vFirstName As Variant
    Dim vSurname As Variant
    
    On Error GoTo GetUserInfo_Err
    
    ' Unicode
    bytPDCName = GetDomainContName() & vbNullChar
    strUserName = GetCurrentUser
    bytUserName = strUserName & vbNullChar
 
    ' Get the info
    lReturn = NetUserGetInfo(bytPDCName(0), bytUserName(0), 3, bufptr)
    If (lReturn = ERROR_SUCCESS) Then
        'Move the buffer contents into the Type
        Call RtlMoveMemory(usrinfo, ByVal bufptr, Len(usrinfo))
        
        '---- Get the password ----
        sPassword = Trim(Pointer2String(usrinfo.usri3_password))
        '---- Get the password age ----
        lPasswordAge = usrinfo.usri3_password_age
        '---- Get the home dir ----
        sHomeDir = Trim(Pointer2String(usrinfo.usri3_home_dir))
        '---- Get the comment ----
        sComment = Trim(Pointer2String(usrinfo.usri3_comment))
        '---- Get the username ----
        sName = Trim(Pointer2String(usrinfo.usri3_name))
        '---- Get the usr comment ----
        sUsrComment = Trim(Pointer2String(usrinfo.usri3_usr_comment))
        '---- Get the workstations ----
        sWorkstations = Trim(Pointer2String(usrinfo.usri3_workstations))
        '---- Get the last logon date ----
        lReturn = usrinfo.usri3_last_logon
        dteLastLogon = DateAdd("s", lReturn, DateSerial(1970, 1, 1) + TimeSerial(0, 0, 0))
        '---- Get the last logoff date ----
        lReturn = usrinfo.usri3_last_logoff
        dteLastLogoff = DateAdd("s", lReturn, DateSerial(1970, 1, 1) + TimeSerial(0, 0, 0))
        '---- Get the account expiry date ----
        lReturn = usrinfo.usri3_acct_expires
        dteAcctExpires = DateAdd("s", lReturn, DateSerial(1970, 1, 1) + TimeSerial(0, 0, 0))
        '---- Get the max storage ----
        lMaxStorage = usrinfo.usri3_max_storage
        '---- Get the units per week ----
        lUnitsPerWeek = usrinfo.usri3_units_per_week
        '---- Get the logon hours ----
        lLogonHours = usrinfo.usri3_logon_hours
        '---- Get the bad password count ----
        lBadPWCount = usrinfo.usri3_bad_pw_count
        '---- Get the logon count ----
        lNumLogons = usrinfo.usri3_num_logons
        '---- Get the logon server ----
        sLogonServer = Trim(Pointer2String(usrinfo.usri3_logon_server))
        '---- Get the country code ----
        lCountryCode = usrinfo.usri3_country_code
        '---- Get the user ID ----
        lUserID = usrinfo.usri3_user_id
        '---- Get the primary group ID ----
        lPrimaryGroupID = usrinfo.usri3_primary_group_id
        '---- Get the home dir drive ----
        sHomeDirDrive = Trim(Pointer2String(usrinfo.usri3_home_dir_drive))
        '---- Get the password expired flag ----
        lPasswordExpired = usrinfo.usri3_password_expired
        '---- Get the script path ----
        sScriptPath = Trim(Pointer2String(usrinfo.usri3_script_path))
        
        '---- Get the full name ----
        vReturn = Trim(Pointer2String(usrinfo.usri3_full_name))
        If vFirstNameFirst = True Then
            'Reverse the order of the names to [FN SN]
            vSurname = Left(vReturn, InStr(1, vReturn, " ") - 1)
            vFirstName = Mid(vReturn, InStr(1, vReturn, " ") + 1)
            vReturn = vFirstName & " " & vSurname
        End If
        sFullName = vReturn
        
        '---- Get the account flags ----
        lFlags = usrinfo.usri3_flags
        If lFlags > 0 Then
            'Populate the collection
            If (lFlags And UF_ACCOUNTDISABLE) Then _
                    colAcctFlags.Add "Account disabled", "Account disabled"
            If (lFlags And UF_HOMEDIR_REQUIRED) Then _
                    colAcctFlags.Add "Home directory required", "Home directory required"
            If (lFlags And UF_PASSWD_NOTREQD) Then _
                    colAcctFlags.Add "No password required", "No password required"
            If (lFlags And UF_PASSWD_CANT_CHANGE) Then _
                    colAcctFlags.Add "User cannot change password", "User cannot change password"
            If (lFlags And UF_LOCKOUT) Then _
                    colAcctFlags.Add "Account is currently locked out", "Account is currently locked out"
            If (lFlags And UF_DONT_EXPIRE_PASSWD) Then _
                    colAcctFlags.Add "Password should never expire", "Password should never expire"
            If (lFlags And UF_ENCRYPTED_TEXT_PASSWORD_ALLOWED) Then _
                    colAcctFlags.Add "Password is stored under reversible encryption in the Active Directory", "Password is stored under reversible encryption in the Active Directory"
            If (lFlags And UF_NOT_DELEGATED) Then _
                    colAcctFlags.Add "Sensitive - other users cannot act as delegates of this user account", "Sensitive - other users cannot act as delegates of this user account"
            If (lFlags And UF_SMARTCARD_REQUIRED) Then _
                    colAcctFlags.Add "Smart card required to logon", "Smart card required to logon"
            If (lFlags And UF_USE_DES_KEY_ONLY) Then _
                    colAcctFlags.Add "Must use only Data Encryption Standard (DES) encryption types for keys", "Must use only Data Encryption Standard (DES) encryption types for keys"
            If (lFlags And UF_DONT_REQUIRE_PREAUTH) Then _
                    colAcctFlags.Add "Does not require Kerberos pre-authentication for logon", "Does not require Kerberos preauthentication for logon"
            If (lFlags And UF_TRUSTED_FOR_DELEGATION) Then _
                    colAcctFlags.Add "Account is enabled for delegation", "Account is enabled for delegation"
            'If (lFlags And UF_PASSWORD_EXPIRED) Then _
                    colAcctFlags.Add "Password has expired", "Password has expired"
            'If (lFlags And UF_TRUSTED_TO_AUTHENTICATE_FOR_DELEGATION) Then _
                    colAcctFlags.Add "Account is trusted to authenticate a user outside of the Kerberos security package and delegate that user through constrained delegation", "Account is trusted to authenticate a user outside of the Kerberos security package and delegate that user through constrained delegation"
            If (lFlags And UF_NORMAL_ACCOUNT) Then _
                    colAcctFlags.Add "Normal account", "Normal account"
            If (lFlags And UF_TEMP_DUPLICATE_ACCOUNT) Then _
                    colAcctFlags.Add "Account for user whose primary account is in another domain", "Account for user whose primary account is in another domain"
            If (lFlags And UF_WORKSTATION_TRUST_ACCOUNT) Then _
                    colAcctFlags.Add "Account for a computer that is a member of this domain", "Account for a computer that is a member of this domain"
            If (lFlags And UF_SERVER_TRUST_ACCOUNT) Then _
                    colAcctFlags.Add "Account for a backup domain controller that is a member of this domain", "Account for a backup domain controller that is a member of this domain"
            If (lFlags And UF_INTERDOMAIN_TRUST_ACCOUNT) Then _
                    colAcctFlags.Add "Permit to a trust account for a domain that trusts other domains", "Permit to a trust account for a domain that trusts other domains"
        End If
        
        '---- Get the user privileges ----
        lPriv = usrinfo.usri3_priv
        If lPriv > 0 Then
            'Populate the collection
            If (lPriv And USER_PRIV_GUEST) Then colPrivileges.Add "Guest", "Guest"
            If (lPriv And USER_PRIV_USER) Then colPrivileges.Add "User", "User"
            If (lPriv And USER_PRIV_ADMIN) Then colPrivileges.Add "Administrator", "Administrator"
        End If
        
        '---- Get the authority flags ----
        lAuthFlags = usrinfo.usri3_auth_flags
        If lAuthFlags > 0 Then
            'Populate the collection
            If (lAuthFlags And AF_OP_PRINT) Then colAuthFlags.Add "Print Operator", "Print Operator"
            If (lAuthFlags And AF_OP_COMM) Then colAuthFlags.Add "Communications Operator", "Communications Operator"
            If (lAuthFlags And AF_OP_SERVER) Then colAuthFlags.Add "Server Operator", "Server Operator"
            If (lAuthFlags And AF_OP_ACCOUNTS) Then colAuthFlags.Add "Accounts Operator", "Accounts Operator"
        End If
    End If
    
GetUserInfo_Exit:
    'Clean up
    Call NetAPIBufferFree(bufptr)
    Exit Sub
    
GetUserInfo_Err:
    Resume GetUserInfo_Exit
End Sub
 
Private Function GetDomainContName() As String
    'Returns the name of the domain controller
    Dim usrinfo As Long
    Dim lReturn As Long
    Dim abytBuf() As Byte
    
    lReturn = NetGetDCName(0, 0, usrinfo)
    If lReturn = NERR_SUCCESS Then
        GetDomainContName = Pointer2String(usrinfo)
    End If
    
    'Clean up
    Call NetAPIBufferFree(usrinfo)
End Function
 
Private Function Pointer2String(lPointer As Long) As String
    'Converts a Unicode pointer to an ANSI string
    Dim lLen As Long
    Dim bytString() As Byte
    
    lLen = lstrlenW(lPointer) * 2
    If lLen > 0 Then
        ReDim bytString(0 To lLen - 1)
        
        Call RtlMoveMemory(bytString(0), ByVal lPointer, lLen)
        Pointer2String = bytString()
    End If
End Function
 
Private Function GetUserDomainInfo(Optional iSelection As Integer = 1) As String
    'Returns the current user's domain information
    'Windows NT/2000 only
 
    Dim lReturn As Long
    Dim lPointer As Long
    Dim wkstinfo As WKSTA_USER_INFO_1
    
    On Error GoTo MachineName_Err
    
    lReturn = NetWkstaUserGetInfo(0&, 1&, lPointer)
    If lReturn = 0 Then
        RtlMoveMemory wkstinfo, ByVal lPointer, LenB(wkstinfo)
        
        If Not lPointer = 0 Then
            Select Case iSelection
                Case 1 'Return the logon domain name
                    GetUserDomainInfo = Pointer2String(wkstinfo.wkui1_logon_domain)
                Case 2 'Return the logon server name
                    GetUserDomainInfo = Pointer2String(wkstinfo.wkui1_logon_server)
                Case 3 'Return the logon other domains
                    GetUserDomainInfo = Pointer2String(wkstinfo.wkui1_oth_domains)
                Case 4 'Return the username
                    GetUserDomainInfo = Pointer2String(wkstinfo.wkui1_username)
                Case Else
                    GetUserDomainInfo = ""
            End Select
        End If
    End If
    
MachineName_Exit:
    Exit Function
    
MachineName_Err:
    GetUserDomainInfo = vbNullString
    Resume MachineName_Exit
End Function
    
Private Function GetMachineName() As String
    'Returns the current user's workstation (computer) name
    Dim lLength As Long
    Dim lReturn As Long
    Dim sMachineName As String
    
    lLength = 16
    sMachineName = String(lLength, 0)
    
    lReturn = GetComputerName(sMachineName, lLength)
    If lReturn <> 0 Then
        GetMachineName = Left(sMachineName, lLength)
    Else
        GetMachineName = ""
    End If
End Function
 
Public Sub CollectInfo()
    'Equivalent to Main()
    
    GetUserInfo
    If sDomain = "" Then sDomain = GetUserDomainInfo(1)
    If sLogonServer = "" Or sLogonServer = "\\*" Then sLogonServer = GetUserDomainInfo(2)
    If sCurrentWS = "" Then sCurrentWS = GetMachineName
    If sName = "" Then sName = GetUserDomainInfo(3)
    GetUserGroups sLogonServer, sName
    GetAccessUserSecurityInfo
End Sub
 
Private Sub GetUserGroups(ByVal sServerName As String, _
                          ByVal sUserName As String, _
                          Optional bLocalGroups As Boolean = False)
    'Populates a collection with the NT user groups to which the specified user belongs
    
    Dim bytUser() As Byte
    Dim bytServer() As Byte
    Dim lBuffer As Long
    Dim lEntries As Long
    Dim lMaxLen As Long
    Dim lTotalEntries As Long
    Dim lReturn As Long
    Dim lGroups() As Long
    Dim bytBuffer() As Byte
    Dim iCtr As Integer
    Dim lLen As Long
    Dim sGroups() As String
    
    If bLocalGroups Then
        'If we want the local groups only...
        sServerName = vbNullChar
    Else
        'If we want the remote groups only...
        If Left(sServerName, 2) <> "\\" Then sServerName = "\\" & sServerName
    End If
    
    'Initialize
    bytServer = sServerName & vbNullChar
    bytUser = sUserName & vbNullChar
    
    If bLocalGroups Then
        'Get the local groups
        lReturn = NetUserGetLocalGroups(bytServer(0), bytUser(0), 0, 0, _
            lBuffer, 1024, lMaxLen, lTotalEntries)
    Else
        'Get the remote groups
        lReturn = NetUserGetGroups(bytServer(0), bytUser(0), 0, _
            lBuffer, 1024, lMaxLen, lTotalEntries)
    End If
    
    If lReturn = 0 And lMaxLen > 0 Then
        ReDim lGroups(lMaxLen - 1) As Long
        ReDim sGroups(lMaxLen - 1) As String
        
        'Move the groups from the buffer to the array
        RtlMoveMemory lGroups(0), ByVal lBuffer, lMaxLen * 4
        
        For iCtr = 0 To lMaxLen - 1
            'Get the length of the array
            lLen = lstrlenW(lGroups(iCtr)) * 2
            If lLen > 0 Then
                'Fix the byte buffer array size
                ReDim bytBuffer(lLen - 1) As Byte
                
                'Move the groups from the array to the byte buffer
                RtlMoveMemory bytBuffer(0), ByVal lGroups(iCtr), lLen
                'Populate a new string array from the byte buffer
                sGroups(iCtr) = bytBuffer
                'Populate the collection from the string array
                colGroups.Add sGroups(iCtr), sGroups(iCtr)
            End If
        Next
    Else
        ReDim sGroups(0) As String
    End If
    
    'Clean up
    If lBuffer > 0 Then NetAPIBufferFree (lBuffer)
End Sub
 
Private Function GetCurrentUser() As String
    'Returns the current username
    Dim nSize As Long
    Dim lReturn As Long
    Dim sUserName As String
    
    sUserName = String(254, 0)
    nSize = 255
    
    lReturn = GetUserName(sUserName, nSize)
    If lReturn <> 0 Then
        GetCurrentUser = Left(sUserName, nSize - 1)
    Else
        GetCurrentUser = ""
    End If
End Function
 
Private Sub GetAccessUserSecurityInfo()
    Dim iCtr As Integer
    Dim sGroupName As String
    
    'Get the current user's Access username
    sAccessUsername = DBEngine(0).UserName
    
    'Get the Access security groups that the current user belongs to
    For iCtr = 0 To DBEngine(0).Users(sAccessUsername).Groups.count - 1
        sGroupName = DBEngine(0).Users(sAccessUsername).Groups(iCtr).name
        colAccessGroups.Add sGroupName, sGroupName
    Next iCtr
End Sub
 
Public Property Get Password() As String
    Password = sPassword
End Property
 
Public Property Get PasswordAge() As Long
    PasswordAge = lPasswordAge
End Property
 
Public Property Get HomeDir() As String
    HomeDir = sHomeDir
End Property
 
Public Property Get ScriptPath() As String
    ScriptPath = sScriptPath
End Property
 
Public Property Get Comment() As String
    Comment = sComment
End Property
 
Public Property Get FullName() As String
    FullName = sFullName
End Property
 
Public Property Get UserName() As String
    UserName = sName
End Property
 
Public Property Get UsrComment() As String
    UsrComment = sUsrComment
End Property
 
Public Property Get Workstations() As String
    Workstations = sWorkstations
End Property
 
Public Property Get LastLogon() As Date
    LastLogon = dteLastLogon
End Property
 
Public Property Get LastLogoff() As Date
    LastLogoff = dteLastLogoff
End Property
 
Public Property Get AcctExpires() As Date
    AcctExpires = dteAcctExpires
End Property
 
Public Property Get MaxStorage() As Long
    MaxStorage = lMaxStorage
End Property
 
Public Property Get UnitsPerWeek() As Long
    UnitsPerWeek = lUnitsPerWeek
End Property
 
Public Property Get LogonHours() As Long
    LogonHours = lLogonHours
End Property
 
Public Property Get BadPWCount() As Long
    BadPWCount = lBadPWCount
End Property
 
Public Property Get NumLogons() As Long
    NumLogons = lNumLogons
End Property
 
Public Property Get LogonServer() As String
    LogonServer = sLogonServer
End Property
 
Public Property Get CountryCode() As Long
    CountryCode = lCountryCode
End Property
 
Public Property Get UserID() As Long
    UserID = lUserID
End Property
 
Public Property Get PrimaryGroupID() As Long
    PrimaryGroupID = lPrimaryGroupID
End Property
 
Public Property Get HomeDirDrive() As String
    HomeDirDrive = sHomeDirDrive
End Property
 
Public Property Get PasswordExpired() As Boolean
    PasswordExpired = IIf(lPasswordExpired = 0, False, True)
End Property
 
Public Property Get CurrentWS() As String
    CurrentWS = sCurrentWS
End Property
 
Public Property Get Domain() As String
    Domain = sDomain
End Property
 
Public Property Get AccessUsername() As String
    AccessUsername = sAccessUsername
End Property
 
Public Property Get UserGroups() As Collection
    Set UserGroups = colGroups
End Property
 
Public Property Get AuthFlags() As Collection
    Set AuthFlags = colAuthFlags
End Property
 
Public Property Get AcctFlags() As Collection
    Set AcctFlags = colAcctFlags
End Property
 
Public Property Get Privileges() As Collection
    Set Privileges = colPrivileges
End Property
 
Public Property Get AccessUserGroups() As Collection
    Set AccessUserGroups = colAccessGroups
End Property
 
Private Sub Class_Initialize()
    'Instantiate all the collections
    Set colGroups = New Collection
    Set colAuthFlags = New Collection
    Set colAcctFlags = New Collection
    Set colPrivileges = New Collection
    Set colAccessGroups = New Collection
End Sub
 
Private Sub Class_Terminate()
    'Clean up
    Set colGroups = Nothing
    Set colAuthFlags = Nothing
    Set colAcctFlags = Nothing
    Set colPrivileges = Nothing
    Set colAccessGroups = Nothing
End Sub
' ************>>>>>>>  end of class module
 
'************>>>>>>>>  and some examples of other functions i popped in a module to pull the info out when asked to by a query or macro 
'- with the data loaded to a tempVar once fetched
 
Function fOSUserName() As String
'  Returns the username from active directory
    Dim CurrentUser As clsUserInfo
    Dim aUser As String
    Dim lLen As Long
        Set CurrentUser = New clsUserInfo
        With CurrentUser
            .CollectInfo
            fOSUserName = .FullName
        End With
        Set CurrentUser = Nothing
End Function
 
 
Function fOSPrimary() As String
'  Returns the primary user group from active directory
    Dim CurrentUser As clsUserInfo
    Dim primaryGp As String
        Set CurrentUser = New clsUserInfo
        With CurrentUser
            .CollectInfo
            primaryGp = .PrimaryGroupID
            If (primaryGp > 0) Then
                fOSPrimary = primaryGp
            Else
                fOSPrimary = "none"
            End If
        End With
        Set CurrentUser = Nothing
End Function
 
 
Function fOSADGrp(Grp As String) As String
'  Checks user groups from active directory
    Dim CurrentUser As clsUserInfo
    Dim varItem As Variant
    Dim aFlag As String
        Set CurrentUser = New clsUserInfo
        With CurrentUser
            .CollectInfo
            For Each varItem In .UserGroups
                If varItem = Grp Then
                    aFlag = "y"
                End If
            Next varItem
            If aFlag = "y" Then
                fOSADGrp = "y"
            Else
                fOSADGrp = "n"
            End If
 '  end user group loop
        End With
        Set CurrentUser = Nothing
End Function

Open in new window

0
 
Joe3RingsAuthor Commented:
thanks :)
0

Featured Post

The new generation of project management tools

With monday.com’s project management tool, you can see what everyone on your team is working in a single glance. Its intuitive dashboards are customizable, so you can create systems that work for you.

  • 11
  • 10
Tackle projects and never again get stuck behind a technical roadblock.
Join Now