VERSION 5.00
Begin VB.Form frmKerb 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "PurgeTKTCache"
   ClientHeight    =   2250
   ClientLeft      =   45
   ClientTop       =   345
   ClientWidth     =   4695
   Icon            =   "Chap12_Listing01_Purge_Kerb_Tkts_form.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   2250
   ScaleWidth      =   4695
   StartUpPosition =   2  'CenterScreen
   Begin VB.Frame Frame1 
      Height          =   2240
      Left            =   0
      TabIndex        =   0
      Top             =   0
      Width           =   4695
      Begin VB.ListBox lstOutput 
         Height          =   1425
         Left            =   120
         TabIndex        =   2
         Top             =   240
         Width           =   4455
      End
      Begin VB.CommandButton cmdPurge 
         Caption         =   "&Purge!"
         Default         =   -1  'True
         Height          =   375
         Left            =   1560
         TabIndex        =   1
         Top             =   1760
         Width           =   1575
      End
   End
End
Attribute VB_Name = "frmKerb"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
     
    Option Explicit
    Option Base 0
    
    ' From the book "Managing Enterprise Active Directory Services"
    ' ISBN: 0-672-32125-4
    
    Private Const STATUS_SUCCESS = 0&
    Private Const MICROSOFT_KERBEROS_NAME_A = "Kerberos"
    
    Private Enum KERB_PROTOCOL_MESSAGE_TYPE
        KerbDebugRequestMessage = 0&
        KerbQueryTicketCacheMessage = 1&
        KerbChangeMachinePasswordMessage = 2&
        KerbVerifyPacMessage = 3&
        KerbRetrieveTicketMessage = 4&
        KerbUpdateAddressesMessage = 5&
        KerbPurgeTicketCacheMessage = 6&
        KerbChangePasswordMessage = 7&
        KerbRetrieveEncodedTicketMessage = 8&
        KerbDecryptDataMessage = 9&
        KerbAddBindingCacheEntryMessage = 10&
        KerbSetPasswordMessage = 11&
    End Enum
                
    Private Type LSA_STRING
        Length As Integer
        MaximumLength As Integer
        buffer As String
    End Type
    
    Private Type UNICODE_STRING
        Length As Integer
        MaximumLength As Integer
        buffer As Long
    End Type
    
    Private Type KERB_PURGE_TKT_CACHE_REQUEST
        MessageType As Long
        LogonId As Long
        ServerName As UNICODE_STRING
        RealmName As UNICODE_STRING
    End Type
    
    Private Declare Function LsaLookupAuthenticationPackage Lib "Secur32.dll" _
        (ByVal LsaHandle As Long, _
        PackageName As LSA_STRING, _
        AuthenticationPackage As Long) As Long
    
    Private Declare Function LsaCallAuthenticationPackage Lib "Secur32.dll" _
        (ByVal LsaHandle As Long, _
        ByVal AuthenticationPackage As Long, _
        ProtocolSubmitBuffer As KERB_PURGE_TKT_CACHE_REQUEST, _
        ByVal SubmitBufferLength As Long, _
        ProtocolReturnBuffer As Long, _
        ReturnBufferLength As Long, _
        ProtocolStatus As Long) As Long
    
    Private Declare Function LsaConnectUntrusted Lib "Secur32.dll" _
        (LsaHandle As Long) As Long
        
    Private Declare Function LsaDeregisterLogonProcess Lib "Secur32.dll" _
        (ByVal LsaHandle As Long) As Long
    
    Private Declare Function StrLenA Lib "Kernel32" _
        Alias "lstrlenA" _
        (ByVal lpString As String) As Long
    
    Private Declare Function strLen Lib "Kernel32" _
        Alias "lstrlenW" _
        (ByVal Ptr As Long) As Long
    
    Private Declare Function LsaNtStatusToWinError Lib "Advapi32.dll" _
        (ByVal Status As Long) As Long
        
    Private Declare Sub MoveMemory Lib "Kernel32" _
        Alias "RtlMoveMemory" _
        (pDest As Any, _
        pSource As Any, _
        ByVal dwLength As Long)
    
    Private Sub cmdPurge_Click()
    
        Call PurgeTKTs
    
    End Sub
       
    Private Sub PurgeTKTs()
    
       Dim lRet As Long
        Dim hPolicy As Long
        Dim lAuthPack As Long
        Dim lPStatus As Long
        Dim lngBuffer As Long
        Dim tLsaAuthPackage As LSA_STRING
        Dim tPurgeTGT As KERB_PURGE_TKT_CACHE_REQUEST
    
        lRet = LsaConnectUntrusted(hPolicy)
        
        If lRet <> 0 Then
            lstOutput.AddItem _
            "Unable to open an untrusted connection, Error: " _
            & LsaNtStatusToWinError(lRet)
        Else
            lstOutput.AddItem _
            "Successfully opened an untrusted connection"
        End If
        
        Call InitLsaStringA(tLsaAuthPackage, _
             MICROSOFT_KERBEROS_NAME_A)
        
        lRet = LsaLookupAuthenticationPackage(hPolicy, _
               tLsaAuthPackage, _
               lAuthPack)
        
        If lRet <> 0 Then
            lstOutput.AddItem _
            "Unable to resolve the Kerberos package, Error: " _
            & LsaNtStatusToWinError(lRet)
        Else
            lstOutput.AddItem _
            "Successfully resolved the Kerberos package"
        End If
    
        With tPurgeTGT
            .LogonId = 0&
            .MessageType = KerbPurgeTicketCacheMessage
        End With
        
        lRet = LsaCallAuthenticationPackage(hPolicy, _
               lAuthPack, _
               tPurgeTGT, _
               LenB(tPurgeTGT) * 2, _
               0&, _
               0&, _
               lPStatus)
        
        If lRet <> 0 Then
            lstOutput.AddItem _
            "Unable to purge the Kerberos ticket cache, Error: " _
            & LsaNtStatusToWinError(lRet)
                        
            lstOutput.AddItem "Raw Return: " & lPStatus
            lstOutput.AddItem "Status Return: " _
            & LsaNtStatusToWinError(lPStatus)
        Else
            lstOutput.AddItem _
            "Successfully purged the Kerberos ticket cache"
            lstOutput.AddItem "Status Return: " _
            & LsaNtStatusToWinError(lPStatus)
        End If
    
        lRet = LsaDeregisterLogonProcess(hPolicy)
        
        If lRet <> 0 Then
            lstOutput.AddItem _
            "Unable to close the untrusted connection, Error: " _
            & LsaNtStatusToWinError(lRet)
        Else
            lstOutput.AddItem _
            "Successfully closed the untrusted connection"
        End If
    
    End Sub
       
    Private Sub InitLsaStringA(LsaString As LSA_STRING, strString As String)
    
        With LsaString
            If strString = "" Then
                .Length = 0
                .MaximumLength = 0
                .buffer = ""
            Else
                .Length = StrLenA(strString)
                .MaximumLength = StrLenA(strString) + 1
                .buffer = strString
            End If
        End With
    End Sub
    
    Private Sub InitUnicodeString(LsaString As UNICODE_STRING, strString As String)
    
        With LsaString
            If strString = "" Then
                .buffer = ""
                .Length = 0
                .MaximumLength = 0
            Else
                .buffer = StrPtr(strString)
                .Length = strLen(StrPtr(strString)) * 2
                .MaximumLength = (strLen(StrPtr(strString)) + 1) * 2
            End If
        End With
    End Sub