VB实现SHELL扩展之接口参数获取失败探析

前几天有位网友问我用 VB 实现 SHELL 扩展的问题，这个问题比较有意思，虽然 VB 较少使用了，但是用 VB 开发 COM 组件还是比较方便的（前几天用 EVC 开发 COM 组件，相比起来，用 VB 还是比较幸福的），所以便进行了深入的研究。

Shell 扩展有多种，而我们目前所关注的就是实现 “IShellExecuteHookW ” 接口的扩展，这个接口功能很强劲，只要是 window 加载相应程序，必须要过这一关，这样你就可以在程序执行之前预先获知要运行的进程名称，并且你可以决定该程序是否执行（瑞星杀毒软件就实现了这样一个组件，在程序运行之前，进行截获并杀毒）。

网上有位朋友用 C# 实现了该功能，链接如下： http://blog.csdn.net/startsoft/archive/2002/12/30/13417.aspx ，写的很详细，不过我没有用 C# 做一遍，是否有效不好说。

从内容上看实现该功能应该比较容易，然而上帝是公平的，用 VB 虽然编写 COM 组件比较容易，但却在实现过程中，为 VB 设下一个又一个难关，下面我一一道来！

1、 接口函数为过程，不是函数，不能返回值

这是 VB 默认生成的接口函数，如果强制修改为 Function ，则编译无法通过。

Public Sub IShellExecuteHookW_Execute(pei As olelib.SHELLEXECUTEINFO)

End Sub

而恰恰是，实现该功能必须要返回值，实际发现，该过程虽然没有返回值，但是对调用者来说，返回的是 S_OK ，这样，所有的程序都无法启动，因为只有返回值为 S_FALSE 时，才允许可执行文件运行。

不过，如果过程中显示路径信息的话，是可以正确显示的（也就是说可以截获程序运行信息）。

2、 另辟蹊径，用黑客技术实现函数返回

查了 n 多资料，发现有如下实现方法：

‘------- 类中的代码 ------------

Implements IShellExecuteHookW

Private m_pOldIShellExecuteHookW As Long

Private Sub Class_Initialize()

    Dim pShellExecuteHookW As IShellExecuteHookW

    Set pShellExecuteHookW = Me

    ' 把“ IShellExecuteHookW_Execute ”接口函数替换为“ Execute ”

    m_pOldIShellExecuteHookW = SwapVtableEntry(ObjPtr(pShellExecuteHookW), 4, AddressOf Execute)

End Sub

Public Sub IShellExecuteHookW_Execute(pei As olelib.SHELLEXECUTEINFO)

    ' 空接口，实际并不执行，因为已转入 Execute 中执行

End Sub

‘--------- 模块中的代码 ---------------

Public Function Execute(pei As olelib.SHELLEXECUTEINFO) As HRESULTS

   ‘ 新接口，如果接口被调用，则执行该函数体内的代码

End Sub

Public Function SwapVtableEntry(pObj As Long, EntryNumber As Integer, ByVal lpfn As Long) As Long

    Dim lOldAddr As Long

    Dim lpVtableHead As Long

    Dim lpfnAddr As Long

    Dim lOldProtect As Long

    CopyMemory lpVtableHead, ByVal pObj, 4

    lpfnAddr = lpVtableHead + (EntryNumber - 1) * 4

    CopyMemory lOldAddr, ByVal lpfnAddr, 4

    Call VirtualProtect(lpfnAddr, 4, PAGE_EXECUTE_READWRITE, lOldProtect)

    CopyMemory ByVal lpfnAddr, lpfn, 4

    Call VirtualProtect(lpfnAddr, 4, lOldProtect, lOldProtect)

    SwapVtableEntry = lOldAddr

End Function

从以上代码可以看出，在 COM 组件被初始化时，把原接口函数的地址换成新接口地址，使我们自定义的接口函数取代原函数。

注意上面的代码，在模块中接口“ Execute ”已经是函数形式，可以返回值了

至于 SwapVtableEntry 函数第二个参数为什么是 4 ，我也不清楚，我看过其他相关例程，什么数字的都有，不过一般都是 4 ，我实际测试过，如果不是 4 ，有种情况是原类中的接口和模块中的“ Execute ”会先后执行的（有的甚至会执行几次）。

这个时候，编译加载，你发现是可以通过不同的返回值，来决定刚打开的程序是否运行的，不过命运之神偏偏又捉弄我们， Execute 函数的参数值有问题，无法正确的显示程序信息。

3 、柳暗花明

刚开始我以为是 SwapVtableEntry 第二个参数在搞怪，从 0 测试到 11 ，都不行，反而把 Windows 搞死好几次。

后来把 pei As olelib.SHELLEXECUTEINFO 参数定义为 lPei as long 型，通过内存拷贝，进行类型赋值也不行。

实际发现 pei. cbSize 参数为结构体的大小，固定为 60 ，所以我把该参数的前后 64 个字节全看了个遍，也没有发现有 60 的，实在没有办法了，我又仔细看了看用 C# 实现的代码：

public class ExtenShell : IShellExecuteHook
      {
           private int S_OK=0;
           private int S_FALSE=1;
           public int Execute(SHELLEXECUTEINFO sei)
           {
               try
               {
                   MessageBox.Show(null, "[ Verb ]: " + sei.lpVerb + "/n[ File ]: " + sei.lpFile + "/n[ Parameters ]:" + sei.lpParameters + "/n[ Directory ]:" + sei.lpDirectory , "ShellExtensionHook",MessageBoxButtons.OK, MessageBoxIcon.Information);

               }
               catch(Exception e)
               {
                   Console.Error.WriteLine("Unknown exception : " + e.ToString());
               }

               return S_FALSE;
               // 如果返回值为 S_OK 则 SHELL 将停止对 Shell 对象的以后的所有动作。
            }
       }

用 C# 实现很简单，直接实现 public int Execute(SHELLEXECUTEINFO sei) 接口就可以了，看着看着，突然，灵光一现，接口 Execute 为类中的函数，而在 VB 中新的接口函数放在模块中，普通函数和类中函数是有区别的，那就是类中的函数的第一个参数为隐含参数，也就是 this 指针，一般指针的长度为 4 个字节，在 VB 中也就是 long 型，好，重新把 VB 模块中函数声明如下：

Public Function Execute(this As Long, pei As olelib.SHELLEXECUTEINFO) As HRESULTS

End Function

注意，新添加了 this As Long 参数，好，编译测试， OK ，成功！！！

完整代码如下：

1、类中代码：

' *************************************************************************
' **模 块 名：CShellHook
' **说    明：YFsoft 版权所有2007 - 2008(C)
' **创 建 人：叶帆
' **日    期：2007-08-23 13:20:11
' **修 改 人：
' **日    期：
' **描    述：叶帆工作室 http://blog.csdn.net/yefanqiu
' **版    本：V1.0.0
' *************************************************************************
Option  Explicit
Implements IShellExecuteHookW
Private  m_pOldIShellExecuteHookW  As  Long

' *************************************************************************
' **函 数 名：Class_Initialize
' **输    入：无
' **输    出：无
' **功能描述：类初始化
' **全局变量：
' **调用模块：
' **作    者：叶帆
' **日    期：2007-08-23 13:20:09
' **修 改 人：
' **日    期：
' **版    本：V1.0.0
' *************************************************************************
Private  Sub  Class_Initialize()
     Dim  pShellExecuteHookW  As  IShellExecuteHookW
     Set  pShellExecuteHookW  =  Me
     ' 把“IShellExecuteHookW_Execute”接口函数替换为“Execute”
    m_pOldIShellExecuteHookW  =  SwapVtableEntry(ObjPtr(pShellExecuteHookW),  4 , AddressOf  Execute )
End Sub

' *************************************************************************
' **函 数 名：IShellExecuteHookW_Execute
' **输    入：pei(olelib.SHELLEXECUTEINFO) -
' **输    出：无
' **功能描述：接口函数（为空）
' **全局变量：
' **调用模块：
' **作    者：叶帆
' **日    期：2007-08-23 13:20:24
' **修 改 人：
' **日    期：
' **版    本：V1.0.0
' *************************************************************************
Public  Sub  IShellExecuteHookW_Execute(pei  As  olelib.SHELLEXECUTEINFO)
     ' 已转入Execute 中执行
End Sub

' *************************************************************************
' **函 数 名：Class_Terminate
' **输    入：无
' **输    出：无
' **功能描述：类销毁
' **全局变量：
' **调用模块：
' **作    者：叶帆
' **日    期：2007-08-23 13:20:19
' **修 改 人：
' **日    期：
' **版    本：V1.0.0
' *************************************************************************
Private  Sub  Class_Terminate()
    Dim  pShellExecuteHookW  As  IShellExecuteHookW
    Set  pShellExecuteHookW  =  Me
   m_pOldIShellExecuteHookW  =  SwapVtableEntry(ObjPtr(pShellExecuteHookW),  4 , m_pOldIShellExecuteHookW)
End Sub

2、模块中的代码

' *************************************************************************
' **模 块 名：ShellHook
' **说    明：YFsoft 版权所有2007 - 2008(C)
' **创 建 人：叶帆
' **日    期：2007-08-23 13:23:52
' **修 改 人：
' **日    期：
' **描    述：叶帆工作室 http://blog.csdn.net/yefanqiu
' **版    本：V1.0.0
' *************************************************************************
Option  Explicit
Public  Const  E_NOTIMPL  =  & H80004001
Public  Const  PAGE_EXECUTE_READWRITE  =  & H40 &
Public  Const  S_FALSE  =  1
Public  Const  S_OK  =  0

Public  Declare  Sub  CopyMemory Lib  " kernel32 "  Alias  " RtlMoveMemory "  (pDest  As  Any, pSource  As  Any, ByVal ByteLen  As  Long )
Public  Declare  Function  VirtualProtect Lib  " kernel32 "  (ByVal lpAddress  As  Long , ByVal dwSize  As  Long , ByVal flNewProtect  As  Long , ByRef lpflOldProtect  As  Long )  As  Long

Private  Declare  Function  lstrlenA Lib  " kernel32 "  (ByVal lpString  As  Long )  As  Long
Private  Declare  Function  lstrlenW Lib  " kernel32 "  (ByVal lpString  As  Long )  As  Long

Private  Declare  Function  lstrcpyA Lib  " kernel32 "  (ByVal lpString1  As  Long , ByVal lpString2  As  Long )  As  Long
Private  Declare  Function  lstrcpyW Lib  " kernel32 "  (ByVal lpString1  As  Long , ByVal lpString2  As  Long )  As  Long

' *************************************************************************
' **函 数 名：Execute
' **输    入：this(Long)                   - 类的this指针
' **        ：pei(olelib.SHELLEXECUTEINFO) - 参数
' **输    出：(HRESULTS) -
' **功能描述：被替换的接口函数
' **全局变量：
' **调用模块：
' **作    者：叶帆
' **日    期：2007-08-23 13:23:56
' **修 改 人：
' **日    期：
' **版    本：V1.0.0
' *************************************************************************
Public  Function  Execute (this  As  Long , pei  As  olelib.SHELLEXECUTEINFO)  As  HRESULTS
     Dim  strInfo  As  String

    strInfo  =  strInfo  +  " cbSize "  +  str(pei.cbSize)  +  vbCrLf
    strInfo  =  strInfo  +  " fMask "  +  str(pei.fMask)  +  vbCrLf
    strInfo  =  strInfo  +  " hInstApp "  +  str(pei.hInstApp)  +  vbCrLf
    strInfo  =  strInfo  +  " hwnd "  +  str(pei.hwnd)  +  vbCrLf
    strInfo  =  strInfo  +  " lpDirectory "  +  StrFromPtr(pei.lpDirectory,  True )  +  vbCrLf
    strInfo  =  strInfo  +  " lpFile "  +  StrFromPtr(pei.lpFile,  True )  +  vbCrLf
    strInfo  =  strInfo  +  " lpParameters "  +  StrFromPtr(pei.lpParameters,  True )  +  vbCrLf
    strInfo  =  strInfo  +  " lpVerb "  +  StrFromPtr(pei.lpVerb,  True )  +  vbCrLf
    strInfo  =  strInfo  +  " nShow "  +  str(pei.nShow)  +  vbCrLf

     MsgBox  strInfo

     If  MsgBox ( " 允许' "  +  StrFromPtr(pei.lpFile,  True )  +  " '程序执行吗? " , vbQuestion  +  vbOKCancel,  " 程序运行监控 " )  =  vbOK  Then
         Execute  =  S_FALSE
     Else
         Execute  =  S_OK
     End  If
End Function

' *************************************************************************
' **函 数 名：SwapVtableEntry
' **输    入：pObj(Long)           - 类对象初始地址
' **        ：EntryNumber(Integer) - 入口函数索引
' **        ：ByVal lpfn(Long)     - 新函数
' **输    出：(Long) - 原函数地址
' **功能描述：更换接口函数
' **全局变量：
' **调用模块：
' **作    者：叶帆
' **日    期：2007-08-23 13:24:26
' **修 改 人：
' **日    期：
' **版    本：V1.0.0
' *************************************************************************
Public  Function  SwapVtableEntry(pObj  As  Long , EntryNumber  As  Integer , ByVal lpfn  As  Long )  As  Long

     Dim  lOldAddr  As  Long
     Dim  lpVtableHead  As  Long
     Dim  lpfnAddr  As  Long
     Dim  lOldProtect  As  Long

    CopyMemory lpVtableHead, ByVal pObj,  4
    lpfnAddr  =  lpVtableHead  +  (EntryNumber  -  1 )  *  4
    CopyMemory lOldAddr, ByVal lpfnAddr,  4

     Call  VirtualProtect(lpfnAddr,  4 , PAGE_EXECUTE_READWRITE, lOldProtect)
    CopyMemory ByVal lpfnAddr, lpfn,  4
     Call  VirtualProtect(lpfnAddr,  4 , lOldProtect, lOldProtect)

    SwapVtableEntry  =  lOldAddr

End Function

' *************************************************************************
' **函 数 名：StrFromPtr
' **输    入：ByVal lpString(Long)               - 字符串指针
' **        ：Optional fUnicode(Boolean = False) - 字符格式
' **输    出：(String) - 字符串
' **功能描述：转换字符串
' **全局变量：
' **调用模块：
' **作    者：叶帆
' **日    期：2007-08-23 13:24:28
' **修 改 人：
' **日    期：
' **版    本：V1.0.0
' *************************************************************************
Public  Function  StrFromPtr(ByVal lpString  As  Long , Optional fUnicode  As  Boolean  =  False )  As  String
     On  Error  Resume  Next
     If  fUnicode  Then
        StrFromPtr  =  String (lstrlenW(lpString),  Chr ( 0 ))
        lstrcpyW StrPtr(StrFromPtr), ByVal lpString
     Else
        StrFromPtr  =  String (lstrlenA(lpString),  Chr ( 0 ))
        lstrcpyA ByVal StrFromPtr, ByVal lpString
     End  If
End Function

注：要实现在程序运行截获，必须在注册表添加如下项（如下图），字符串为 COM 的 GUID ， VB 中生成的 COM 的 GUID ，你可以在注册表中搜索获取，也可以用专门的工具直接查看（我用的工具是， RegCtrls.exe ），当然也可以新建 VB 工程引用你的 COM 组件，保存后，用文本编辑器打开工程文件，查看相应 GUID 信息。

 

程序在浏览器被双击运行后，会提前弹出如下对话框（此外程序中调用的进程，也会显示该对话框），这时候该程序运不运行就你说了算了。别说和 Vista 中安全机制还真有些像，需要用户确认下才能运行：）