如何在不生成Shell到VB6中的regsvr32的情况下注册/注销DLL / OCX

Question

我需要创建一个VB6程序来注册/注销给定文件夹中的所有dll / ocx文件（该文件夹最多可以包含200个此类文件）。

这不是一项一次性的任务，需要在不同客户位置的数百台计算机上运行，​​因此需要一种有效执行此任务的工具。 在这里无法使用regsvr32.exe，因此无需对该方法进行任何讨论。

http://support.microsoft.com/kb/173091上有一个示例，但这需要在Declare语句中对dll / ocx的名称进行硬编码，这在我们的方案中几乎没有用。

我知道逻辑过程遵循以下原则：

1. 扫描目录并枚举其中的所有dll / ocx文件

2. 对于每个这样的文件：

   2.1调用LoadLibrary加载它（如果调用失败退出）

   2.2调用GetProcAddress在当前文件中找到函数“ DllRegisterServer”或“ DllUnRegisterServer”（取决于请求的操作：注册还是注销）

   2.3如果找不到该功能，则跳过文件； 其他：

   2.4调用函数注册/注销文件

   2.5调用FreeLibrary卸载文件

问题在步骤2.4中。 在基于C / C ++的Windows API代码中，我可以简单地使用从GetProcAddress（）返回的函数指针来调用函数，但是在VB6中，这似乎要复杂得多。

到目前为止，我已经看到了两个建议：1）使用CallWindowProc（）2）使用CreateThread（）

对于1），请参见： http : //www.pcreview.co.uk/forums/using-callwindowproc-call-non-wndproc-functions-t2912253.html有人甚至创建了一个可用于调用的通用包装器通过将参数推入堆栈来获取任何API函数指针，请参见此处http://www.Planet-Source-Code.com/vb/scripts/ShowCode.asp?txtCodeId=32873&lngWId=1

对于2），我丢失了发布原始代码的网站，但是它像这样：

hMod      = LoadLibrary(sFilePath)
lProcAddr = GetProcAddress(hMod, "DllRegisterServer")
hThread   = CreateThread(ByVal 0&, 0&, ByVal lProcAddr, ByVal 0&, 0&, tid)
lWaitRes  = WaitForSingleObject(hThread, 30000)  'give it 30 seconds to finish

我非常了解这些Windows API，但不是VB6的内部运作专家以及为什么它不能仅调用简单的函数指针。 我的问题是：

1. 我怀疑这两种方法中的哪一种更好（即更有效，更可靠），我怀疑1）如果VB代码只有Sub Main（），即不能在没有GUI的cmdline代码中运行，则将无法工作。 但是对于我来说，创建一个仅用于调用函数的新线程似乎有些过大。
2. 有没有更简单的方法？ （不，在这里不接受炮击到regsvr32.exe）

谢谢。

Answer 1

正确安装ActiveX库不仅仅需要调用它们的自注册入口点。 而是创建一个适当的安装程序。 如果其中任何一个是共享库，则有可能对目标系统上的其他应用程序造成很大的损害。

或者，为这些库创建隔离的程序集，因此根本不需要注册。

您建议的路径听起来像是DLL Hell的秘方。 职业编码人员的这种黑客攻击只是VB（和C ++）信誉如此差的一个原因。

认真聘请安装专业人员。

Answer 2

您可以将其视为有价值的东西，并且相信我，我理解某人做出的决定，认为所有事情都可以在2次单击中完成。 几年前，我为自己编写了一个实用程序。 它还使用复选框有选择地禁止显示任何结果消息。 此代码使用文本框输入特定的文件名或通配符，创建文件名数组（具有完整路径），并尝试注册所有匹配的文件。 您没有看到任何其他程序正在启动。

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Dim blnCancel As Boolean

Const WM_CLOSE = &H10
Const WM_QUIT = &H12
Const WM_SYSCOMMAND = &H112
Const WM_COMMAND = &H111
Const SC_CLOSE = &HF060


Private Sub btnRegister_Click()
    Dim aryDLL() As String
    Dim i As Integer
    Dim fName As String
    Dim fPath As String
    Dim Rtn As Double
    Dim hwnd As Long
    Dim strCommand As String

    On Error GoTo errbtnRegister

    Command2.Enabled = False
    Command1.Caption = "Cancel"

    Me.MousePointer = vbHourglass

    If CurDir$ <> ExtractPath(Text1.Text) Then
        If Left$(CurDir$, 1) <> Left$(ExtractPath(Text1.Text), 1) Then
            ChDrive (Left$(Text1.Text, 2))
        End If
        ChDir (ExtractPath(Text1.Text))
    End If

    fName = Dir$(ExtractFile(Text1.Text))

    If fName = "" Then
        MsgBox "There were no files found matching " & Text1.Text & ".", vbOKOnly + vbInformation, "Nothing To Do"
        CleanUp
        Exit Sub
    Else
        While fName > ""
            ReDim Preserve aryDLL(i)
            aryDLL(i) = fName
            fName = Dir$()
            i = i + 1

            If blnCancel = True Then
                CleanUp
                Exit Sub
            End If

        Wend

        i = 0   'reinitialize i
        Label1.Visible = True

        For i = LBound(aryDLL) To UBound(aryDLL)

            If blnCancel = True Then
                CleanUp
                Exit Sub
            End If

            Label1.Caption = "Current File   " & CStr(i + 1) & " of " & CStr(UBound(aryDLL) + 1)
            lblCurrFile.Caption = aryDLL(i)
            lblCurrFile.Refresh
            DoEvents
            If InStr(CurDir$, " ") Then
               strCommand = """" & CurDir$ & "\" & aryDLL(i) & """"
            Else
               strCommand = CurDir$ & "\" & aryDLL(i)
            End If
            If chkSilent.Value = vbChecked Then
                Rtn = Shell("regsvr32.exe /s " & strCommand, vbNormalNoFocus)
            Else
                Rtn = Shell("regsvr32.exe " & strCommand, vbNormalNoFocus)
            End If

            If UBound(aryDLL) > 0 Then
                If CInt(i / UBound(aryDLL)) * 100 <= 100 Then
                    ProgressBar1.Value = CInt(i / UBound(aryDLL) * 100)
                Else
                    ProgressBar1.Value = 100
                End If
            Else
                ProgressBar1.Value = 100
            End If

            Delay 5
            hwnd = FindWindow(vbNullString, "RegSvr32")
            'close the regsvr32 message window
            Rtn = SendMessage(hwnd, WM_COMMAND, SC_CLOSE, vbNull)

        Next i

    End If

    CleanUp
    Exit Sub

errbtnRegister:
    If Err.Number = 9 Then  'no files found
        MsgBox "There were no files found matching " & Text1.Text & ".", vbOKOnly + vbInformation, "Nothing To Do"
    Else
        MsgBox "There was an error registering " & Text1.Text & " files." & vbLf & vbLf _
            & "Error = " & CStr(Err.Number) & ", " & Err.Description, vbOKOnly + vbInformation, "Program Error"
    End If

    Exit Sub

End Sub

Answer 3

如果必须在VB6中全部实现它，则可以使用委托者轻量级对象。

首先，您将需要一个具有自定义接口且具有long retval的自定义接口的typelib，因为VB6“接口”类的方法始终返回HRESULT ，这会干扰委托者的retval（负retval会引发错误）。

[
  uuid(a4d82779-ed39-437c-9f42-89048603a82b),
  version(1.0),
  helpstring("Delegator Typelib 1.0")
]
library DelegatorLib
{
    importlib("stdole2.tlb");

    [
      odl,
      uuid(fdb250f4-4175-444f-8a53-72ecfcaf8fd0),
      version(1.0),
    ]    
    interface IDelegator : IUnknown {
        long Call0([in] long pfn);
        long Call1([in] long pfn, [in] long A1);
        long Call2([in] long pfn, [in] long A1, [in] long A2);
        long Call3([in] long pfn, [in] long A1, [in] long A2, [in] long A3);
        long Call4([in] long pfn, [in] long A1, [in] long A2, [in] long A3, [in] long A4);
        long Call5([in] long pfn, [in] long A1, [in] long A2, [in] long A3, [in] long A4, [in] long A5);
        long Call6([in] long pfn, [in] long A1, [in] long A2, [in] long A3, [in] long A4, [in] long A5, [in] long A6);
        long Call7([in] long pfn, [in] long A1, [in] long A2, [in] long A3, [in] long A4, [in] long A5, [in] long A6, [in] long A7);
    };
}

然后，在标准模块中，您可以实现轻量级对象-一个非常小的实现就足够了。

Option Explicit

'--- for VirtualQuery'
Private Const PAGE_EXECUTE_READWRITE            As Long = &H40

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function VirtualProtect Lib "kernel32" (lpAddress As Any, ByVal dwSize As Long, ByVal flNewProtect As Long, lpflOldProtect As Long) As Long

Private m_aThunk(0 To 1)        As Long
Private m_aVtbl(0 To 9)         As Long

Public Type DelegatorData
    pVTable             As Long
End Type

Public Function InitDelegator(This As DelegatorData) As IDelegator
    Dim dwDummy         As Long
    Dim lIdx            As Long

    If m_aVtbl(0) = 0 Then
        m_aThunk(0) = &H51585859
        m_aThunk(1) = &H9090E0FF
        Call VirtualProtect(m_aThunk(0), 8, PAGE_EXECUTE_READWRITE, dwDummy)
        m_aVtbl(0) = pvAddr(AddressOf pvQueryInterface)
        m_aVtbl(1) = pvAddr(AddressOf pvAddRefRelease)
        m_aVtbl(2) = pvAddr(AddressOf pvAddRefRelease)
        For lIdx = 3 To 9
            m_aVtbl(lIdx) = VarPtr(m_aThunk(0))
        Next
    End If
    This.pVTable = VarPtr(m_aVtbl(0))
    Call CopyMemory(InitDelegator, VarPtr(This), 4)
End Function

Private Function pvAddr(ByVal lPtr As Long) As Long
    pvAddr = lPtr
End Function

Private Function pvQueryInterface(This As DelegatorData, ByVal riid As Long, pvObj As Long) As Long
    pvObj = VarPtr(This)
End Function

Private Function pvAddRefRelease(This As DelegatorData) As Long
    '--- do nothing
End Function

笨拙的代码确实是有趣的部分，这是程序集

00401030 59                   pop         ecx
00401031 58                   pop         eax
00401032 58                   pop         eax
00401033 51                   push        ecx
00401034 FF E0                jmp         eax

因此，从根本上说，它将返回地址保存在ecx ，摆脱了第一个参数（ this ），然后弹出并跳转到第二个参数（ pfn ），而其余参数则保持不变。 然后，委托函数的Epilog负责堆栈（委托函数必须在stdcall调用约定中）。

您可以像这样初始化一个（单个）委托人

Private m_uDelegator        As DelegatorData
Private m_pDelegator        As IDelegator

Set m_pDelegator = InitDelegator(m_uDelegator)

然后像这样直接使用m_pDelegator var

ret = m_pDelegator.Call0(AddressOf Test)

无需清理。

其余的CallN函数使用相同的thunk，但是您可以切掉它们，因为您不需要这些目的。