typelib.bas

利用windows的API来注册自动OCX

Attribute VB_Name = "mTypeLib"
Option Explicit
'
' Brad Martinez, http://www.mvps.org
'
Declare Function LoadTypeLib Lib "oleaut32" _
                              (ByVal szFileName As String, _
                              lplptlib As Any) As Long   ' lplptlib As Long

Declare Function RegisterTypeLib Lib "oleaut32" _
                              (ByVal ptlib As Any, _
                              ByVal szFullPath As String, _
                              ByVal szHelpDir As String) As Long

Declare Function UnRegisterTypeLib Lib "oleaut32" _
                              (GUID As GUID, _
                              ByVal wVerMajor As Long, _
                              ByVal wVerMinor As Long, _
                              ByVal lcid As Long, _
                              ByVal SYSKIND As SYSKIND) As Long

Public Const S_OK = 0   ' indicates successful HRESULT

' "Error accessing the OLE registry." Typically means that
' the GUID passed to UnRegisterTypeLib wasn't found in
' the registry (i.e the typelib was already unregistered)
Public Const TYPE_E_REGISTRYACCESS = &H8002801C

Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)
Declare Function LocalAlloc Lib "kernel32" (ByVal uFlags As Long, ByVal uBytes As Long) As Long
Declare Function LocalSize Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function LocalFree Lib "kernel32" (ByVal hMem As Long) As Long

' LocalAlloc uFlags values
Public Const LMEM_FIXED = &H0
Public Const LMEM_ZEROINIT = &H40
Public Const LPTR = (LMEM_FIXED Or LMEM_ZEROINIT)

Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" _
                            (ByVal dwFlags As FM_dwFlags, _
                            lpSource As Any, _
                            ByVal dwMessageId As Long, _
                            ByVal dwLanguageId As Long, _
                            ByVal lpBuffer As String, _
                            ByVal nSize As Long, _
                            Arguments As Any) As Long
  
Public Enum FM_dwFlags
'  FORMAT_MESSAGE_ALLOCATE_BUFFER = &H100
'  FORMAT_MESSAGE_ARGUMENT_ARRAY = &H2000
'  FORMAT_MESSAGE_FROM_HMODULE = &H800
'  FORMAT_MESSAGE_FROM_STRING = &H400
  FORMAT_MESSAGE_FROM_SYSTEM = &H1000
  FORMAT_MESSAGE_IGNORE_INSERTS = &H200
  FORMAT_MESSAGE_MAX_WIDTH_MASK = &HFF
End Enum

' FormatMessage dwLanguageId value
Public Const LANG_USER_DEFAULT = &H400&
'

' Registers the specified typelib.

'   sTypelibPath  - typelib's path, either explicit, or relative if the system can find it
'   sHelpPath      - typelib's help file path, should be explicit
'   fSilent            - specifies that a messagebox will not be shown indicating the result of the function

' Returns True on success, False otherwise.

Public Function RegTypelib(sTypelibPath As String, _
                                            Optional sHelpPath As String = vbNullChar, _
                                            Optional fSilent As Boolean = False) As Boolean
On Error GoTo myerr
  Dim hr As Long
'  Dim lptlb As Long
  Dim itlb As ITypeLib
  'If Dir(sTypelibPath) = "" Then Exit Function
  hr = LoadTypeLib(StrConv(sTypelibPath, vbUnicode), itlb)
  If (hr = S_OK) Then
    hr = RegisterTypeLib(itlb, StrConv(sTypelibPath, vbUnicode), _
                                              StrConv(sHelpPath, vbUnicode))
  End If
    
  If (fSilent = False) Then
    If (hr = S_OK) Then
      'MsgBox "Successfully registered " & sTypelibPath
      RegTypelib = True
    Else
      'MsgBox "Failed to register " & sTypelibPath & _
                    vbCrLf & vbCrLf & GetAPIErrStr(hr), vbExclamation
    End If
  End If
myerr:
End Function

' Unregisters the specified typelib.
'   sTypelibPath  - typelib's path, either explicit, or relative if the system can find it
'   fSilent            - specifies that a messagebox will not be shown indicating the result of the function

' Returns True on success, False otherwise.

Public Function UnregTypelib(sTypelibPath As String, _
                                               Optional fSilent As Boolean = False) As Boolean
On Error GoTo myerr
  Dim hr As Long
  Dim itlb As ITypeLib
  Dim lptlba As Long
  Dim tlba As TLIBATTR
  'If Dir(sTypelibPath) = "" Then Exit Function
  hr = LoadTypeLib(StrConv(sTypelibPath, vbUnicode), itlb)
  If (hr = S_OK) Then

' can't do this since VB DWORD aligns the struct !!! (it has 3 WORD members)
'    If itlb.GetLibAttr(tlba) = S_OK Then
    
    ' allocate memory for the TLIBATTR struct
    lptlba = LocalAlloc(LPTR, Len(tlba))
    hr = Err.LastDllError
    If lptlba Then
      
      ' Fill the struct's pointer
      hr = itlb.GetLibAttr(lptlba)
      If (hr = S_OK) Then
        
        ' Fill the struct from its pointer
        ' VB doesn't DWORD align the struct on this call... (?)
        MoveMemory tlba, ByVal lptlba, Len(tlba)
        
        ' Unregister the typelib using the info from the TLIBATTR struct
        With tlba
          hr = UnRegisterTypeLib(.GUID, .wMajorVerNum, .wMinorVerNum, .lcid, .SYSKIND)
        End With

        ' Don't do this since we're de-allocating
        ' below what we allocated above
'        Call itlb.ReleaseTLibAttr(tlba)
'        Set itlb = Nothing
      End If
      
      Call LocalFree(lptlba)
    
    End If   ' lptlba
  End If   ' LoadTypeLib
  
  If (fSilent = False) Then
    If (hr = S_OK) Then
      'MsgBox "Successfully unregistered " & sTypelibPath
      UnregTypelib = True
    ElseIf (hr = TYPE_E_REGISTRYACCESS) Then
      'MsgBox "Type library is not registered: " & sTypelibPath
      UnregTypelib = True
    Else
      'MsgBox "Failed to unregister " & sTypelibPath & _
                    vbCrLf & vbCrLf & GetAPIErrStr(hr), vbExclamation
    End If
  End If
  
  UnregTypelib = (hr = S_OK)
myerr:
End Function

' Returns the system-defined description of an API error code

Public Function GetAPIErrStr(dwErrCode As Long) As String
  Dim sErrDesc As String * 256   ' max string resource len
  
  If FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM Or _
                                FORMAT_MESSAGE_IGNORE_INSERTS Or _
                                FORMAT_MESSAGE_MAX_WIDTH_MASK, _
                                ByVal 0&, dwErrCode, LANG_USER_DEFAULT, _
                                ByVal sErrDesc, 256, 0) Then
  
    GetAPIErrStr = Left$(sErrDesc, InStr(sErrDesc, vbNullChar) - 1)
  End If
End Function