解决打开VB6反复提示windows正在设置Office

鉴于office安装问题太烦人，于是打算彻底干掉它。除了前面讲的用Open锁定msi.dll的方法外，还有更好的方法。
Open虽然简单，但会禁止msi文件，所以又找到一种新的不妨碍其它程序的办法。

方法是hook当前进程的ZwOpenFile(NtOpenFile)，发现是msi.dll时跳过即可。

代码如下：

'窗体
Option Explicit

Private Sub Form_Load()
        Me.Move (Screen.Width - Me.Width) \ 2, (Screen.Height - Me.Height) \ 2
        Me.Show
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
        Unhook
End Sub

'模块
Option Explicit

Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function ZwOpenFile Lib "NTDLL.DLL" (ByRef Filehandle As Long, _
                                                ByVal DesiredAccess As Long, _
                                                ByRef ObjectAttributes As OBJECT_ATTRIBUTES, _
                                                ByRef IoStatusBlock As IO_STATUS_BLOCK, _
                                                ByVal ShareAccess As Long, _
                                                ByVal OpenOptions As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSrc As Any, ByVal ByteLen As Long)

Private Const STATUS_OBJECT_NAME_NOT_FOUND = &HC0000034

Private Type IO_STATUS_BLOCK
        Status                          As Long
        Information                     As Long
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 MyHook As cls_HookApi   '自定义hook

Sub Main()
        App.TaskVisible = False
        Set MyHook = New cls_HookApi
        MyHook.HookApi "ntdll.dll", "ZwOpenFile", GetFunAddr(AddressOf ZwOpenFileCallback), GetCurrentProcess
        Load frm_Main
End Sub

'NtOpenFile回调
Public Function ZwOpenFileCallback(Filehandle As Long, ByVal DesiredAccess As Long, ObjectAttributes As OBJECT_ATTRIBUTES, IoStatusBlock As IO_STATUS_BLOCK, ByVal ShareAccess As Long, ByVal OpenOptions As Long) As Long
        Dim lRetVal As Long
        MyHook.HookStatus False
        'Debug.Print ObjectAttrToName(ObjectAttributes)
        If LCase(ObjectAttrToName(ObjectAttributes)) Like LCase("*msi.dll") Then
                lRetVal = STATUS_OBJECT_NAME_NOT_FOUND '返回值改为对象不存在
        Else
                lRetVal = ZwOpenFile(Filehandle, DesiredAccess, ObjectAttributes, IoStatusBlock, ShareAccess, OpenOptions)
        End If
        MyHook.HookStatus True
        ZwOpenFileCallback = lRetVal
End Function

'得到文件名称
Private Function ObjectAttrToName(ObjectAttr As OBJECT_ATTRIBUTES) As String
        Dim bytCode() As Byte
        Dim dwName As Long
        Dim dwLength As Integer
        CopyMemory dwLength, ByVal ObjectAttr.ObjectName, 2
        If dwLength > 0 Then
                CopyMemory dwName, ByVal ObjectAttr.ObjectName + 4, 4
                ReDim bytCode(dwLength - 1)
                CopyMemory bytCode(0), ByVal dwName, dwLength
                ObjectAttrToName = StrConv(StrConv(bytCode, vbUnicode), vbFromUnicode)
                ObjectAttrToName = Replace(ObjectAttrToName, "\??\", "")
        End If
        Erase bytCode
End Function

Public Function GetFunAddr(lngFunAddr As Long) As Long
        GetFunAddr = lngFunAddr
End Function

Sub Unhook()
        Set MyHook = Nothing
End Sub

'类
Option Explicit

Private Declare Function WriteProcessMemory Lib "kernel32" (ByVal hProcess As Long, lpBaseAddress As Any, lpBuffer As Any, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal length As Long)

Private Const PROCESS_ALL_ACCESS As Long = &H1F0FFF

Private mbytOldCode(5) As Byte
Private mbytNewCode(5) As Byte
Private mlngFunAddr As Long

Private mhProcess As Long

Public Function HookApi(ByVal strDllName As String, ByVal strFunName As String, ByVal lngFunAddr As Long, ByVal hProcess As Long) As Boolean
        Dim hModule As Long, dwJmpAddr As Long
        mhProcess = GetCurrentProcess
        hModule = LoadLibrary(strDllName)
        If hModule = 0 Then HookApi = False: Exit Function
        mlngFunAddr = GetProcAddress(hModule, strFunName)
        If mlngFunAddr = 0 Then HookApi = False: Exit Function
        CopyMemory mbytOldCode(0), ByVal mlngFunAddr, 6
        mbytNewCode(0) = &HE9
        dwJmpAddr = lngFunAddr - mlngFunAddr - 5
        CopyMemory mbytNewCode(1), dwJmpAddr, 4
        HookStatus True
        HookApi = True
End Function

Public Function HookStatus(ByVal blnIsHook As Boolean) As Boolean
        If blnIsHook Then
                If WriteProcessMemory(mhProcess, ByVal mlngFunAddr, mbytNewCode(0), 5, 0) <> 0 Then HookStatus = True '拦截
        Else
                If WriteProcessMemory(mhProcess, ByVal mlngFunAddr, mbytOldCode(0), 5, 0) <> 0 Then HookStatus = False '恢复
        End If
End Function

Private Sub Class_Terminate()
        HookStatus False
End Sub

'****完成****