Option Explicit
Private Declare Function AdjustTokenPrivileges _
Lib "advapi32.dll" (ByVal TokenHandle As Long, _
ByVal DisableAllPriv As Long, _
ByRef NewState As TOKEN_PRIVILEGES, _
ByVal BufferLength As Long, _
ByRef PreviousState As TOKEN_PRIVILEGES, _
ByRef pReturnLength As Long) As Long
Private Declare Function GetCurrentProcess _
Lib "kernel32" () As Long
Private Declare Function GetVersionEx _
Lib "kernel32" _
Alias "GetVersionExA" (LpVersionInformation As OSVERSIONINFO) As Long
Private Declare Function LookupPrivilegeValue _
Lib "advapi32.dll" _
Alias "LookupPrivilegeValueA" (ByVal lpSystemName As Any, _
ByVal lpName As String, _
lpLuid As LUID) As Long
Private Declare Function NtSystemDebugControl _
Lib "NTDLL.DLL" (ByVal scCommand As SYSDBG_COMMAND, _
ByVal pInputBuffer As Long, _
ByVal InputBufferLength As Long, _
ByVal pOutputBuffer As Long, _
ByVal OutputBufferLength As Long, _
ByRef pReturnLength As Long) As Long
Private Declare Function OpenProcessToken _
Lib "advapi32.dll" (ByVal ProcessHandle As Long, _
ByVal DesiredAccess As Long, _
TokenHandle As Long) As Long
'=========Checking OS staff=============
Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type
Private Type MEMORY_CHUNKS
Address As Long
pData As Long
Length As Long
End Type
Private Type LUID
UsedPart As Long
IgnoredForNowHigh32BitPart As Long
End Type '
Private Type TOKEN_PRIVILEGES
PrivilegeCount As Long
TheLuid As LUID
Attributes As Long
End Type
Private Enum SYSDBG_COMMAND
'//以下5个在Windows NT各个版本上都有
SysDbgGetTraceInformation = 1
SysDbgSetInternalBreakpoint = 2
SysDbgSetSpecialCall = 3
SysDbgClearSpecialCalls = 4
SysDbgQuerySpecialCalls = 5
'// 以下是NT 5.1 新增的
SysDbgDbgBreakPointWithStatus = 6
'//获取KdVersionBlock
SysDbgSysGetVersion = 7
'//从内核空间拷贝到用户空间或者从用户空间拷贝到用户空间
'//但是不能从用户空间拷贝到内核空间
SysDbgCopyMemoryChunks_0 = 8

'//SysDbgReadVirtualMemory = 8
'//从用户空间拷贝到内核空间或者从用户空间拷贝到用户空间
'//但是不能从内核空间拷贝到用户空间
SysDbgCopyMemoryChunks_1 = 9
'//SysDbgWriteVirtualMemory = 9
'//从物理地址拷贝到用户空间 不能写到内核空间
SysDbgCopyMemoryChunks_2 = 10
'//SysDbgReadVirtualMemory = 10
'//从用户空间拷贝到物理地址 不能读取内核空间
SysDbgCopyMemoryChunks_3 = 11
'//SysDbgWriteVirtualMemory = 11
'//读写处理器相关控制块
SysDbgSysReadControlSpace = 12
SysDbgSysWriteControlSpace = 13
'//读写端口
SysDbgSysReadIoSpace = 14
SysDbgSysWriteIoSpace = 15
'//分别调用_WRMSR@12
SysDbgSysReadMsr = 16
SysDbgSysWriteMsr = 17
'//读写总线数据
SysDbgSysReadBusData = 18
SysDbgSysWriteBusData = 19
SysDbgSysCheckLowMemory = 20
'// 以下是NT 5.2 新增的
'//分别调用_KdDisableDebugger@0
SysDbgEnableDebugger = 21
SysDbgDisableDebugger = 22
'//获取和设置一些调试相关的变量
SysDbgGetAutoEnableOnEvent = 23
SysDbgSetAutoEnableOnEvent = 24
SysDbgGetPitchDebugger = 25
SysDbgSetDbgPrintBufferSize = 26
SysDbgGetIgnoreUmExceptions = 27
SysDbgSetIgnoreUmExceptions = 28
End Enum
Private Const SE_DEBUG As String = "SeDebugPrivilege"
Private Const SE_PRIVILEGE_ENABLED As Long = &H2
Private Const TOKEN_QUERY As Long = &H8
Private Const TOKEN_ADJUST_PRIVILEGES As Long = &H20
Dim VerInfo As OSVERSIONINFO
Public Function GetData(ByVal addr As Long) As Long
Dim mc As MEMORY_CHUNKS
Dim retv&, retl&
With mc
.Address = addr
.Length = Len(addr)
.pData = VarPtr(retv)
End With
Dim st As Long
st = NtSystemDebugControl(SysDbgCopyMemoryChunks_0, VarPtr(mc), Len(mc), 0&, 0&, VarPtr(retl))
GetData = retv
If (Not NT_SUCCESS(st)) Then GetData = 0
End Function
Public Function InitMemoryControl() As Boolean
InitMemoryControl = True
InitMemoryControl = InitMemoryControl And IsSupportedOS
InitMemoryControl = InitMemoryControl And EnablePrivilege(SE_DEBUG)
End Function
Public Function IsSupportedOS() As Boolean
On Error GoTo IsSupportedOS_Err_Hdl
IsSupportedOS = False
VerInfo.dwOSVersionInfoSize = Len(VerInfo)
If (GetVersionEx(VerInfo)) <> 0 Then
If VerInfo.dwPlatformId = 2 Then
If VerInfo.dwMajorVersion = 5 Then
If (VerInfo.dwMinorVersion > 0) Then
IsSupportedOS = True
End If
End If
End If
End If
IsSupportedOS_Err_Hdl:
End Function
Public Function SetData(ByVal addr As Long, _
ByVal data As Long) As Boolean
Dim mc As MEMORY_CHUNKS
Dim retv&, retl&
With mc
.Address = addr
.Length = Len(addr)
.pData = VarPtr(data)
color="#0000FF">End With
Dim st As Long
st = NtSystemDebugControl(SysDbgCopyMemoryChunks_1, VarPtr(mc), Len(mc), 0&, 0&, VarPtr(retl))
SetData = NT_SUCCESS(st)
End Function
Private Function EnablePrivilege(ByVal seName As String) As Boolean
On Error Resume Next
Dim p_lngRtn As Long
Dim p_lngToken As Long
Dim p_lngBufferLen As Long
Dim p_typLUID As LUID
Dim p_typTokenPriv As TOKEN_PRIVILEGES
Dim p_typPrevTokenPriv As TOKEN_PRIVILEGES
p_lngRtn = OpenProcessToken(GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES Or _
TOKEN_QUERY, p_lngToken)
If p_lngRtn = 0 Then
EnablePrivilege = False
Exit Function
End If
If Err.LastDllError <> 0 Then
EnablePrivilege = False
Exit Function
End If
p_lngRtn = LookupPrivilegeValue(0&, seName, p_typLUID)
If p_lngRtn = 0 Then
EnablePrivilege = False
Exit Function
End If
p_typTokenPriv.PrivilegeCount = 1
p_typTokenPriv.Attributes = SE_PRIVILEGE_ENABLED
p_typTokenPriv.TheLuid = p_typLUID
EnablePrivilege = (AdjustTokenPrivileges(p_lngToken, False, p_typTokenPriv, Len( _
p_typPrevTokenPriv), p_typPrevTokenPriv, p_lngBufferLen) <> 0)
End Function
Private Function NT_SUCCESS(ByVal nsStatus As Long) As Boolean
NT_SUCCESS = (nsStatus >= 0)
End Function