NT域驗證功能VB典型程式碼

Attribute VB_Name = "modSecurity"
Option Explicit

Private Const HEAP_ZERO_MEMORY = &H8
Private Const SEC_WINNT_AUTH_IDENTITY_ANSI = &H1
Private Const SECBUFFER_TOKEN = &H2
Private Const SECURITY_NATIVE_DREP = &H10
Private Const SECPKG_CRED_INBOUND = &H1
Private Const SECPKG_CRED_OUTBOUND = &H2
Private Const SEC_I_CONTINUE_NEEDED = &H90312
Private Const SEC_I_COMPLETE_NEEDED = &H90313
Private Const SEC_I_COMPLETE_AND_CONTINUE = &H90314
Private Const VER_PLATFORM_WIN32_NT = &H2

Type SecPkgInfo
   fCapabilities As Long
   wVersion As Integer
   wRPCID As Integer
   cbMaxToken As Long
   Name As Long
   Comment As Long
End Type

Type SecHandle
    dwLower As Long
    dwUpper As Long
End Type

Type AUTH_SEQ
   fInitialized As Boolean
   fHaveCredHandle As Boolean
   fHaveCtxtHandle As Boolean
   hcred As SecHandle
   hctxt As SecHandle
End Type

Type SEC_WINNT_AUTH_IDENTITY
   User As String
   UserLength As Long
   Domain As String
   DomainLength As Long
   Password As String
   PasswordLength As Long
   Flags As Long
End Type

Type TimeStamp
   LowPart As Long
   HighPart As Long
End Type

Type SecBuffer
   cbBuffer As Long
   BufferType As Long
   pvBuffer As Long
End Type

Type SecBufferDesc
   ulVersion As Long
   cBuffers As Long
   pBuffers As Long
End Type

Public Type OSVERSIONINFO
   dwOSVersionInfoSize As Long
   dwMajorVersion As Long
   dwMinorVersion As Long
   dwBuildNumber As Long
   dwPlatformId As Long
   szCSDVersion As String * 128
End Type

'// For Windows NT4 or higher
Private Declare Function NT4QuerySecurityPackageInfo Lib "Security" Alias "QuerySecurityPackageInfoA" (ByVal PackageName As String, ByRef pPackageInfo As Long) As Long
Private Declare Function NT4FreeContextBuffer Lib "Security" Alias "FreeContextBuffer" (ByVal pvContextBuffer As Long) As Long
Private Declare Function NT4InitializeSecurityContext Lib "Security" Alias "InitializeSecurityContextA" (ByRef phCredential As SecHandle, ByRef phContext As SecHandle, ByVal pszTargetName As Long, ByVal fContextReq As Long, ByVal Reserved1 As Long, ByVal TargetDataRep As Long, ByRef pInput As SecBufferDesc, ByVal Reserved2 As Long, ByRef phNewContext As SecHandle, ByRef pOutput As SecBufferDesc, ByRef pfContextAttr As Long, ByRef ptsExpiry As TimeStamp) As Long
Private Declare Function NT4InitializeSecurityContext2 Lib "Security" Alias "InitializeSecurityContextA" (ByRef phCredential As SecHandle, ByVal phContext As Long, ByVal pszTargetName As Long, ByVal fContextReq As Long, ByVal Reserved1 As Long, ByVal TargetDataRep As Long, ByVal pInput As Long, ByVal Reserved2 As Long, ByRef phNewContext As SecHandle, ByRef pOutput As SecBufferDesc, ByRef pfContextAttr As Long, ByRef ptsExpiry As TimeStamp) As Long
Private Declare Function NT4AcquireCredentialsHandle Lib "Security" Alias "AcquireCredentialsHandleA" (ByVal pszPrincipal As Long, ByVal pszPackage As String, ByVal fCredentialUse As Long, ByVal pvLogonId As Long, ByRef pAuthData As SEC_WINNT_AUTH_IDENTITY, ByVal pGetKeyFn As Long, ByVal pvGetKeyArgument As Long, ByRef phCredential As SecHandle, ByRef ptsExpiry As TimeStamp) As Long
Private Declare Function NT4AcquireCredentialsHandle2 Lib "Security" Alias "AcquireCredentialsHandleA" (ByVal pszPrincipal As Long, ByVal pszPackage As String, ByVal fCredentialUse As Long, ByVal pvLogonId As Long, ByVal pAuthData As Long, ByVal pGetKeyFn As Long, ByVal pvGetKeyArgument As Long, ByRef phCredential As SecHandle, ByRef ptsExpiry As TimeStamp) As Long
Private Declare Function NT4AcceptSecurityContext Lib "Security" Alias "AcceptSecurityContext" (ByRef phCredential As SecHandle, ByRef phContext As SecHandle, ByRef pInput As SecBufferDesc, ByVal fContextReq As Long, ByVal TargetDataRep As Long, ByRef phNewContext As SecHandle, ByRef pOutput As SecBufferDesc, ByRef pfContextAttr As Long, ByRef ptsExpiry As TimeStamp) As Long
Private Declare Function NT4AcceptSecurityContext2 Lib "Security" Alias "AcceptSecurityContext" (ByRef phCredential As SecHandle, ByVal phContext As Long, ByRef pInput As SecBufferDesc, ByVal fContextReq As Long, ByVal TargetDataRep As Long, ByRef phNewContext As SecHandle, ByRef pOutput As SecBufferDesc, ByRef pfContextAttr As Long, ByRef ptsExpiry As TimeStamp) As Long
Private Declare Function NT4CompleteAuthToken Lib "Security" Alias "CompleteAuthToken" (ByRef phContext As SecHandle, ByRef pToken As SecBufferDesc) As Long
Private Declare Function NT4DeleteSecurityContext Lib "Security" Alias "DeleteSecurityContext" (ByRef phContext As SecHandle) As Long
Private Declare Function NT4FreeCredentialsHandle Lib "Security" Alias "FreeCredentialsHandle" (ByRef phContext As SecHandle) As Long

'// For Windows 98
Private Declare Function QuerySecurityPackageInfo Lib "secur32" Alias "QuerySecurityPackageInfoA" (ByVal PackageName As String, ByRef pPackageInfo As Long) As Long
Private Declare Function FreeContextBuffer Lib "secur32" (ByVal pvContextBuffer As Long) As Long
Private Declare Function InitializeSecurityContext Lib "secur32" Alias "InitializeSecurityContextA" (ByRef phCredential As SecHandle, ByRef phContext As SecHandle, ByVal pszTargetName As Long, ByVal fContextReq As Long, ByVal Reserved1 As Long, ByVal TargetDataRep As Long, ByRef pInput As SecBufferDesc, ByVal Reserved2 As Long, ByRef phNewContext As SecHandle, ByRef pOutput As SecBufferDesc, ByRef pfContextAttr As Long, ByRef ptsExpiry As TimeStamp) As Long
Private Declare Function InitializeSecurityContext2 Lib "secur32" Alias "InitializeSecurityContextA" (ByRef phCredential As SecHandle, ByVal phContext As Long, ByVal pszTargetName As Long, ByVal fContextReq As Long, ByVal Reserved1 As Long, ByVal TargetDataRep As Long, ByVal pInput As Long, ByVal Reserved2 As Long, ByRef phNewContext As SecHandle, ByRef pOutput As SecBufferDesc, ByRef pfContextAttr As Long, ByRef ptsExpiry As TimeStamp) As Long
Private Declare Function AcquireCredentialsHandle Lib "secur32" Alias "AcquireCredentialsHandleA" (ByVal pszPrincipal As Long, ByVal pszPackage As String, ByVal fCredentialUse As Long, ByVal pvLogonId As Long, ByRef pAuthData As SEC_WINNT_AUTH_IDENTITY, ByVal pGetKeyFn As Long, ByVal pvGetKeyArgument As Long, ByRef phCredential As SecHandle, ByRef ptsExpiry As TimeStamp) As Long
Private Declare Function AcquireCredentialsHandle2 Lib "secur32" Alias "AcquireCredentialsHandleA" (ByVal pszPrincipal As Long, ByVal pszPackage As String, ByVal fCredentialUse As Long, ByVal pvLogonId As Long, ByVal pAuthData As Long, ByVal pGetKeyFn As Long, ByVal pvGetKeyArgument As Long, ByRef phCredential As SecHandle, ByRef ptsExpiry As TimeStamp) As Long
Private Declare Function AcceptSecurityContext Lib "secur32" (ByRef phCredential As SecHandle, ByRef phContext As SecHandle, ByRef pInput As SecBufferDesc, ByVal fContextReq As Long, ByVal TargetDataRep As Long, ByRef phNewContext As SecHandle, ByRef pOutput As SecBufferDesc, ByRef pfContextAttr As Long, ByRef ptsExpiry As TimeStamp) As Long
Private Declare Function AcceptSecurityContext2 Lib "secur32" Alias "AcceptSecurityContext" (ByRef phCredential As SecHandle, ByVal phContext As Long, ByRef pInput As SecBufferDesc, ByVal fContextReq As Long, ByVal TargetDataRep As Long, ByRef phNewContext As SecHandle, ByRef pOutput As SecBufferDesc, ByRef pfContextAttr As Long, ByRef ptsExpiry As TimeStamp) As Long
Private Declare Function CompleteAuthToken Lib "secur32" (ByRef phContext As SecHandle, ByRef pToken As SecBufferDesc) As Long
Private Declare Function DeleteSecurityContext Lib "secur32" (ByRef phContext As SecHandle) As Long
Private Declare Function FreeCredentialsHandle Lib "secur32" (ByRef phContext As SecHandle) As Long

'// Common API
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GetProcessHeap Lib "kernel32" () As Long
Private Declare Function HeapAlloc Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function HeapFree Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal lpMem As Long) As Long
Private Declare Function GetVersionExA Lib "kernel32" (lpVersionInformation As OSVERSIONINFO) As Integer
     
Private m_IS_NT4_Platform. As Boolean

Public Function ValidateNTAccount(ByVal UserName As String, _
                                  ByVal Password As String, _
                                  Optional ByVal Domain 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
  
   
    ValidateNTAccount = False
  
    Domain = IIf(Domain = "", Environ("USERDOMAIN"), Domain)
    ' Determine if system is Windows NT (version 4.0 or earlier)
    osinfo.dwOSVersionInfoSize = Len(osinfo)
    osinfo.szCSDVersion = Space$(128)
    GetVersionExA osinfo
    m_IS_NT4_Platform. = (osinfo.dwPlatformId = VER_PLATFORM_WIN32_NT And osinfo.dwMajorVersion <= 4)

   ' Get max token size
    If m_IS_NT4_Platform. Then
        NT4QuerySecurityPackageInfo "NTLM", pSPI
    Else
        QuerySecurityPackageInfo "NTLM", pSPI
    End If
   
    CopyMemory SPI, ByVal pSPI, Len(SPI)
    cbMaxToken = SPI.cbMaxToken
   
    If m_IS_NT4_Platform. 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 = UserName
    ai.UserLength = Len(UserName)
    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
   
    ValidateNTAccount = True
   
FreeResourcesAndExit:
   
    ' Clean up resources
    If asClient.fHaveCtxtHandle Then
        If m_IS_NT4_Platform. Then
            NT4DeleteSecurityContext asClient.hctxt
        Else
            DeleteSecurityContext asClient.hctxt
        End If
    End If
   
    If asClient.fHaveCredHandle Then
        If m_IS_NT4_Platform. Then
            NT4FreeCredentialsHandle asClient.hcred
        Else
            FreeCredentialsHandle asClient.hcred
        End If
    End If
   
    If asServer.fHaveCtxtHandle Then
        If m_IS_NT4_Platform. Then
            NT4DeleteSecurityContext asServer.hctxt
        Else
            DeleteSecurityContext asServer.hctxt
        End If
    End If
   
    If asServer.fHaveCredHandle Then
        If m_IS_NT4_Platform. 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
End Function

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 m_IS_NT4_Platform. 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 m_IS_NT4_Platform. 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 m_IS_NT4_Platform. 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 m_IS_NT4_Platform. 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 m_IS_NT4_Platform. 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 m_IS_NT4_Platform. 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 m_IS_NT4_Platform. 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 m_IS_NT4_Platform. 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