Check Credentials against OS

[doma23]

This thread was taken from a post in Nz function not working and refers to comments in post #4.

Yeah, I was thinking if you could share that API function you have, because I was searching for a way to verify the user's win password in access for some time now.

[Jerry Maiapu]

Ok, Create a form "FRM_LOGIN" make sure you you have these text boxes TXT_USERNAME,TXT_PASSWORD,and a combo box CMBO_DOMAIN (lists names of domain if in a network or name of PC if stand-lone)

Create a login cmd button ,CMD_LOGIN, to validate
Copy and paste the following in the form's VB Editor..

Option Compare Database
Option Explicit
 
Dim stDocName As String
 
 
Private Type NETRESOURCE
   dwScope                             As Long
   dwType                              As Long
   dwDisplayType                       As Long
   dwUsage                             As Long
   pLocalName                          As Long
   pRemoteName                         As Long
   pComment                            As Long
   pProvider                           As Long
End Type
 
Private Declare Function WNetOpenEnum _
   Lib "mpr.dll" Alias "WNetOpenEnumA" _
   (ByVal dwScope As Long, _
   ByVal dwType As Long, _
   ByVal dwUsage As Long, _
   lpNetResource As Any, _
   lppEnumHwnd As Long) As Long
 
Private Declare Function WNetEnumResource _
   Lib "mpr.dll" Alias "WNetEnumResourceA" _
   (ByVal pEnumHwnd As Long, _
   lpcCount As Long, _
   lpBuffer As NETRESOURCE, _
   lpBufferSize As Long) As Long
 
Private Declare Function WNetCloseEnum _
   Lib "mpr.dll" _
   (ByVal p_lngEnumHwnd As Long) As Long
 
Private Declare Function NetUserGetInfo _
   Lib "netapi32.dll" _
   (ServerName As Byte, _
   Username As Byte, _
   ByVal Level As Long, _
   Buffer As Long) As Long
 
Private Declare Function StrLenA _
   Lib "kernel32" Alias "lstrlenA" _
   (ByVal Ptr As Long) As Long
 
Private Declare Function StrCopyA _
   Lib "kernel32" Alias "lstrcpyA" _
   (ByVal RetVal As String, _
   ByVal Ptr As Long) As Long
 
Private Const MAX_RESOURCES            As Long = 256
Private Const RESOURCE_GLOBALNET       As Long = &H2&
Private Const RESOURCETYPE_ANY         As Long = &H0&
Private Const RESOURCEUSAGE_ALL        As Long = &H0&
Private Const NO_ERROR                 As Long = 0&
Private Const RESOURCE_ENUM_ALL        As Long = &HFFFF
 
 
Private Sub Form_Load()
GetDomains
DoCmd.GoToControl "TXT_PASSWORD"
End Sub
 
Private Sub CMD_LOGIN_Click()
Dim StrPWord As String
Dim StrUserName As String
Dim StrDomain As String
 
On Error GoTo NoData
StrPWord = Me.TXT_PASSWORD
StrUserName = Me.TXT_USERNAME
StrDomain = Me.CMBO_DOMAIN
 
ValidatePW StrPWord, StrUserName, StrDomain
 
Exit Sub
 
NoData:
 
MsgBox "Unable to complete login; One or more pieces of required information are missing", vbInformation, "Missing Data"
 
End Sub
Public Function ValidatePW(Password As String, Username As String, DomainName As String) As Boolean
' Start by retrieving the user's name
Dim lpBuffer As String, nSize As Long
Dim rv As Long, usrName As String
Dim hToken As Long
 
' Initialise an empty buffer, 10 characters long (long enough for most user names)
lpBuffer = String(10, Chr(0))
Do
    nSize = Len(lpBuffer)
    rv = GetUserName(lpBuffer, nSize)
    If rv = 0 Then
        ' The function probably failed due to the buffer being too small
        ' nSize holds the required size
        lpBuffer = String(nSize, Chr(0)) ' Resize buffer to accomodate big name
    End If
Loop Until rv <> 0
' Extract user name from buffer
usrName = Left(lpBuffer, nSize - 1)
 
If usrName <> Username Then
  Msgbox "Username Incorrect"
    TXT_USERNAME.SetFocus
 
    Exit Function
 
End If
 
If Domain() <> DomainName Then
    MsgBox " Wrong Domain name"
    CMBO_DOMAIN.SetFocus
 
    Exit Function
 
End If
 
' Now validate the password
rv = LogonUser(usrName, vbNullString, Password, LOGON32_LOGON_NETWORK, LOGON32_PROVIDER_DEFAULT, hToken)
If rv <> 0 Then
    ' Password validated successfully    
     Me!TXT_PASSWORD = ""
        Me.Visible = False
     stDocName = "Enter name of form to open after validation success"
     DoCmd.OpenForm stDocName
 
Else
    ' Username and password failed validation
  Msgbox"Incorrect Password"
     TXT_PASSWORD.SetFocus
End If
End Function
 
Public Function Domain() As String
Dim wshNet As Object
Set wshNet = CreateObject("WScript.Network")
On Error GoTo errBadNetwork
Domain = wshNet.UserDomain
Set wshNet = Nothing
Exit Function
errBadNetwork:
Domain = "Unavailable"
End Function
Public Sub GetDomains()
 
Dim p_avntDomains                   As Variant
Dim p_lngLoop                       As Long
Dim p_lngNumItems                   As Long
 
p_avntDomains = EnumDomains()
 
On Error Resume Next
p_lngNumItems = UBound(p_avntDomains)
On Error GoTo 0
 
If p_lngNumItems > 0 Then
   For p_lngLoop = 1 To p_lngNumItems
 
      Me.CMBO_DOMAIN.AddItem p_avntDomains(p_lngLoop)
 
   Next p_lngLoop
 
Else
 
    Me.CMBO_DOMAIN.AddItem Domain()
 
End If
 
End Sub
 
Private Function EnumDomains() As Variant
 
Dim p_lngRtn                        As Long
Dim p_lngEnumHwnd                   As Long
Dim p_lngCount                      As Long
Dim p_lngLoop                       As Long
Dim p_lngBufSize                    As Long
Dim p_astrDomainNames()             As String
Dim p_atypNetAPI(0 To MAX_RESOURCES) As NETRESOURCE
 
' ------------------------------------------
' First time thru, we are just getting the root level
' ------------------------------------------
p_lngEnumHwnd = 0&
p_lngRtn = WNetOpenEnum(dwScope:=RESOURCE_GLOBALNET, _
   dwType:=RESOURCETYPE_ANY, _
   dwUsage:=RESOURCEUSAGE_ALL, _
   lpNetResource:=ByVal 0&, _
   lppEnumHwnd:=p_lngEnumHwnd)
 
If p_lngRtn = NO_ERROR Then
   p_lngCount = RESOURCE_ENUM_ALL
 
   p_lngBufSize = UBound(p_atypNetAPI) * Len(p_atypNetAPI(0))
   p_lngRtn = WNetEnumResource(pEnumHwnd:=p_lngEnumHwnd, _
      lpcCount:=p_lngCount, _
      lpBuffer:=p_atypNetAPI(0), _
      lpBufferSize:=p_lngBufSize)
 
End If
 
If p_lngEnumHwnd <> 0 Then
   Call WNetCloseEnum(p_lngEnumHwnd)
End If
 
' ------------------------------------------
' Now we are going for the second level,
'     which should contain the domain names
' ------------------------------------------
p_lngRtn = WNetOpenEnum(dwScope:=RESOURCE_GLOBALNET, _
   dwType:=RESOURCETYPE_ANY, _
   dwUsage:=RESOURCEUSAGE_ALL, _
   lpNetResource:=p_atypNetAPI(0), _
   lppEnumHwnd:=p_lngEnumHwnd)
 
If p_lngRtn = NO_ERROR Then
   p_lngCount = RESOURCE_ENUM_ALL
 
   p_lngBufSize = UBound(p_atypNetAPI) * Len(p_atypNetAPI(0))
   p_lngRtn = WNetEnumResource(pEnumHwnd:=p_lngEnumHwnd, _
      lpcCount:=p_lngCount, _
      lpBuffer:=p_atypNetAPI(0), _
      lpBufferSize:=p_lngBufSize)
 
   If p_lngCount > 0 Then
      ReDim p_astrDomainNames(1 To p_lngCount) As String
      For p_lngLoop = 0 To p_lngCount - 1
         p_astrDomainNames(p_lngLoop + 1) = _
         PointerToAsciiStr(p_atypNetAPI(p_lngLoop).pRemoteName)
      Next p_lngLoop
   End If
End If
 
If p_lngEnumHwnd <> 0 Then
   Call WNetCloseEnum(p_lngEnumHwnd)
End If
 
' ------------------------------------------
' Set the return value
' ------------------------------------------
EnumDomains = p_astrDomainNames
 
End Function
 
Private Function PointerToAsciiStr(ByVal xi_lngPtrToString _
  As Long) As String
 
On Error Resume Next         ' Don't accept an error here
 
Dim p_lngLen                        As Long
Dim p_strStringValue                As String
Dim p_lngNullPos                    As Long
Dim p_lngRtn                        As Long
 
p_lngLen = StrLenA(xi_lngPtrToString)
If xi_lngPtrToString > 0 And p_lngLen > 0 Then
   p_strStringValue = Space$(p_lngLen + 1)
   p_lngRtn = StrCopyA(p_strStringValue, xi_lngPtrToString)
   p_lngNullPos = InStr(p_strStringValue, Chr$(0))
   If p_lngNullPos > 0 Then
      PointerToAsciiStr = Left$(p_strStringValue, _
         p_lngNullPos - 1) 'Lose the null terminator...
   Else
      'Just pass the string...
      PointerToAsciiStr = p_strStringValue
   End If
Else
   PointerToAsciiStr = ""
End If
 
End Function

Hope this helps..
Note: REPLACE Enter name of form to open after validation successIN CODE LINE 127 WITH YOU FORM'S NAME THAT WILL OPEN AFTER VALIDATION IS SUCCESSFUL.

Cheers..

Jerry Maiapu
Mangi Karex

Welcome to Bytes..

[doma23]

@Jerry Maiapu
Tnx a bunch!
I'll give it a shot and let you know if the implementation was succesful.

[doma23]

Uhhh, late reply. Here it goes.
I've tried to implement this and this is what I got:

1) On a click of a LOGIN button I got "Sub or function not define" error, pointing to "GetUserName" in the code. After that I've added this line:

Private Declare Function GetUserName Lib "advapi32.dll" (ByVal lpBuffer As String, nSize As Long) As Long

It seemed to work, as the next error message was different.

2) Variable not defined pointing to "LOGON32_LOGON_NETWORK" in this code:

' Now validate the password
rv = LogonUser(usrName, vbNullString, Password, LOGON32_LOGON_NETWORK, LOGON32_PROVIDER_DEFAULT, hToken)

Thanks!

[NeoPa]

Jerry, I guess the actual procedure that makes the OS call to check the name and password is called LogonUser(). Unfortunately, this particular procedure wasn't included in your post.

As I think there may be some interest in this, from public and members alike, would you mind posting that routine and any supporting declarations for all to see. Thanks for your efforts :)

[Jerry Maiapu]

My fault. Shame on me.. Create a new module and add this

Option Compare Database
 
Public Const LOGON32_LOGON_BATCH = 4
Public Const LOGON32_LOGON_INTERACTIVE = 2
Public Const LOGON32_LOGON_SERVICE = 5
Public Const LOGON32_LOGON_NETWORK = 3
Public Const LOGON32_PROVIDER_DEFAULT = 0
Public Const LOGON32_PROVIDER_WINNT35 = 1
Public Declare Function LogonUser Lib "advapi32.dll" Alias "LogonUserA" (ByVal lpszUsername As String, ByVal lpszDomain As String, ByVal lpszPassword As String, ByVal dwLogonType As Long, ByVal dwLogonProvider As Long, phToken As Long) As Long
 
 
Public Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long

It should be fine now

Cheers!

Jerry

[Jerry Maiapu]

NeoPA,

Would you mind making these posts concerning usernanme,password stuff a new threat while giving a suitable title..(All posts starting from say post# 8)This is to help those interest public and members like you mention..

Thanks..

Jerry

[NeoPa]

All done Jerry :)

[Jerry Maiapu]

Heaps of thanks

Cheers

[NeoPa]

If my reading of the documentation is right, then LogonUserA doesn't only check the credentials, it also creates a validated user context, within which processes can initiated on behalf of the said user. As such, tidy code would demand that the context be cleared down with a user logoff of some form. I found nothing for UserLogoffA. Perhaps you have code to handle this Jerry (Sorry if it's in your posted code and I missed it).