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
Private Declare Function GetUserName Lib "advapi32.dll" (ByVal lpBuffer As String, nSize As Long) As Long
' Now validate the password rv = LogonUser(usrName, vbNullString, Password, LOGON32_LOGON_NETWORK, LOGON32_PROVIDER_DEFAULT, hToken)
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
Comment