pluginloader.cls

一个完整的插件框架结构演示代码

                        udtPlugins(lngPluginCnt).localfile = strPFile
                        udtPlugins(lngPluginCnt).guid = uid
                        lngPluginCnt = lngPluginCnt + 1
                    End If
                    Exit For
                End If
            Next
        End If
    End If

    lngRet = 1

    Do
        lngRet = FindNextFile(hSearch, udtFindData)
        If lngRet = 0 Then Exit Do

        If Left$(udtFindData.cFileName, 1) <> "." Then
            If (udtFindData.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) Then
                If recursive Then
                    FindFilesAPI path & Trim$(StripNulls(udtFindData.cFileName)), filter, recursive
                End If
            Else
                For i = LBound(filter) To UBound(filter)
                    If StripNulls(udtFindData.cFileName) Like filter(i) Then
                        strPFile = path & Trim$(StripNulls(udtFindData.cFileName))

                        If IsValidPlugin(strPFile, uid) Then
                            ReDim Preserve udtPlugins(lngPluginCnt) As PluginClass
                            udtPlugins(lngPluginCnt).localfile = strPFile
                            udtPlugins(lngPluginCnt).guid = uid
                            lngPluginCnt = lngPluginCnt + 1
                        End If
                        Exit For
                    End If
                Next
            End If
        End If
    Loop

    FindClose hSearch
End Sub

Private Function StripNulls( _
    OriginalStr As String _
) As String

    If InStr(OriginalStr, Chr(0)) > 0 Then
        OriginalStr = Left(OriginalStr, InStr(OriginalStr, Chr(0)) - 1)
    End If

    StripNulls = Trim$(OriginalStr)
End Function

Private Function IsValidPlugin( _
    ByVal strFile As String, _
    classguid As UUID _
) As Boolean

    Dim clsTypeLib  As ITypeLib
    Dim clsTypeInfo As ITypeInfo
    Dim clsImplInfo As ITypeInfo
    Dim pTypeAttr   As Long
    Dim udtTypeAttr As TYPEATTR
    Dim udtImplAttr As TYPEATTR
    Dim i           As Long
    Dim j           As Long
    Dim hRefType    As Long

    ' first register the component, then try to load its type library
    If Not RegisterServer(strFile, True) Then Exit Function

    Set clsTypeLib = LoadTypeLibEx(strFile, REGKIND_REGISTER)
    If clsTypeLib Is Nothing Then Exit Function

    ' get all the CoClasses in the server and search for
    ' the interface the plugins have to implement
    For i = 0 To clsTypeLib.GetTypeInfoCount - 1
        If clsTypeLib.GetTypeInfoType(i) = TKIND_COCLASS Then
            Set clsTypeInfo = clsTypeLib.GetTypeInfo(i)

            pTypeAttr = clsTypeInfo.GetTypeAttr
            If pTypeAttr <> 0 Then
                CpyMem udtTypeAttr, ByVal pTypeAttr, Len(udtTypeAttr)
                clsTypeInfo.ReleaseTypeAttr pTypeAttr

                ' Implements of the current class
                For j = 0 To udtTypeAttr.cImplTypes - 1
                    hRefType = clsTypeInfo.GetRefTypeOfImplType(j)
                    Set clsImplInfo = clsTypeInfo.GetRefTypeInfo(hRefType)

                    If Not clsImplInfo Is Nothing Then
                        pTypeAttr = clsImplInfo.GetTypeAttr
                        If pTypeAttr <> 0 Then
                            CpyMem udtImplAttr, ByVal pTypeAttr, Len(udtImplAttr)
                            clsImplInfo.ReleaseTypeAttr pTypeAttr

                            If CompareGUIDs(udtImplAttr.iid, uidInterface) Then
                                ' a class implements the specified interface,
                                ' we found a plugin!
                                classguid = udtTypeAttr.iid
                                IsValidPlugin = True
                                Exit Function
                            End If

                        End If
                    End If

                Next

            End If
        End If
    Next
End Function

Private Function CompareGUIDs( _
    guid1 As UUID, _
    guid2 As UUID _
) As Boolean

    Dim i   As Long

    If guid1.Data1 = guid2.Data1 Then
        If guid1.Data2 = guid2.Data2 Then
            If guid1.Data3 = guid2.Data3 Then
                For i = 0 To 7
                    If guid1.Data4(i) <> guid2.Data4(i) Then
                        Exit Function
                    End If
                Next

                CompareGUIDs = True
            End If
        End If
    End If
End Function

Private Function IIDfromDispatch( _
    clsDisp As olelib.IDispatch _
) As UUID

    Dim pTypeAttr   As Long
    Dim udtTypeAttr As TYPEATTR

    pTypeAttr = clsDisp.GetTypeInfo.GetTypeAttr

    If pTypeAttr = 0 Then Exit Function
    CpyMem udtTypeAttr, ByVal pTypeAttr, Len(udtTypeAttr)

    IIDfromDispatch = udtTypeAttr.iid

    clsDisp.GetTypeInfo.ReleaseTypeAttr pTypeAttr
End Function

Private Function RegisterServer( _
    ByVal strFile As String, _
    ByVal register As Boolean _
) As Boolean

    Dim hLib    As Long
    Dim fpReg   As Long

    hLib = LoadLibrary(strFile)
    If hLib = 0 Then Exit Function

    If register Then
        fpReg = GetProcAddress(hLib, "DllRegisterServer")
    Else
        fpReg = GetProcAddress(hLib, "DllUnregisterServer")
    End If

    If fpReg = 0 Then Exit Function

    CallStd fpReg

    RegisterServer = True
End Function

Private Function AllocMemory( _
    ByVal bytes As Long, _
    Optional ByVal lpAddr As Long = 0, _
    Optional ByVal PageFlags As VirtualAllocPageFlags = PAGE_READWRITE _
) As allocated_memory

    With AllocMemory
        .address = VirtualAlloc(lpAddr, bytes, MEM_COMMIT, PageFlags)
        .bytes = bytes
    End With
End Function

Private Function FreeMemory( _
    udtMem As allocated_memory _
) As Boolean

    VirtualFree udtMem.address, udtMem.bytes, MEM_DECOMMIT

    udtMem.address = 0
    udtMem.bytes = 0
End Function

Private Function CallStd( _
    ByVal fnc As Long, _
    ParamArray Params() As Variant _
) As Long

    Dim udtMem              As allocated_memory
    Dim pASM                As Long
    Dim i                   As Integer

    udtMem = AllocMemory(&HEC00&, , PAGE_EXECUTE_READWRITE)
    If udtMem.address = 0 Then Exit Function
    pASM = udtMem.address

    AddByte pASM, &H58                  ' POP EAX
    AddByte pASM, &H59                  ' POP ECX
    AddByte pASM, &H59                  ' POP ECX
    AddByte pASM, &H59                  ' POP ECX
    AddByte pASM, &H59                  ' POP ECX
    AddByte pASM, &H50                  ' PUSH EAX

    If UBound(Params) = 0 Then
        If IsArray(Params(0)) Then
            For i = UBound(Params(0)) To 0 Step -1
                AddPush pASM, CLng(Params(0)(i))    ' PUSH dword
            Next
        Else
            For i = UBound(Params) To 0 Step -1
                AddPush pASM, CLng(Params(i))       ' PUSH dword
            Next
        End If
    Else
        For i = UBound(Params) To 0 Step -1
            AddPush pASM, CLng(Params(i))           ' PUSH dword
        Next
    End If

    AddCall pASM, fnc                   ' CALL rel addr
    AddByte pASM, &HC3                  ' RET

    CallStd = CallWindowProc(udtMem.address, _
                             0, 0, 0, 0)

    FreeMemory udtMem
End Function

Private Sub AddPush( _
    pASM As Long, _
    lng As Long _
)

    AddByte pASM, &H68
    AddLong pASM, lng
End Sub

Private Sub AddCall( _
    pASM As Long, _
    addr As Long _
)

    AddByte pASM, &HE8
    AddLong pASM, addr - pASM - 4
End Sub

Private Sub AddLong( _
    pASM As Long, _
    lng As Long _
)

    CpyMem ByVal pASM, lng, 4
    pASM = pASM + 4
End Sub

Private Sub AddByte( _
    pASM As Long, _
    Bt As Byte _
)

    CpyMem ByVal pASM, Bt, 1
    pASM = pASM + 1
End Sub