• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 236
  • Last Modified:

Passwords in Visual Basic

I have a log on box that retrieves the log on id from the system.  Now i want to be able to have the user type in their system password and i want to check to see if it is the same as the system password.  is there any routine that i can use.  if anyone knows how to do this can you please let me know and if you have any snippets of code to share that would be greatly appreciated.  thanks

1 Solution
You can not get the user password in your code because of NT security.
You can only try to change existing password.
Operation will be succeeded only if old password i correct.

See example :

Option Explicit

' *****************
' Usage Example - ChangePassword and GetLastError Functions
' *****************
'Private Sub cmdOK_Click()
'  'This is an example on how to the the cOSNT_ChangePassword class.
'  Dim bResult As Boolean
'  Dim clsChange As cOSNT_ChangePassword
'  Set clsChange = New cOSNT_ChangePassword
'  MousePointer = vbHourglass
'  bResult = clsChange.ChangePassword(txtUser.Text, txtMachine.Text, txtNew.Text, txtOld.Text)
'  MousePointer = vbDefault
'  If bResult = False Then
'     MsgBox clsChange.GetLastError, vbCritical, "Change Password Error"
'  Else
'     MsgBox "Password Change was Successful"
'  End If
'  Set clsChange = Nothing
'End Sub

  Const NERR_BASE = 2100
  Const MAX_NERR = NERR_BASE + 899 ' This is the last error in
                                   ' NERR   range.

  Private Declare Function LoadLibraryEx Lib "kernel32" Alias _
     "LoadLibraryExA" (ByVal lpLibFileName As String, _
     ByVal hFile As Long, ByVal dwFlags As Long) As Long

  Private Declare Function FreeLibrary Lib "kernel32" _
     (ByVal hLibModule As Long) As Long

  Private Declare Function NetApiBufferFree& Lib "netapi32" _
     (ByVal Buffer As Long)

  Private Declare Sub lstrcpyW Lib "kernel32" (dest As Any, ByVal src As Any)

  Private Declare Function FormatMessage Lib "kernel32" Alias _
     "FormatMessageA" (ByVal dwFlags As Long, _
     ByVal lpSource As Long, _
     ByVal dwMessageId As Long, _
     ByVal dwLanguageId As Long, ByVal lpBuffer As String, _
     ByVal nSize As Long, Arguments As Any) As Long

  Private Declare Function NetUserSetInfo Lib "netapi32.dll" _
     (ByVal ServerName As String, ByVal Username As String, _
     ByVal Level As Long, UserInfo As Any, ParmError As Long) As Long

  Private Declare Function NetGetDCName Lib "netapi32.dll" ( _
     ServerName As Long, domainname As Byte, bufptr As Long) As Long

  Private Declare Function NetUserChangePassword Lib "netapi32.dll" ( _
     ByVal domainname As String, ByVal Username As String, _
     ByVal OldPassword As String, ByVal NewPassword As String) As Long

  Private Type USER_INFO_1003
     usri1003_password As Long
  End Type

Private mlLastReturnCode As Long

Public Function ChangePassword(UserID As String, MachineOrDomain As String, NewPassword As String, OldPassword As String) As Boolean
  Dim sServer As String, sUser As String
  Dim sNewPass As String, sOldPass As String
  Dim UI1003 As USER_INFO_1003
  Dim dwLevel As Long
  Dim lRet As String
  Dim sNew As String

  ' StrConv Functions are necessary since VB will perform
  ' UNICODE/ANSI translation before passing strings to the NETAPI
  ' functions

  sUser = StrConv(UserID, vbUnicode)
  sNewPass = StrConv(NewPassword, vbUnicode)

  'See if this is Domain or Computer referenced
  If Left(MachineOrDomain, 2) = "\\" Then
    sServer = StrConv(MachineOrDomain, vbUnicode)
    ' Domain was referenced, get the Primary Domain Controller
    sServer = StrConv(GetPrimaryDCName(MachineOrDomain), vbUnicode)
  End If

  If OldPassword = "" Then
     ' Administrative over-ride of existing password.
     ' Does not require old password

     dwLevel = 1003
     sNew = NewPassword
     UI1003.usri1003_password = StrPtr(sNew)
     mlLastReturnCode = NetUserSetInfo(sServer, sUser, dwLevel, UI1003, 0&)
     ' Set the Old Password and attempt to change the user's password
     sOldPass = StrConv(OldPassword, vbUnicode)
     mlLastReturnCode = NetUserChangePassword(sServer, sUser, sOldPass, sNewPass)
  End If
  'If the last operation (SetInfo or ChangePassword) were successful then the return code (mlLastReturnCode) will be zero.
  If mlLastReturnCode <> 0 Then
    ChangePassword = False
    ChangePassword = True
  End If
End Function

Public Function GetLastError() As String

  Dim sMsg As String
  Dim sRtrnCode As String
  Dim lFlags As Long
  Dim hModule As Long
  Dim lRet As Long

   hModule = 0
   sRtrnCode = Space$(256)

    ' if lRet is in the network range, load the message source

    If (mlLastReturnCode >= NERR_BASE And mlLastReturnCode <= MAX_NERR) Then
       hModule = LoadLibraryEx("netmsg.dll", 0&, _

       If (hModule <> 0) Then
           lFlags = lFlags Or FORMAT_MESSAGE_FROM_HMODULE
       End If

    End If

   ' Call FormatMessage() to allow for message text to be acquired
   ' from the system or the supplied module handle.

   lRet = FormatMessage(lFlags, hModule, mlLastReturnCode, 0&, _
                        sRtrnCode, 256&, 0&)
   If lRet = 0 Then
      GetLastError = "FormatMessage Error : " & Err.LastDllError
   End If

   ' if you loaded a message source, unload it.
   If (hModule <> 0) Then
     FreeLibrary (hModule)
   End If

'//... now display this string
sMsg = "ERROR: " & mlLastReturnCode & " - " & sRtrnCode

GetLastError = sMsg

End Function
Public Function GetPrimaryDCName(ByVal DName As String) As String

  Dim DCName As String, DCNPtr As Long
  Dim DNArray() As Byte, DCNArray(100) As Byte
  Dim result As Long

  DNArray = DName & vbNullChar
  ' Lookup the Primary Domain Controller
  result = NetGetDCName(0&, DNArray(0), DCNPtr)
  If result <> 0 Then
     'MsgBox "Error: " & result
     Exit Function
  End If
  lstrcpyW DCNArray(0), DCNPtr
  result = NetApiBufferFree(DCNPtr)
  DCName = DCNArray()
  GetPrimaryDCName = Left(DCName, InStr(DCName, Chr(0)) - 1)

End Function

I think it will be useful for you a lot of Password/VB source code :
Search for Password

Good lick...

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

Join & Write a Comment

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.

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