I am having a simalair problem, i need to setup a specific group to be able
to aceess the db, is that possible .. i have copied the code that is in the
log in please advise
Is there a way to designate a specific OU for acces to the resource?
thanks in advance
Option Explicit
Private Declare Function LogonUser Lib "Advapi32" Alias "LogonUserA" (ByVal
lpszUsername As String, ByVal lpszDomain As Any, ByVal lpszPassword As
String, ByVal dwLogonType As Long, ByVal dwLogonProvider As Long, phToken As
Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long)
As Long
Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA"
(ByVal dwFlags As Long, lpSource As Any, ByVal dwMessageId As Long, ByVal
dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long,
Arguments As Long) As Long
Private Declare Function NetUserChangePassword Lib "netapi32.dll" (ByVal
sDomain As String, ByVal sUserName As String, ByVal sOldPassword As String,
ByVal sNewPassword As String) As Long
'Purpose : Checks if a the NT password for a user is correct.
'Inputs : UserName The username
' Password The password
' [Domain] If DOMAIN is omitted uses the local
account database.
'Outputs : Returns True if the password and user name are valid.
'Notes : Windows NT and 2000 ONLY. Will work on any machine.
' Slower than the UserCheckPassword function, but more reliable.
Function UserValidate(sUserName As String, sPassword As String, Optional
sDomain As String) As Boolean
Dim lReturn As Long
Const NERR_BASE = 2100
Const NERR_PasswordCantChange = NERR_BASE + 143
Const NERR_PasswordHistConflict = NERR_BASE + 144
Const NERR_PasswordTooShort = NERR_BASE + 145
Const NERR_PasswordTooRecent = NERR_BASE + 146
If Len(sDomain) = 0 Then
sDomain = Environ$("USERDOMAIN")
End If
'Call API to check password.
lReturn = NetUserChangePassword(StrConv(sDomain, vbUnicode),
StrConv(sUserName, vbUnicode), StrConv(sPassword, vbUnicode),
StrConv(sPassword, vbUnicode))
'Test return value.
Select Case lReturn
Case 0, NERR_PasswordCantChange, NERR_PasswordHistConflict,
NERR_PasswordTooShort, NERR_PasswordTooRecent
UserValidate = True
Case Else
UserValidate = False
End Select
End Function
'Purpose : Checks if a the NT password for a user is correct.
'Inputs : UserName The username
' Password The password
' [Domain] If DOMAIN is omitted uses the local
account database.
'Outputs : Returns True if the password and user name are valid.
'Notes : Windows NT and 2000 ONLY. Requires correct permissions to
run (must have
' the SE_TCB_NAME privilege. In User Manager, this is the "Act
as part of the
' Operating System" right).
Function UserCheckPassword(ByVal UserName As String, ByVal Password As
String, Optional ByVal Domain As String = vbNullString) As Boolean
Dim lRet As Long, hToken As Long
Const LOGON32_LOGON_NETWORK = 3& 'Intended for high
performance servers to authenticate clear text passwords
Const LOGON32_LOGON_INTERACTIVE = 2& 'Intended for users who will
be interactively using the machine, such as a user being logged on by a
terminal server
Const LOGON32_LOGON_BATCH = 4&
Const LOGON32_PROVIDER_DEFAULT = 0& 'Use the standard logon
provider for the system
Const LOGON32_PROVIDER_WINNT40 = 2& 'Use the Windows NT 4.0
logon provider
Const LOGON32_PROVIDER_WINNT35 = 1& 'Use the Windows NT 3.5
logon provider
Const LOGON32_PROVIDER_WINNT50 = 3& 'Use the Windows 2000 logon
provider.
'Check the username and password
lRet = LogonUser(UserName, Domain, Password, LOGON32_LOGON_NETWORK,
LOGON32_PROVIDER_DEFAULT, hToken)
If lRet Then
'Password correct
UserCheckPassword = True
CloseHandle hToken
Else
'Failed:
Debug.Print "Error: " & DLLErrorText(Err.LastDllError)
End If
End Function
'Purpose : Return the error message associated with LastDLLError
'Inputs : lLastDLLError The error number of the last DLL
error (from Err.LastDllError)
'Outputs : Returns the error message associated with the DLL error number
'Notes :
'Revisions :
Public Function DLLErrorText(ByVal lLastDLLError As Long) As String
Dim sBuff As String * 256
Dim lCount As Long
Const FORMAT_MESSAGE_ALLOCATE_BUFFER = &H100,
FORMAT_MESSAGE_ARGUMENT_ARRAY = &H2000
Const FORMAT_MESSAGE_FROM_HMODULE = &H800, FORMAT_MESSAGE_FROM_STRING =
&H400
Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000, FORMAT_MESSAGE_IGNORE_INSERTS
= &H200
Const FORMAT_MESSAGE_MAX_WIDTH_MASK = &HFF
lCount = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM Or
FORMAT_MESSAGE_IGNORE_INSERTS, 0, lLastDLLError, 0&, sBuff, Len(sBuff), ByVal
0)
If lCount Then
DLLErrorText = Left$(sBuff, lCount - 2) 'Remove line feeds
End If
End Function
Sub TestLogin()
'Check if password is valid
Debug.Print "Password valid, method 1: " & UserCheckPassword("rcurran",
InputBox("Password"))
Debug.Print "Password valid method 2: " & UserValidate("rcurran",
InputBox("Password"))
'Debug.Print "Password valid, method 1: " &
UserCheckPassword(Environ$("USERNAME"), "password")
'Debug.Print "Password valid method 2: " &
UserValidate(Environ$("USERNAME"), "password")
End Sub
Function bConfirmCreateLogin(psUser As String, psPassword As String,
Optional psDomain As String) As Boolean
On Error GoTo R_Err
Dim sSQL As String
bConfirmCreateLogin = False
If UserValidate(psUser, psPassword, psDomain) = True Then
'Confirm User Created
If DCount("UserID", "tblUser", "UserName=""" & Nz(psUser, "") & """
") = 0 Then
sSQL = "INSERT INTO tblUser (UserName, FullName) SELECT """ &
Nz(psUser, "") & """,""" & UCase(Nz(psUser, "")) & """ "
DoCmd.SetWarnings False
DoCmd.RunSQL (sSQL)
End If
bConfirmCreateLogin = True
End If
R_Err:
On Error Resume Next
DoCmd.SetWarnings True
Exit Function
R_Exit:
bConfirmCreateLogin = False
Resume R_Err
End Function
