前幾天有位網友問我用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中安全機制還真有些像，需要使用者确認下才能運作：）
