CRegComp.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 = "ICompReg"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

' ==============================================================
' CompReg.cls - allows to register or unregister a COM component
' ==============================================================

' infinite wait
Private Const INFINITE = &HFFFF

' wait status codes
Private Const WAIT_OBJECT_0 = &H0&
Private Const WAIT_ABANDONED = &H80&
Private Const WAIT_TIMEOUT = &H102&
Private Const WAIT_FAILED = &HFFFFFFFF

' results from the reg/unreg operation
Public Enum enRegStatus
    S_OK = &H0&
    S_FALSE = &H1&
    SELFREG_E_TYPELIB = &H80040200
    SELFREG_E_CLASS = &H80040201
    E_OUTOFMEMORY = &H8007000E
    E_UNEXPECTED = &H8000FFFF
    P_NOTFOUND = &H9000F001
    P_NOTCOMP = &H9000F002
    P_CANTEXEC = &H9000F003
    P_EXECERR = &H9000F004
End Enum

' Entry point names
Private Const FN_REG = "DllRegisterServer"
Private Const FN_UNR = "DllUnregisterServer"

' APIs used throughout the code
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Declare Function CreateThread Lib "kernel32" (ByVal lpThreadAttributes As Long, ByVal dwStackSize As Long, ByVal lpStartAddress As Long, ByVal lpParameter As Long, ByVal dwCreationFlags As Long, lpThreadId As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function GetExitCodeThread Lib "kernel32" (ByVal hThread As Long, lpExitCode As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

' private workareas
Private mbRegFlag       As Boolean
Private mnStatusCode    As enRegStatus

' Register/UnRegister a COM component
Public Function RegUnreg(ByVal sCompName As String, ByVal bRegister As Boolean) As enRegStatus
    Dim hLibrary As Long, lpProcAddr As Long, hThread As Long, lThreadID As Long
    Dim lResult As Long, lTemp As Long, sFunc As String

    ' initialize return code and try to
    ' load the specified component file
    lResult = P_NOTFOUND
    hLibrary = LoadLibrary(sCompName)
    If (hLibrary <> 0) Then
        ' now let's try to find the register
        ' on unregister function entry point
        lResult = P_NOTCOMP
        If (bRegister) Then
            sFunc = FN_REG
        Else
            sFunc = FN_UNR
        End If
        lpProcAddr = GetProcAddress(hLibrary, FN_UNR)
        If (lpProcAddr <> 0) Then
            ' we got the function entry point, now since VB
            ' doesn't know what to do with a function ptr we
            ' will use the createthread function to call the
            ' component function by using its pointer
            lResult = P_CANTEXEC
            hThread = CreateThread(0&, 0&, lpProcAddr, 0&, 0&, lThreadID)
            If (hThread <> 0) Then
                ' let's wait for the thread to terminate and
                ' get its return code to check what happened
                lResult = P_EXECERR
                lTemp = WaitForSingleObject(hThread, INFINITE)
                If lTemp = WAIT_OBJECT_0 Then
                    ' should be S_OK from the reg/unreg if all ok
                    lTemp = GetExitCodeThread(hThread, lResult)
                End If
                ' done with thread, close the thread handle
                Call CloseHandle(hThread)
            End If
        End If
        ' release/unload the component
        Call FreeLibrary(hLibrary)
    End If

    ' store the reg/unreg flag and the result code
    mbRegFlag = bRegister
    mnStatusCode = lResult

    ' all done, return the result code (0=all ok)
    RegUnreg = lResult
End Function

' reg/unreg status (exit) code
Public Property Get StatusCode() As enRegStatus
    StatusCode = mnStatusCode
End Property

' reg/unreg status msg, the messages have been
' taken out from various sources (msdn etc...)
Public Property Get StatusMsg() As String
    Dim sMsg As String

    ' initialize and decode the status code to a message
    sMsg = ""
    Select Case mnStatusCode
        Case S_OK
            ' all ok
            If mbRegFlag = True Then
                sMsg = "The registry entries were created successfully."
            Else
                sMsg = "The registry entries were removed successfully."
            End If
        Case S_FALSE
            ' ok, but with some side issues
            If mbRegFlag = False Then
                sMsg = "Unregistration of this server’s known entries was successful, but other entries still exist for this server’s classes."
            End If
        Case SELFREG_E_TYPELIB
            ' problems with "tlb"
            If mbRegFlag = True Then
                sMsg = "The server was unable to complete the registration of all the type libraries used by its classes."
            Else
                sMsg = "The server was unable to remove the entries of all the type libraries used by its classes."
            End If
        Case SELFREG_E_CLASS
            ' problems with classes
            If mbRegFlag = True Then
                sMsg = "The server was unable to complete the registration of all the object classes."
            Else
                sMsg = "The server was unable to remove the entries of all the object classes."
            End If
        Case E_OUTOFMEMORY
            ' need more memory
            sMsg = "The server ran out of memory while processing the request."
        Case E_UNEXPECTED
            ' whoops this shouldn't happen
            sMsg = "An unexpected internal error occurred."
        Case P_NOTFOUND
            ' the file to (un)register wasn't found
            sMsg = "Component not found."
        Case P_NOTCOMP
            ' no reg/unreg entry point
            sMsg = "The specified file is not a component."
        Case P_CANTEXEC
            ' error calling the entry point
            sMsg = "Can't call the requested registration function."
        Case P_EXECERR
            ' the entry point call terminated abnormally
            sMsg = "The requested function terminated abnormally."
        Case Else
            ' all other error codes
            sMsg = ""
    End Select

    ' complete and return the message
    If Len(sMsg) < 1 Then
        sMsg = "Unknown return code"
    End If
    StatusMsg = "0x" & Right("00000000" & Hex(mnStatusCode), 8) & " " & sMsg
End Property