This code will generate authentication task for the application credentials entered in, validates w

by Gorla Venkateshwara Rao (1 Submission)
Category: Encryption
Compatability: VB 6.0
Difficulty: Unknown Difficulty
Originally Published: Fri 5^th December 2003
Date Added: Mon 8^th February 2021
Rating: (1 Votes)

This code will generate authentication task for the application credentials entered in, validates with the windows login credentials for

API Declarations
Option Explicit ' API Declerations for Getting the ClsId of the ActiveX component Public Declare Function CLSIDFromProgID Lib "ole32.dll" (ByVal lpszProgID As Long, pCLSID As GUID) As Long Public Declare Function StringFromCLSID Lib "ole32.dll" (pCLSID As GUID, lpszProgID As Long) As Long Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long) ' API to get the local computer name Public Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long ' Public Const MAX_COMPUTERNAME_LENGTH As Long = 15& ' ' CLSID/GUID structure Public Type GUID Data1 As Long Data2 As Integer Data3 As Integer Data4(7) As Byte End Type ' Public Const MOVEFILE_COPY_ALLOWED = &H2 Public Const MOVEFILE_REPLACE_EXISTING = &H1 Public Declare Function MoveFile Lib "kernel32" Alias "MoveFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String) As Long Public Declare Function MoveFileEx Lib "kernel32" Alias "MoveFileExA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal dwFlags As Long) As Long Public Declare Function DeleteFile Lib "kernel32" Alias "DeleteFileA" (ByVal lpFileName As String) As Long ' Public Const APP_TITLE As String = "iIE 2.4 Test Harness" Global Const REG_SZ As Long = 1 Global Const REG_DWORD As Long = 4 Public Const REG_BINARY = 3 ' Free form binary Public Const REG_DWORD_BIG_ENDIAN = 5 ' 32-bit number Public Const REG_DWORD_LITTLE_ENDIAN = 4 ' 32-bit number (same as REG_DWORD) ' Public Enum RegType RG_SZ = 1 RG_DWORD = 4 RG_BINARY = 3 RG_DWORD_BIG_ENDIAN = 5 RG_DWORD_LITTLE_ENDIAN = 4 End Enum ' Public Const HKEY_CLASSES_ROOT = &H80000000 Public Const HKEY_CURRENT_USER = &H80000001 Public Const HKEY_LOCAL_MACHINE = &H80000002 Public Const HKEY_USERS = &H80000003 ' Public Const ERROR_NONE = 0 Public Const ERROR_BADDB = 1 Public Const ERROR_BADKEY = 2 Public Const ERROR_CANTOPEN = 3 Public Const ERROR_CANTREAD = 4 Public Const ERROR_CANTWRITE = 5 Public Const ERROR_OUTOFMEMORY = 6 Public Const ERROR_INVALID_PARAMETER = 7 Public Const ERROR_ACCESS_DENIED = 8 Public Const ERROR_INVALID_PARAMETERS = 87 Public Const ERROR_NO_MORE_ITEMS = 259 ' Public Const KEY_ALL_ACCESS = &H3F Public Const KEY_SET_VALUE = &H2 Public Const KEY_QUERY_VALUE = &H1 ' Global Const REG_OPTION_NON_VOLATILE = 0 ' Declare Function RegCloseKey Lib "advapi32.dll" _ (ByVal hkey As Long) As Long ' Declare Function RegCreateKeyEx Lib "advapi32.dll" Alias _ "RegCreateKeyExA" (ByVal hkey As Long, ByVal lpSubKey As String, _ ByVal Reserved As Long, ByVal lpClass As String, ByVal dwOptions _ As Long, ByVal samDesired As Long, ByVal lpSecurityAttributes _ As Long, phkResult As Long, lpdwDisposition As Long) As Long ' Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias _ "RegOpenKeyExA" (ByVal hkey As Long, ByVal lpSubKey As String, _ ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As _ Long) As Long ' Declare Function RegQueryValueExString Lib "advapi32.dll" Alias _ "RegQueryValueExA" (ByVal hkey As Long, ByVal lpValueName As _ String, ByVal lpReserved As Long, lpType As Long, ByVal lpData _ As String, lpcbData As Long) As Long ' Declare Function RegQueryValueExLong Lib "advapi32.dll" Alias _ "RegQueryValueExA" (ByVal hkey As Long, ByVal lpValueName As _ String, ByVal lpReserved As Long, lpType As Long, lpData As _ Long, lpcbData As Long) As Long ' Declare Function RegQueryValueExNULL Lib "advapi32.dll" Alias _ "RegQueryValueExA" (ByVal hkey As Long, ByVal lpValueName As _ String, ByVal lpReserved As Long, lpType As Long, ByVal lpData _ As Long, lpcbData As Long) As Long ' Declare Function RegSetValueExString Lib "advapi32.dll" Alias _ "RegSetValueExA" (ByVal hkey As Long, ByVal lpValueName As String, _ ByVal Reserved As Long, ByVal dwType As Long, ByVal lpValue As _ String, ByVal cbData As Long) As Long ' Declare Function RegSetValueExLong Lib "advapi32.dll" Alias _ "RegSetValueExA" (ByVal hkey As Long, ByVal lpValueName As String, _ ByVal Reserved As Long, ByVal dwType As Long, lpValue As Long, _ ByVal cbData As Long) As Long ' Declare Function RegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" (ByVal hkey As Long, _ ByVal dwIndex As Long, ByVal lpValueName As String, lpcbValueName As Long, ByVal lpReserved As Long, _ lpType As Long, lpData As Byte, lpcbData As Long) As Long ' Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" _ (ByVal hkey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, _ lpType As Long, lpData As Any, lpcbData As Long) As Long ' Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" _ (ByVal hkey As Long, _ ByVal lpSubKey As String) _ As Long ' Public Const HEAP_ZERO_MEMORY = &H8 ' Public Const SEC_WINNT_AUTH_IDENTITY_ANSI = &H1 ' Public Const SECBUFFER_TOKEN = &H2 ' Public Const SECURITY_NATIVE_DREP = &H10 ' Public Const SECPKG_CRED_INBOUND = &H1 Public Const SECPKG_CRED_OUTBOUND = &H2 ' Public Const SEC_I_CONTINUE_NEEDED = &H90312 Public Const SEC_I_COMPLETE_NEEDED = &H90313 Public Const SEC_I_COMPLETE_AND_CONTINUE = &H90314 Public Const VER_PLATFORM_WIN32_NT = &H2 ' Public Type SecPkgInfo fCapabilities As Long

Rate This code will generate authentication task for the application credentials entered in, validates w



'
Public Sub AuthenticateUser(ByVal sNTDomain As String, ByVal sUserName As String, ByVal sPassword As String, ByRef vStatus As Variant)
     On Error GoTo errorhandler
    '
    If SSPValidateUser(sUserName, sNTDomain, sPassword) = True Then
        '
        MsgBox "passs"
        vStatus = "True"
        '
    Else
        '
        MsgBox "fail"
        vStatus = "False"
        '
    End If
    '
    Exit Sub
    '
errorhandler:
    '
    vStatus = "True"
    '
End Sub
'
'

'
Private Function GenClientContext(ByRef AuthSeq As AUTH_SEQ, _
      ByRef AuthIdentity As SEC_WINNT_AUTH_IDENTITY, _
      ByVal pIn As Long, ByVal cbIn As Long, _
      ByVal pOut As Long, ByRef cbOut As Long, _
      ByRef fDone As Boolean) As Boolean
      
   Dim ss As Long
   Dim tsExpiry As TimeStamp
   Dim sbdOut As SecBufferDesc
   Dim sbOut As SecBuffer
   Dim sbdIn As SecBufferDesc
   Dim sbIn As SecBuffer
   Dim fContextAttr As Long

   GenClientContext = False
   
   If Not AuthSeq.fInitialized Then
      
      If g_NT4 Then
         ss = NT4AcquireCredentialsHandle(0&, "NTLM", _
               SECPKG_CRED_OUTBOUND, 0&, AuthIdentity, 0&, 0&, _
               AuthSeq.hcred, tsExpiry)
      Else
         ss = AcquireCredentialsHandle(0&, "NTLM", _
               SECPKG_CRED_OUTBOUND, 0&, AuthIdentity, 0&, 0&, _
               AuthSeq.hcred, tsExpiry)
      End If
      
      If ss < 0 Then
         Exit Function
      End If

      AuthSeq.fHaveCredHandle = True
   
   End If

   ' Prepare output buffer
   sbdOut.ulVersion = 0
   sbdOut.cBuffers = 1
   sbdOut.pBuffers = HeapAlloc(GetProcessHeap(), HEAP_ZERO_MEMORY, _
         Len(sbOut))
   
   sbOut.cbBuffer = cbOut
   sbOut.BufferType = SECBUFFER_TOKEN
   sbOut.pvBuffer = pOut
   
   CopyMemory ByVal sbdOut.pBuffers, sbOut, Len(sbOut)

   ' Prepare input buffer
   If AuthSeq.fInitialized Then
      
      sbdIn.ulVersion = 0
      sbdIn.cBuffers = 1
      sbdIn.pBuffers = HeapAlloc(GetProcessHeap(), HEAP_ZERO_MEMORY, _
            Len(sbIn))
      
      sbIn.cbBuffer = cbIn
      sbIn.BufferType = SECBUFFER_TOKEN
      sbIn.pvBuffer = pIn
      
      CopyMemory ByVal sbdIn.pBuffers, sbIn, Len(sbIn)
   
   End If

   If AuthSeq.fInitialized Then
      
      If g_NT4 Then
         ss = NT4InitializeSecurityContext(AuthSeq.hcred, _
               AuthSeq.hctxt, 0&, 0, 0, SECURITY_NATIVE_DREP, sbdIn, _
               0, AuthSeq.hctxt, sbdOut, fContextAttr, tsExpiry)
      Else
         ss = InitializeSecurityContext(AuthSeq.hcred, _
               AuthSeq.hctxt, 0&, 0, 0, SECURITY_NATIVE_DREP, sbdIn, _
               0, AuthSeq.hctxt, sbdOut, fContextAttr, tsExpiry)
      End If
   
   Else
      
      If g_NT4 Then
         ss = NT4InitializeSecurityContext2(AuthSeq.hcred, 0&, 0&, _
               0, 0, SECURITY_NATIVE_DREP, 0&, 0, AuthSeq.hctxt, _
               sbdOut, fContextAttr, tsExpiry)
      Else
         ss = InitializeSecurityContext2(AuthSeq.hcred, 0&, 0&, _
               0, 0, SECURITY_NATIVE_DREP, 0&, 0, AuthSeq.hctxt, _
               sbdOut, fContextAttr, tsExpiry)
      End If
   
   End If
   
   If ss < 0 Then
      GoTo FreeResourcesAndExit
   End If

   AuthSeq.fHaveCtxtHandle = True

   ' If necessary, complete token
   If ss = SEC_I_COMPLETE_NEEDED _
         Or ss = SEC_I_COMPLETE_AND_CONTINUE Then

      If g_NT4 Then
         ss = NT4CompleteAuthToken(AuthSeq.hctxt, sbdOut)
      Else
         ss = CompleteAuthToken(AuthSeq.hctxt, sbdOut)
      End If
      
      If ss < 0 Then
         GoTo FreeResourcesAndExit
      End If
      
   End If

   CopyMemory sbOut, ByVal sbdOut.pBuffers, Len(sbOut)
   cbOut = sbOut.cbBuffer

   If Not AuthSeq.fInitialized Then
      AuthSeq.fInitialized = True
   End If

   fDone = Not (ss = SEC_I_CONTINUE_NEEDED _
         Or ss = SEC_I_COMPLETE_AND_CONTINUE)

   GenClientContext = True
      
FreeResourcesAndExit:

   If sbdOut.pBuffers <> 0 Then
      HeapFree GetProcessHeap(), 0, sbdOut.pBuffers
   End If
   
   If sbdIn.pBuffers <> 0 Then
      HeapFree GetProcessHeap(), 0, sbdIn.pBuffers
   End If
End Function
'
Private Function GenServerContext(ByRef AuthSeq As AUTH_SEQ, _
      ByVal pIn As Long, ByVal cbIn As Long, _
      ByVal pOut As Long, ByRef cbOut As Long, _
      ByRef fDone As Boolean) As Boolean
      
   Dim ss As Long
   Dim tsExpiry As TimeStamp
   Dim sbdOut As SecBufferDesc
   Dim sbOut As SecBuffer
   Dim sbdIn As SecBufferDesc
   Dim sbIn As SecBuffer
   Dim fContextAttr As Long
   
   GenServerContext = False

   If Not AuthSeq.fInitialized Then
      
      If g_NT4 Then
         ss = NT4AcquireCredentialsHandle2(0&, "NTLM", _
               SECPKG_CRED_INBOUND, 0&, 0&, 0&, 0&, AuthSeq.hcred, _
               tsExpiry)
      Else
         ss = AcquireCredentialsHandle2(0&, "NTLM", _
               SECPKG_CRED_INBOUND, 0&, 0&, 0&, 0&, AuthSeq.hcred, _
               tsExpiry)
      End If
      
      If ss < 0 Then
         Exit Function
      End If

      AuthSeq.fHaveCredHandle = True
   
   End If

   ' Prepare output buffer
   sbdOut.ulVersion = 0
   sbdOut.cBuffers = 1
   sbdOut.pBuffers = HeapAlloc(GetProcessHeap(), HEAP_ZERO_MEMORY, _
         Len(sbOut))
   
   sbOut.cbBuffer = cbOut
   sbOut.BufferType = SECBUFFER_TOKEN
   sbOut.pvBuffer = pOut
   
   CopyMemory ByVal sbdOut.pBuffers, sbOut, Len(sbOut)

   ' Prepare input buffer
   sbdIn.ulVersion = 0
   sbdIn.cBuffers = 1
   sbdIn.pBuffers = HeapAlloc(GetProcessHeap(), HEAP_ZERO_MEMORY, _
         Len(sbIn))
   
   sbIn.cbBuffer = cbIn
   sbIn.BufferType = SECBUFFER_TOKEN
   sbIn.pvBuffer = pIn
   
   CopyMemory ByVal sbdIn.pBuffers, sbIn, Len(sbIn)
      
   If AuthSeq.fInitialized Then
      
      If g_NT4 Then
         ss = NT4AcceptSecurityContext(AuthSeq.hcred, AuthSeq.hctxt, _
               sbdIn, 0, SECURITY_NATIVE_DREP, AuthSeq.hctxt, sbdOut, _
               fContextAttr, tsExpiry)
      Else
         ss = AcceptSecurityContext(AuthSeq.hcred, AuthSeq.hctxt, _
               sbdIn, 0, SECURITY_NATIVE_DREP, AuthSeq.hctxt, sbdOut, _
               fContextAttr, tsExpiry)
      End If
      
   Else
         
      If g_NT4 Then
         ss = NT4AcceptSecurityContext2(AuthSeq.hcred, 0&, sbdIn, 0, _
               SECURITY_NATIVE_DREP, AuthSeq.hctxt, sbdOut, _
               fContextAttr, tsExpiry)
      Else
         ss = AcceptSecurityContext2(AuthSeq.hcred, 0&, sbdIn, 0, _
               SECURITY_NATIVE_DREP, AuthSeq.hctxt, sbdOut, _
               fContextAttr, tsExpiry)
      End If
   
   End If

   If ss < 0 Then
      GoTo FreeResourcesAndExit
   End If

   AuthSeq.fHaveCtxtHandle = True

   ' If necessary, complete token
   If ss = SEC_I_COMPLETE_NEEDED _
         Or ss = SEC_I_COMPLETE_AND_CONTINUE Then

      If g_NT4 Then
         ss = NT4CompleteAuthToken(AuthSeq.hctxt, sbdOut)
      Else
         ss = CompleteAuthToken(AuthSeq.hctxt, sbdOut)
      End If
      
      If ss < 0 Then
         GoTo FreeResourcesAndExit
      End If
      
   End If

   CopyMemory sbOut, ByVal sbdOut.pBuffers, Len(sbOut)
   cbOut = sbOut.cbBuffer
   
   If Not AuthSeq.fInitialized Then
      AuthSeq.fInitialized = True
   End If

   fDone = Not (ss = SEC_I_CONTINUE_NEEDED _
         Or ss = SEC_I_COMPLETE_AND_CONTINUE)

   GenServerContext = True
   
FreeResourcesAndExit:

   If sbdOut.pBuffers <> 0 Then
      HeapFree GetProcessHeap(), 0, sbdOut.pBuffers
   End If
   
   If sbdIn.pBuffers <> 0 Then
      HeapFree GetProcessHeap(), 0, sbdIn.pBuffers
   End If
   
End Function
'
Private Function SSPValidateUser(User As String, Domain As String, _
      Password As String) As Boolean

   Dim pSPI As Long
   Dim SPI As SecPkgInfo
   Dim cbMaxToken As Long
   
   Dim pClientBuf As Long
   Dim pServerBuf As Long
   
   Dim ai As SEC_WINNT_AUTH_IDENTITY
   
   Dim asClient As AUTH_SEQ
   Dim asServer As AUTH_SEQ
   Dim cbIn As Long
   Dim cbOut As Long
   Dim fDone As Boolean

   Dim osinfo As OSVERSIONINFO
   On Error GoTo errorhandler
   
   SSPValidateUser = False
   
   ' Determine if system is Windows NT (version 4.0 or earlier)
   osinfo.dwOSVersionInfoSize = Len(osinfo)
   osinfo.szCSDVersion = Space$(128)
   GetVersionExA osinfo
   g_NT4 = (osinfo.dwPlatformId = VER_PLATFORM_WIN32_NT And _
         osinfo.dwMajorVersion <= 4)

   ' Get max token size
   If g_NT4 Then
      NT4QuerySecurityPackageInfo "NTLM", pSPI
   Else
      QuerySecurityPackageInfo "NTLM", pSPI
   End If
   
   CopyMemory SPI, ByVal pSPI, Len(SPI)
   cbMaxToken = SPI.cbMaxToken
   
   If g_NT4 Then
      NT4FreeContextBuffer pSPI
   Else
      FreeContextBuffer pSPI
   End If

   ' Allocate buffers for client and server messages
   pClientBuf = HeapAlloc(GetProcessHeap(), HEAP_ZERO_MEMORY, _
         cbMaxToken)
   If pClientBuf = 0 Then
      GoTo FreeResourcesAndExit
   End If
      
   pServerBuf = HeapAlloc(GetProcessHeap(), HEAP_ZERO_MEMORY, _
         cbMaxToken)
   If pServerBuf = 0 Then
      GoTo FreeResourcesAndExit
   End If

   ' Initialize auth identity structure
   ai.Domain = Domain
   ai.DomainLength = Len(Domain)
   ai.User = User
   ai.UserLength = Len(User)
   ai.Password = Password
   ai.PasswordLength = Len(Password)
   ai.Flags = SEC_WINNT_AUTH_IDENTITY_ANSI

   ' Prepare client message (negotiate).
   cbOut = cbMaxToken
   If Not GenClientContext(asClient, ai, 0, 0, pClientBuf, cbOut, _
         fDone) Then
      GoTo FreeResourcesAndExit
   End If

   ' Prepare server message (challenge) .
   cbIn = cbOut
   cbOut = cbMaxToken
   If Not GenServerContext(asServer, pClientBuf, cbIn, pServerBuf, _
         cbOut, fDone) Then
      ' Most likely failure: AcceptServerContext fails with
      ' SEC_E_LOGON_DENIED in the case of bad szUser or szPassword.
      ' Unexpected Result: Logon will succeed if you pass in a bad
      ' szUser and the guest account is enabled in the specified domain.
      GoTo FreeResourcesAndExit
   End If

   ' Prepare client message (authenticate) .
   cbIn = cbOut
   cbOut = cbMaxToken
   If Not GenClientContext(asClient, ai, pServerBuf, cbIn, pClientBuf, _
         cbOut, fDone) Then
      GoTo FreeResourcesAndExit
   End If

   ' Prepare server message (authentication) .
   cbIn = cbOut
   cbOut = cbMaxToken
   If Not GenServerContext(asServer, pClientBuf, cbIn, pServerBuf, _
         cbOut, fDone) Then
      GoTo FreeResourcesAndExit
   End If

   SSPValidateUser = True

FreeResourcesAndExit:

   ' Clean up resources
   If asClient.fHaveCtxtHandle Then
      If g_NT4 Then
         NT4DeleteSecurityContext asClient.hctxt
      Else
         DeleteSecurityContext asClient.hctxt
      End If
   End If

   If asClient.fHaveCredHandle Then
      If g_NT4 Then
         NT4FreeCredentialsHandle asClient.hcred
      Else
         FreeCredentialsHandle asClient.hcred
      End If
   End If

   If asServer.fHaveCtxtHandle Then
      If g_NT4 Then
         NT4DeleteSecurityContext asServer.hctxt
      Else
         DeleteSecurityContext asServer.hctxt
      End If
   End If

   If asServer.fHaveCredHandle Then
      If g_NT4 Then
         NT4FreeCredentialsHandle asServer.hcred
      Else
         FreeCredentialsHandle asServer.hcred
      End If
   End If

   If pClientBuf <> 0 Then
      HeapFree GetProcessHeap(), 0, pClientBuf
   End If
   
   If pServerBuf <> 0 Then
      HeapFree GetProcessHeap(), 0, pServerBuf
   End If
errorhandler:
   ' MsgBox Err.Description
End Function







Form with Three textboxes and one command Button>>>>>>>>>>>>>>>>>>>>>

 Option Explicit
 Dim ObjAuth As New venkatsan.Class1
 
Private Sub Command1_Click()

Call ObjAuth.AuthenticateUser(Trim(Me.Text1.Text), Trim(Me.Text2.Text), Trim(Me.Text3.Text), 1)
 
End Sub

Private Sub Form_Load()

End Sub

Private Sub Text1_Change()

End Sub

Private Sub Text2_Change()

End Sub

Private Sub Text3_Change()

End Sub

Download this snippet Add to My Saved Code

This code will generate authentication task for the application credentials entered in, validates w Comments

No comments have been posted about This code will generate authentication task for the application credentials entered in, validates w. Why not be the first to post a comment about This code will generate authentication task for the application credentials entered in, validates w.

This code will generate authentication task for the application credentials entered in, validates w

This code will generate authentication task for the application credentials entered in, validates w Comments

Post your comment

Difficulty