VBA If password matches a userform string

[decadence]

Hi, I am trying to match the string typed into a user form against the windows password, how can I do this?
There are no passwords stored anywhere and the string that is typed is covered by stars so the passwords won't be visible when typed.

The code below is from Expert Exchange

Option Explicit
Private Declare Function NetUserChangePassword Lib "Netapi32" (ByVal domainname As Long, ByVal UserName As Long, ByVal OldPassword As Long, ByVal NewPassword As Long) As Long
Private Const NERR_SUCCESS = 0
Private Const INVALID_PASSWORD = 86&
Private Const ACCESS_DENIED = 5

Private Sub Command1_Click()
     Dim arg As String
     arg = InputBox("Enter Password", "Window logon", vbNullString)
     Select Case arg
         Case vbNullString
         If WindowPassword(arg, arg) Then
             MsgBox "The current users password is blank."
         End If
         Case Else
         If WindowPassword(arg, arg) Then
             MsgBox "Windows Logon Password: " & arg
         End If
     End Select
 End Sub 

Function WindowPassword(ByVal oldpw As String, ByVal newpw As String, Optional ByVal UserName As String = vbNullString) As Boolean
    Dim NetRet As Long
    NetRet = NetUserChangePassword(0&, StrPtr(UserName), StrPtr(oldpw), StrPtr(newpw))
     Select Case NetRet
         Case NERR_SUCCESS
             WindowPassword = True
         Case INVALID_PASSWORD
             MsgBox "Invalid Password"
         Case ACCESS_DENIED
             MsgBox "Access denied"
     End Select
 End Function

 

[Logit]

.
Confused ... are you saying you already know the Windows Logon password ?

What is the purpose of matching the Logon password from your Userform ? Can another password work ?

 

[decadence]

Hi Logit, The purpose is to match what the user puts in the user form against who is logged in, If the person who is logged on the computer has validated their login on the userform then they can proceed.
If the person who tries to validate their credentials while someone else is logged on cannot proceed. I don't need to know or want to know the users credentials, all I want to do is make the user validate who they are when using specific files as the computers are shared and trying to prevent false data entry.

Below is what I have so far, I only want the user to use the userform password box and not the arg inputbox to validate the credentials.

Option Explicit
Private Declare Function NetUserChangePassword Lib "Netapi32" (ByVal domainname As Long, ByVal UserName As Long, ByVal OldPassword As Long, ByVal NewPassword As Long) As Long
Private Const NERR_SUCCESS = 0
Private Const INVALID_PASSWORD = 86&
Private Const ACCESS_DENIED = 5
Private Declare Function WNetGetUser Lib "mpr.dll" Alias "WNetGetUserA" (ByVal lpName As String, ByVal lpUserName As String, lpnLength As Long) As Long
Const lpnLength As Integer = 255
Const NoError = 0
Dim status As Integer
Dim lpName As String, lpUserName As String, sUser As String, sPass As String, arg As String


Private Sub Validate_Click()
	
    If sUser = GetUserName Then
        'If sPass = arg Then <------ Need to match user form input with windows password
        'arg = InputBox("Enter Password", "Window logon", vbNullString) <----- Needs Removing, Replace with User Form sPass?
            Select Case arg
                Case vbNullString
                    If WindowPassword(arg, arg) Then
                        MsgBox "The current users password is blank."
                    End If
                Case Else
                    If WindowPassword(arg, arg) Then
                        MsgBox "Windows Logon Password: " & arg
                    End If
            End Select
         'End If
     Else
          MsgBox "Unauthorized Access to this File!"
          Application.Quit
     End If
End Sub


Function GetUserName()
    lpUserName = Space$(lpnLength + 1)
    status = WNetGetUser(lpName, lpUserName, lpnLength)
        If status = NoError Then
            lpUserName = Left$(lpUserName, InStr(lpUserName, Chr(0)) - 1)
        Else
            MsgBox "Unable to get the name."
        End If
    GetUserName = lpUserName
End Function

Function WindowPassword(ByVal oldpw As String, ByVal newpw As String, Optional ByVal UserName As String = vbNullString) As Boolean
    Dim NetRet As Long
    NetRet = NetUserChangePassword(0&, StrPtr(UserName), StrPtr(oldpw), StrPtr(newpw))
     Select Case NetRet
         Case NERR_SUCCESS
             WindowPassword = True
         Case INVALID_PASSWORD
             MsgBox "Invalid Password"
         Case ACCESS_DENIED
             MsgBox "Access denied"
     End Select
 End Function

 

[Logit]

.
Several comments...

I have been unable to get your code to work here. Do you have a fully functioning copy that you can upload to DropBox or similar website so it can be downloaded and reviewed ?

I've researched numerous websites relating to your needs. I cannot find a resource that demonstrates how to obtain the Windows User Password. The UserName is easily obtained but
not the password.

???

 

[decadence]

Hi Logit, Unfortunately My company won't allow dropbox

This all the code I have so far which I have updated since the previous post

Basically there is a one button to login with 2 textboxes to input user and password

Option Explicit
Private Declare Function NetUserChangePassword Lib "Netapi32" (ByVal domainname As Long, ByVal UserName As Long, ByVal OldPassword As Long, ByVal NewPassword As Long) As Long
Private Const NERR_SUCCESS = 0
Private Const INVALID_PASSWORD = 86&
Private Const ACCESS_DENIED = 5
Private Declare Function WNetGetUser Lib "mpr.dll" Alias "WNetGetUserA" (ByVal lpName As String, ByVal lpUserName As String, lpnLength As Long) As Long
Const lpnLength As Integer = 255
Const NoError = 0
Dim status As Integer, iCounta As Integer
Dim lpName As String, lpUserName As String, sUser As String, sMsg As String, sTitle As String, sStyle As String, sPW As String, arg As String, xStr As String
 
Private Sub Validate_Click()
'
    If sUser = GetUserName Then
        'If sPass = arg Then <------ Need to match user form input with windows password
        'arg = InputBox("Enter Password", "Window logon", vbNullString) <----- Needs Removing, Replace with User Form sPass?
            Select Case arg
                    Case vbNullString
                        If WindowPassword(arg, arg) Then
                            MsgBox "The current users password is blank."
                        End If
                    Case Else
                        If WindowPassword(arg, arg) Then
                            MsgBox "Windows Logon Password: " & arg
                        End If
                    End Select
                iCounta = Me.tbxGoes.Value
                sTitle = "Incorrect Password"
                sMsg = "You have entered an incorrect Username or Password" & vbNewLine & "Try again" & vbNewLine & "You have " & (3 - iCounta) & " goes left"
                sStyle = vbOKOnly + vbExclamation
                    If iCounta < 3 Then
                        If Me.tbxUser.Value <> sUser Or Me.tbxPW.Value <> sPW Then
                            MsgBox sMsg, sStyle, sTitle
                                With Me
                                    tbxUser.Value = vbNullString
                                    tbxPW = vbNullString
                                    tbxUser.SetFocus
                                    tbxGoes.Value = iCounta + 1
                                End With
                        End If
                    ElseIf iCounta > 2 Then
                        MsgBox "You have tried three time incorrectly. WorkBook will now close", vbOKOnly + vbExclamation, "Warning"
                        ActiveWorkbook.Close savechanges:=False
                    End If
            End If
            Unload Me
        End If
End Sub
Private Sub tbxUser_Change()
End Sub
Private Sub tbxGoes_Change()
End Sub
Private Sub UserForm_Click()
End Sub
Private Sub UserForm_Initialize()
Me.tbxGoes.Value = 1
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    If CloseMode = vbFormControlMenu Then
        MsgBox "User Name and Password Required to Access this File!"
        Cancel = True
    End If
 End Sub
Function GetUserName()
    lpUserName = Space$(lpnLength + 1)
    status = WNetGetUser(lpName, lpUserName, lpnLength)
        If status = NoError Then
            lpUserName = Left$(lpUserName, InStr(lpUserName, Chr(0)) - 1)
        Else
            MsgBox "Unable to get the name."
        End If
    GetUserName = lpUserName
End Function
Function WindowPassword(ByVal oldpw As String, ByVal newpw As String, Optional ByVal UserName As String = vbNullString) As Boolean
    Dim NetRet As Long
    NetRet = NetUserChangePassword(0&, StrPtr(UserName), StrPtr(oldpw), StrPtr(newpw))
     Select Case NetRet
         Case NERR_SUCCESS
             WindowPassword = True
         Case INVALID_PASSWORD
             MsgBox "Invalid Password"
         Case ACCESS_DENIED
             MsgBox "Access denied"
     End Select
 End Function

 

[Logit]

.
Since my last post I've done additional research. The Windows password is not stored in a conventional manner as you might store a password for
a VBA workbook. Also, the password is not accessible when Windows is running.

In order to obtain the Windows password, you'll need another program to access the location and in essence "translate" what is there into something
intelligible.

All in all, trying to use the Windows password to match against is going to require much more work, coding and effort than it is truly worth. I inquired of
some Microsoft folks about this goal ... their response was cryptic at best. All in all, there was no effort to assist probably due to the concern of circumventing
security and not believing how the information might really be used.

Your best path I believe will be to take the conventional approach : either assign a password to each individual or have them create their own when they first
open the workbook.

 

[decadence]

Thanks for your help Logit, I knew it was a long shot but I will just have to sort something else out

 

[Logit]

.
Cheers