pluginloader.cls

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

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "PlugInLoader"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private Declare Function LoadLibrary Lib "kernel32" _
Alias "LoadLibraryA" ( _
    ByVal lpszLib As String _
) As Long

Private Declare Function FreeLibrary Lib "kernel32" ( _
    ByVal hMod As Long _
) As Long

Private Declare Function GetProcAddress Lib "kernel32" ( _
    ByVal hMod As Long, _
    ByVal lpszFnc As String _
) As Long

Private Declare Function CallWindowProc Lib "user32" _
Alias "CallWindowProcA" ( _
    ByVal lpPrevWndFunc As Long, _
    ByVal hWnd As Long, _
    ByVal Msg As Long, _
    ByVal wParam As Long, _
    ByVal lParam As Long _
) As Long

Private Declare Function VirtualAlloc Lib "kernel32" ( _
    ByVal lpAddress As Long, _
    ByVal dwSize As Long, _
    ByVal flAllocType As Long, _
    ByVal flProtect As Long _
) As Long

Private Declare Function VirtualFree Lib "kernel32" ( _
    ByVal lpAddress As Long, _
    ByVal dwSize As Long, _
    ByVal dwFreeType As Long _
) As Long

Private Declare Function VirtualProtect Lib "kernel32" ( _
    ByVal lpAddress As Long, _
    ByVal dwSize As Long, _
    ByVal flNewProtect As Long, _
    lpflOldProtect As Long _
) As Long

Private Declare Sub CpyMem Lib "kernel32" _
Alias "RtlMoveMemory" ( _
    pDst As Any, _
    pSrc As Any, _
    ByVal cBytes As Long _
)

Private Declare Function FindFirstFile Lib "kernel32" _
Alias "FindFirstFileA" ( _
    ByVal lpFileName As String, _
    lpFindFileData As WIN32_FIND_DATA _
) As Long

Private Declare Function FindNextFile Lib "kernel32" _
Alias "FindNextFileA" ( _
    ByVal hFindFile As Long, _
    lpFindFileData As WIN32_FIND_DATA _
) As Long

Private Declare Function GetFileAttributes Lib "kernel32" _
Alias "GetFileAttributesA" ( _
    ByVal lpFileName As String _
) As Long

Private Declare Function FindClose Lib "kernel32" ( _
    ByVal hFindFile As Long _
) As Long

Private Const MAX_PATH                  As Long = 260
Private Const MAXDWORD                  As Long = &HFFFF
Private Const FILE_ATTRIBUTE_ARCHIVE    As Long = &H20
Private Const FILE_ATTRIBUTE_DIRECTORY  As Long = &H10
Private Const FILE_ATTRIBUTE_HIDDEN     As Long = &H2
Private Const FILE_ATTRIBUTE_NORMAL     As Long = &H80
Private Const FILE_ATTRIBUTE_READONLY   As Long = &H1
Private Const FILE_ATTRIBUTE_SYSTEM     As Long = &H4
Private Const FILE_ATTRIBUTE_TEMPORARY  As Long = &H100
Private Const INVALID_HANDLE            As Long = -1

Private Enum VirtualFreeTypes
    MEM_DECOMMIT = &H4000
    MEM_RELEASE = &H8000
End Enum

Private Enum VirtualAllocTypes
    MEM_COMMIT = &H1000
    MEM_RESERVE = &H2000
    MEM_RESET = &H8000
    MEM_LARGE_PAGES = &H20000000
    MEM_PHYSICAL = &H100000
    MEM_WRITE_WATCH = &H200000
End Enum

Private Enum VirtualAllocPageFlags
    PAGE_EXECUTE = &H10
    PAGE_EXECUTE_READ = &H20
    PAGE_EXECUTE_READWRITE = &H40
    PAGE_EXECUTE_WRITECOPY = &H80
    PAGE_NOACCESS = &H1
    PAGE_READONLY = &H2
    PAGE_READWRITE = &H4
    PAGE_WRITECOPY = &H8
    PAGE_GUARD = &H100
    PAGE_NOCACHE = &H200
    PAGE_WRITECOMBINE = &H400
End Enum

Private Type allocated_memory
    address     As Long
    bytes       As Long
End Type

Private Type FILETIME
    dwLowDateTime               As Long
    dwHighDateTime              As Long
End Type

Private Type WIN32_FIND_DATA
    dwFileAttributes            As Long
    FTCreationTime              As FILETIME
    FTLastAccessTime            As FILETIME
    FTLastWriteTime             As FILETIME
    nFileSizeHigh               As Long
    nFileSizeLow                As Long
    dwReserved0                 As Long
    dwReserved1                 As Long
    cFileName                   As String * MAX_PATH
    cAlternate                  As String * 14
End Type

Private Type PluginClass
    localfile                   As String
    guid                        As UUID
End Type

Private clsInterface            As olelib.IDispatch
Private uidInterface            As UUID
Private strPlugPath             As String
Private strFilter               As String
Private blnRecursive            As Boolean

Private udtPlugins()            As PluginClass
Private lngPluginCnt            As Long

Public Property Get PluginCount() As Long
    PluginCount = lngPluginCnt
End Property

Public Property Get PluginLocation(ByVal index As Long) As String
    If PluginCount = 0 Then Err.Raise 9
    PluginLocation = udtPlugins(index).localfile
End Property

Public Function CreatePlugin(ByVal index As Long) As olelib.IUnknown
    Dim iunkPlugin  As olelib.IUnknown

    If PluginCount = 0 Then Err.Raise 9

    CoCreateInstance udtPlugins(index).guid, _
                     Nothing, _
                     CLSCTX_INPROC_SERVER, _
                     uidInterface, _
                     iunkPlugin

    Set CreatePlugin = iunkPlugin
End Function

Public Function FindPlugins() As Long
    Dim strExts() As String

    lngPluginCnt = 0
    strExts = Split(strFilter, ";")

    FindFilesAPI strPlugPath, strExts, True

    FindPlugins = lngPluginCnt
End Function

Public Property Get filter() As String
    filter = strFilter
End Property

Public Property Let filter(ByVal strF As String)
    strFilter = strF
End Property

Public Property Get Interface() As olelib.IDispatch
    Set Interface = clsInterface
End Property

Public Property Set Interface(clsIdisp As olelib.IDispatch)
    Set clsInterface = clsIdisp
    uidInterface = IIDfromDispatch(clsInterface)
End Property

Public Property Get PluginPath() As String
    PluginPath = strPlugPath
End Property

Public Property Let PluginPath(ByVal strPath As String)
    strPlugPath = strPath
End Property

Public Property Get RecursiveSearch() As Boolean
    RecursiveSearch = blnRecursive
End Property

Public Property Let RecursiveSearch(ByVal blnVal As Boolean)
    blnRecursive = blnVal
End Property

Private Function DirExists(ByVal DirName As String) As Boolean
    On Error Resume Next
    DirExists = GetAttr(DirName) And vbDirectory
End Function

Private Function AddSlash(ByVal strText As String) As String
    AddSlash = IIf(Right$(strText, 1) = "\", strText, strText & "\")
End Function

Private Sub Class_Initialize()
    If DirExists(AddSlash(App.path) & "plugins") Then
        strPlugPath = AddSlash(App.path) & "plugins"
    Else
        strPlugPath = AddSlash(App.path)
    End If

    blnRecursive = True

    strFilter = "*.dll;*.ocx"
End Sub

Private Sub FindFilesAPI( _
    ByVal path As String, _
    filter() As String, _
    ByVal recursive As Boolean _
)

    Dim hSearch     As Long
    Dim udtFindData As WIN32_FIND_DATA
    Dim lngRet      As Long
    Dim i           As Long
    Dim uid         As UUID
    Dim strPFile    As String

    If Not Right$(path, 1) = "\" Then path = path & "\"

    hSearch = FindFirstFile(path & "*.*", udtFindData)
    If hSearch = INVALID_HANDLE Then Exit Sub

    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