VERSION 5.00
Begin VB.Form GetTckts
BorderStyle = 1 'Fixed Single
Caption = "Kerberos Tickets"
ClientHeight = 3930
ClientLeft = 45
ClientTop = 330
ClientWidth = 5670
Icon = "Chap12_Extra_Retrieve_All_Kerb_Tkts_form.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 3930
ScaleWidth = 5670
StartUpPosition = 2 'CenterScreen
Begin VB.TextBox txtCopy
Height = 375
Left = 5280
TabIndex = 4
Top = 3480
Visible = 0 'False
Width = 150
End
Begin VB.CommandButton cmdCopy
Caption = "&Copy"
Height = 375
Left = 2880
TabIndex = 3
Top = 3480
Width = 1215
End
Begin VB.Frame Frame1
Height = 3375
Left = 0
TabIndex = 1
Top = 0
Width = 5655
Begin VB.ListBox lstOutput
Height = 2985
Left = 120
TabIndex = 2
Top = 240
Width = 5415
End
End
Begin VB.CommandButton cmdQuery
Caption = "&Query"
Default = -1 'True
Height = 375
Left = 1560
TabIndex = 0
Top = 3480
Width = 1215
End
End
Attribute VB_Name = "GetTckts"
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 Sub cmdQuery_Click()
lstOutput.Clear
Call QueryTkts
End Sub
Private Function QueryTkts()
Dim sRetFlags(40) As String
Dim lRet As Long
Dim lPtr As Long
Dim i As Long
Dim j As Long
Dim x As Integer
Dim lRetPtr As Long
Dim lRetBuf As Long
Dim hPolicy As Long
Dim lAuthPack As Long
Dim lPStatus As Long
Dim lngBuffer As Long
Dim lSecMode As Long
Dim lLuid As LUID
Dim SecurityData As SECURITY_LOGON_SESSION_DATA
Dim tQueryTGT As KERB_QUERY_TKT_CACHE_REQUEST
Dim tRetTGT As KERB_QUERY_TKT_CACHE_RESPONSE
Dim lSessions As Long
Dim lLsaPtr As Long
Dim y As Long
Dim lSecPtr As Long
Call AdjustToken("SeTcbPrivilege")
'Dim lAuthProc As LSA_STRING
'Call InitLsaStringA(lAuthProc, _
' "KerbTkt32")
'lRet = LsaRegisterLogonProcess(lAuthProc, _
' hPolicy, _
' lSecMode)
'If lRet <> 0 Then
' lstOutput.AddItem _
' "Unable to register a logon process, Error: " _
' & LsaNtStatusToWinError(lRet)
'Else
' lstOutput.AddItem _
' "Successfully registered the logon process, Error: " _
' & LsaNtStatusToWinError(lRet)
'End If
lRet = LsaConnectUntrusted(hPolicy)
If lRet <> 0 Then
lstOutput.AddItem _
"Unable to initiate an untrusted LSA connection, Error: " _
& LsaNtStatusToWinError(lRet)
Else
lstOutput.AddItem _
"Successfully initiated an untrusted LSA connection"
End If
Dim tLsaAuthPackage As LSA_STRING
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
lRet = LsaEnumerateLogonSessions(lSessions, lLsaPtr)
If lRet <> 0 Then
lstOutput.AddItem _
"Unable to enumerate connections, Error: " _
& LsaNtStatusToWinError(lRet)
Else
lstOutput.AddItem _
"Successfully enumerated connections, there are " _
& lSessions & " recorded logons"
For y = 1 To lSessions
lRet = LsaGetLogonSessionData(lLsaPtr, lSecPtr)
If lRet <> 0 Then
lstOutput.AddItem _
"Unable to retrieve the logon session data, Error: " _
& LsaNtStatusToWinError(lRet)
Else
lstOutput.AddItem _
"Successfully retrieved the logon session data"
MoveMemory SecurityData, ByVal lSecPtr, Len(SecurityData)
With SecurityData
MoveMemory lLuid, .LogonId, Len(lLuid)
lstOutput.AddItem " "
lstOutput.AddItem "Logon Name: " & vbTab & GetLsaString(.UserName)
lstOutput.AddItem "Logon Sid: " & vbTab & GetSid(.Sid)
lstOutput.AddItem "Logon Domain: " & vbTab & GetLsaString(.LogonDomain)
lstOutput.AddItem "Authentication: " & vbTab & GetLsaString(.AuthenticationPackage)
lstOutput.AddItem "TS Session ID: " & vbTab & .SessionId
lstOutput.AddItem "Logon Name: " & vbTab & GetLogonType(.LogonType)
lstOutput.AddItem "Logon Time: " & vbTab & GetTime(.LogonTime)
With tQueryTGT
.messageType = KerbQueryTicketCacheMessage
.LogonId = lLuid
End With
lRet = LsaCallAuthenticationPackage(hPolicy, _
lAuthPack, _
tQueryTGT, _
LenB(tQueryTGT) + 4, _
lRetPtr, _
lRetBuf, _
lPStatus)
If lRet <> 0 Then
lstOutput.AddItem _
"Unable to query the Kerberos ticket cache, Error: " _
& LsaNtStatusToWinError(lRet)
lstOutput.AddItem "Raw Return: " & lPStatus
lstOutput.AddItem "Status Return: " _
& LsaNtStatusToWinError(lPStatus)
Else
If LsaNtStatusToWinError(lPStatus) = 0 Then
lstOutput.AddItem _
"Successfully queried the Kerberos ticket cache (LSA Status: " _
& LsaNtStatusToWinError(lPStatus) & ")"
lstOutput.AddItem " "
MoveMemory tRetTGT, ByVal lRetPtr, lRetBuf
With tRetTGT
lstOutput.AddItem "Number of tickets returned: " & .CountOfTkts
lstOutput.AddItem " "
If .CountOfTkts > 0 Then
For i = 0 To .CountOfTkts - 1
With .Tickets(i)
lstOutput.AddItem "Ticket " & i + 1
lstOutput.AddItem " - Server Name: " & vbTab & GetLsaString(.ServerName)
lstOutput.AddItem " - Realm Name: " & vbTab & GetLsaString(.RealmName)
lstOutput.AddItem " - Start Time: " & vbTab & GetTime(.StartTime)
lstOutput.AddItem " - End Time: " & vbTab & GetTime(.EndTime)
lstOutput.AddItem " - Renew Time: " & vbTab & GetTime(.RenewTime)
lstOutput.AddItem " - Encryption: " & vbTab & GetCrypto(.EncryptType)
Call GetTktFlags(.TicketFlags, x, sRetFlags)
lstOutput.AddItem " - Flags: " & vbTab & x
For j = 0 To x - 1
lstOutput.AddItem vbTab & vbTab & sRetFlags(j)
Next
lstOutput.AddItem " "
End With
Next i
Else
lstOutput.AddItem "There are currently no kerberos tickets in the ticket cache"
End If
End With
End If
lRet = LsaFreeReturnBuffer(lRetPtr)
lRetPtr = 0
End If
End With
lRet = LsaFreeReturnBuffer(lSecPtr)
End If
lLsaPtr = lLsaPtr + Len(lLuid)
Next y
End If
lRet = LsaFreeReturnBuffer(lLsaPtr)
lRet = LsaDeregisterLogonProcess(hPolicy)
If lRet <> 0 Then
lstOutput.AddItem _
"Unable to close the untrusted LSA connection, Error: " _
& LsaNtStatusToWinError(lRet)
Else
lstOutput.AddItem _
"Successfully closed the untrusted LSA connection"
End If
End Function
Private Function AdjustToken(sPrivilege As String)
Dim lRet As Long
Dim hdlPHandle As Long
Dim hdlTHandle As Long
Dim tmpLuid As LUID
Dim tkp As TOKEN_PRIVILEGES
Dim tkpNew As TOKEN_PRIVILEGES
Dim lBufferLen As Long
hdlPHandle = GetCurrentProcess()
lRet = OpenProcessToken(hdlPHandle, _
(TOKEN_ADJUST_PRIVILEGES Or TOKEN_QUERY), _
hdlTHandle)
If lRet <> 0 Then
lstOutput.AddItem _
"Successfully opened the process token"
lRet = LookupPrivilegeValue("", _
sPrivilege, _
tmpLuid)
If lRet <> 0 Then
lstOutput.AddItem _
"Successfully found " & sPrivilege
With tkp
.PrivilegeCount = 1
.TheLuid = tmpLuid
.Attributes = SE_PRIVILEGE_ENABLED
End With
lRet = AdjustTokenPrivileges(hdlTHandle, _
False, _
tkp, _
Len(tkpNew), _
tkpNew, _
lBufferLen)
If lRet <> 0 Then
lstOutput.AddItem _
"Successfully added " & sPrivilege & _
" to the token's privileges"
Else
lstOutput.AddItem _
"Unable to add " & sPrivilege & _
" to the token's privileges, Error: " & lRet
End If
Else
lstOutput.AddItem _
"Unable to lookup the " & sPrivilege & _
" privilege, Error: " & lRet
End If
Else
lstOutput.AddItem _
"Unable to open the process token, Error: " & lRet
Debug.Print Err.LastDllError
End If
End Function
Private Sub cmdCopy_Click()
Dim i As Long
Clipboard.Clear
txtCopy.Text = ""
For i = 0 To lstOutput.ListCount - 1
txtCopy.Text = txtCopy.Text & lstOutput.List(i) & vbCrLf
Next i
Clipboard.SetText txtCopy
End Sub
Private Sub Form_Load()
End Sub
|
