|
Neither Excel nor VBA provides you with a method to get
the DLL name of a COM Add-In. This page contains a procedure
named DLLOfComAddin that will return the fully-qualified file name of
the DLL of the COM Add-In you pass
in as a parameter.
Since this code deals with COM Add-Ins, it will not work in Office97. This
code can be used in any application that supports
VBA6 (Office 2000 and later) and COM Add-Ins. There is nothing specific to Excel in the
code.The procedure gets the GUID property of the
passed-in COM Add-In reference and looks up that value in the appropriate
key of the
Registry and
returns the
value of the InprocServer32 item. The complete VBA module, including
required constants and
Windows API declarations, is below.
This code uses the functions
TrimToNull
located here and
GetSystemErrorMessageText
located here.
To get the DLL name of the COM Add-In, use code like
the following:
Sub AAATest()
Dim CAI As Office.COMAddIn
Dim DLLName As String
Set CAI =
Application.COMAddIns(1)
DLLName = DLLOfComAddin(A_7_AB_1_ComAddIn:=CAI)
If DLLName <> vbNullString Then
MsgBox "Addin Information:" & vbCrLf & _
"ProgID: " & CAI.ProgID &
vbCrLf & _
"GUID: " & CAI.GUID
& vbCrLf & _
"DLL Name: " & DLLName
End If
End Sub
The Code:
All of the following code that follows should be pasted in to a new,
empty,
VBA code module. You can download an example
Excel Workbook here
or just the code bas module here.
Option Explicit
Option Compare Text
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' modDLLNameOfComAddin
' By Chip Pearson, chip@cpearson.com, www.cpearson.com.
'
' This module contains the DLLOfComAddin function. This function takes as
its input
' parameter a reference to an existing COM AddIn and returns a string
containing
' the fully-qualified DLL file name of that COM Add-In.
' The COM Addin need not be connected.
'
' This module is entirely self-contained. It requires no additional support
code.
' This code may be in any Office application that supports VBA6 (Office 2000
and later).
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Constants
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''
' Misc constants.
'''''''''''''''''''''''''''''
Private Const C_COM_ADDIN_CLSID_REG_LOCATION = "SOFTWARE\Classes\CLSID\"
Private Const C_COM_ADDIN_CLSID_REG_VALUE_NAME = "InprocServer32"
Private Const C_PATH_SEPARATOR = "\"
Private Const ERROR_SUCCESS = As Long 0
Private Const MAX_PATH = As Long 260 ' Windows mandated value.
'''''''''''''''''''''''''''''
' Registry Sections
'''''''''''''''''''''''''''''
Private Const HKEY_CLASSES_ROOT As Long = &H80000000
Private Const HKEY_CURRENT_USER As Long = &H80000001
Private Const HKEY_LOCAL_MACHINE As Long = &H80000002
Private Const HKEY_USERS As Long = &H80000003
'''''''''''''''''''''''''''''
' used by FormatMessage
'''''''''''''''''''''''''''''
Private Const FORMAT_MESSAGE_ALLOCATE_BUFFER As Long = &H100
Private Const FORMAT_MESSAGE_ARGUMENT_ARRAY As Long = &H2000
Private Const FORMAT_MESSAGE_FROM_HMODULE As Long = &H800
Private Const FORMAT_MESSAGE_FROM_STRING As Long = &H400
Private Const FORMAT_MESSAGE_FROM_SYSTEM As Long = &H1000
Private Const FORMAT_MESSAGE_IGNORE_INSERTS As Long = &H200
Private Const FORMAT_MESSAGE_MAX_WIDTH_MASK As Long = &HFF
Private Const FORMAT_MESSAGE_TEXT_LEN = As Long 160 ' from ERRORS.H C++
include file.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Windows API Declares
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' RegOpenKey opens an existing registry key, named in lpSubKey. It populates
' phkResult with a key value that is used by the other registry functions.
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (
_
ByVal hKey As Long, _
ByVal lpSubKey As String, _
ByRef phkResult As Long) As Long
' RegCloseKey closes a registry key previously opened with RegOpenKey.
Private Declare Function RegCloseKey Lib "advapi32.dll" ( _
ByVal hKey As Long) As Long
' RegQueryValue reads the value of a registry item, opened with RegOpenKey.
Private Declare Function RegQueryValue Lib "advapi32.dll" Alias "RegQueryValueA"
( _
ByVal hKey As Long, _
ByVal lpSubKey As String, _
ByVal lpValue As String, _
ByRef lpcbValue As Long) As Long
' FormatMessage gets the descriptive error messages associated with the
error
' number in dwMessageId.
Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA"
( _
ByVal dwFlags As Long, _
ByRef lpSource As Any, _
ByVal dwMessageId As Long, _
ByVal dwLanguageId As Long, _
ByVal lpBuffer As String, _
ByVal nSize As Long, _
ByRef Arguments As Long) As Long
Public Function DLLOfComAddin(A_7_AB_1_ComAddIn As Office.COMAddIn) As
String
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' DLLOfComAddin
' By Chip Pearson, chip@cpearson.com , www.cpearson.com
'
' This function returns the fully-qualified name of the DLL file for the
' specified COM Add-In (CAI). A_7_AB_1_ComAddIn is a reference to an
existing
' CAI. It is not required that the CAI be connected.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim V_7_AB_1_RegistryKeyName As String ' stores the name of the registry key
we're working with
Dim V_7_AB_1_RegResult As String '
stores the name of the COM Add-In's DLL file.
Dim V_7_AB_1_Res As Long
' general puprose return code variable
Dim V_7_AB_1_RegKey As Long
' internal registry key value retrieved by RegOpenKey
Dim V_7_AB_1_ErrorNumber As Long '
stores the error number than may have occurred
Dim V_7_AB_1_ErrorText As String '
error text returned GetSystemErrorMessageText
Dim V_7_AB_1_RegResultLen As Long ' length in
characters of V_7_AB_1_RegResult
'''''''''''''''''''''''''''''''''''''''''''''''''
' Initialize the string we're going to populate with
' the DLL name. The buffer must be long enough
' to store the complete DLL file name. MAX_PATH
' is a Windows mandated length, the maximum
' length of a fully qualified file name.
'''''''''''''''''''''''''''''''''''''''''''''''''
V_7_AB_1_RegResult = String$(MAX_PATH, vbNullChar)
'''''''''''''''''''''''''''''''''''''''''''''''''
' ensure we didn't get NOTHING
'''''''''''''''''''''''''''''''''''''''''''''''''
If A_7_AB_1_ComAddIn Is Nothing Then
MsgBox "The A_7_AB_1_ComAddIn parameter is NOTHING."
Exit Function
End If
'''''''''''''''''''''''''''''''''''''''''''''''''
' Initialzie the registry key name. It will contain
' a string similar to
'
' SOFTWARE\Classes\CLSID\{F0E54810-A875-4C54-9697-0AE40DAA7316}\InprocServer32
'
' We will look up this key in the HKEY_LOCAL_MACHINE section
' of the registry.
'''''''''''''''''''''''''''''''''''''''''''''''''
V_7_AB_1_RegistryKeyName = C_COM_ADDIN_CLSID_REG_LOCATION & _
A_7_AB_1_ComAddIn.GUID & _
C_PATH_SEPARATOR & _
C_COM_ADDIN_CLSID_REG_VALUE_NAME
'''''''''''''''''''''''''''''''''''''''''''''''''
' Open the registry key V_7_AB_1_RegistryKeyName.
' RegOpenKey puts in V_7_AB_1_RegKey a key value
' that is used by all other registry functions
' that access that key.
'''''''''''''''''''''''''''''''''''''''''''''''''
V_7_AB_1_Res = RegOpenKey(hKey:=HKEY_LOCAL_MACHINE, _
lpSubKey:=V_7_AB_1_RegistryKeyName, _
phkResult:=V_7_AB_1_RegKey)
If V_7_AB_1_Res <> ERROR_SUCCESS Then
V_7_AB_1_ErrorNumber = V_7_AB_1_Res
V_7_AB_1_ErrorText =
GetSystemErrorMessageText(V_7_AB_1_ErrorNumber)
MsgBox "Error opening Registry key: '" &
V_7_AB_1_RegistryKeyName & "'" & vbCrLf & _
"System Error: " &
CStr(V_7_AB_1_ErrorNumber) & _
" Hex(&H" &
Hex(V_7_AB_1_ErrorNumber) & ")" & vbCrLf & _
"Description: " &
V_7_AB_1_ErrorText
Exit Function
End If
'''''''''''''''''''''''''''''''''''''''''''''''''
' Get the value from the registry. We set
' lpSubKey:=vbNullString to get the default
' value, which is the DLL file name.
'''''''''''''''''''''''''''''''''''''''''''''''''
' V_7_AB_1_RegResultLen is the length in characters
' of V_7_AB_1_RegResult, the variable that will
' receive the DLL file name.
V_7_AB_1_RegResultLen = MAX_PATH
V_7_AB_1_Res = RegQueryValue(hKey:=V_7_AB_1_RegKey, _
lpSubKey:=vbNullString, _
lpValue:=V_7_AB_1_RegResult, lpcbValue:=V_7_AB_1_RegResultLen)
If V_7_AB_1_Res <> ERROR_SUCCESS Then
V_7_AB_1_ErrorNumber = V_7_AB_1_Res
V_7_AB_1_ErrorText =
GetSystemErrorMessageText(V_7_AB_1_ErrorNumber)
MsgBox "Error retrieving Registry key: '" &
V_7_AB_1_RegistryKeyName & "'" & vbCrLf & _
"System
Error: " & CStr(V_7_AB_1_ErrorNumber) & _
" Hex(&H" &
Hex(V_7_AB_1_ErrorNumber) & ")" & vbCrLf & _
"Description:
" & V_7_AB_1_ErrorText
RegCloseKey hKey:=V_7_AB_1_RegKey
Exit Function
End If
'''''''''''''''''''''''''''''''''''''''''''''''''
' close our registry key
'''''''''''''''''''''''''''''''''''''''''''''''''
RegCloseKey V_7_AB_1_RegKey
'''''''''''''''''''''''''''''''''''''''''''''''''
' trim V_7_AB_1_RegResult to the vbNullChar
'''''''''''''''''''''''''''''''''''''''''''''''''
V_7_AB_1_RegResult = TrimToNull(V_7_AB_1_RegResult)
'''''''''''''''''''''''''''''''''''''''''''''''''
' return the DLL name
'''''''''''''''''''''''''''''''''''''''''''''''''
DLLOfComAddin = V_7_AB_1_RegResult
End Function
Private Function
GetSystemErrorMessageText(ErrorNumber As Long) As String
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' GetSystemErrorMessageText
'
' This function gets the system error message text that corresponds to the
error
' code returned by the GetLastError API function or the Err.LastDllError property.
' It may be used
ONLY for these error codes. These are NOT the error
' numbers returned by Err.Number (for these errors, use Err.Description to
get the
' description of the message). The error number MUST be the value returned by
' GetLastError or
Err.LastDLLError.
'
' In general, you should use Err.LastDllError rather than GetLastError
because under
' some circumstances the value of GetLastError will be reset to 0 before the value is
' returned to VB. Err.LastDllError will always reliably return the last error number
' raised in a DLL.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim V_7_AB_1_ErrorText As String
Dim V_7_AB_1_TextLen As Long
Dim V_7_AB_1_FormatMessageResult As Long
Dim V_7_AB_1_LangID As Long
V_7_AB_1_LangID = 0&
V_7_AB_1_ErrorText = String$(FORMAT_MESSAGE_TEXT_LEN, " ")
V_7_AB_1_TextLen = Len(V_7_AB_1_ErrorText)
V_7_AB_1_FormatMessageResult = 0&
V_7_AB_1_FormatMessageResult = FormatMessage( _
dwFlags:=FORMAT_MESSAGE_FROM_SYSTEM
Or FORMAT_MESSAGE_IGNORE_INSERTS, _
lpSource:=0&, _
dwMessageId:=ErrorNumber, _
dwLanguageId:=0&, _
lpBuffer:=V_7_AB_1_ErrorText, _
nSize:=Len(V_7_AB_1_ErrorText), _
Arguments:=0&)
If V_7_AB_1_FormatMessageResult > 0 Then
' FormatMessage returned some text. Take the left
V_7_AB_1_FormatMessageResult
' characters and return that text.
V_7_AB_1_ErrorText = Left$(V_7_AB_1_ErrorText,
V_7_AB_1_FormatMessageResult)
GetSystemErrorMessageText = V_7_AB_1_ErrorText
Else
' Format message didn't return any text.
' There is no text
description for the specified error.
GetSystemErrorMessageText = "NO ERROR DESCRIPTION AVAILABLE"
End If
End Function
Private Function TrimToNull(Text As String) As String
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' TrimToNull
' This function returns the portion of Text that is to the left of the
vbNullChar
' character (same as Chr(0)). Typically, this function is used with strings
' populated by Windows API procedures. It is generally not used for
' native VB Strings.
' If vbNullChar is not found, the entire Text string is returned.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim Pos As Integer
Pos = InStr(1, Text, vbNullChar)
If Pos > 0 Then
TrimToNull = Left(Text, Pos - 1)
Else
TrimToNull = Text
End If
End Function
Public Sub AAATestIt()
''''''''''''''''''''''''''''''''''''''''''''''
' Test procedure. This procedure may be
' deleted with no side effects.
''''''''''''''''''''''''''''''''''''''''''''''
Dim CAI As Office.COMAddIn
Dim DLLName As String
If Application.COMAddIns.Count >= 1 Then
Set CAI = Application.COMAddIns(1)
DLLName = DLLOfComAddin(A_7_AB_1_ComAddIn:=CAI)
MsgBox "Addin Information:" & vbCrLf & _
"ProgID: " & CAI.ProgID & vbCrLf & _
"GUID: " & CAI.GUID & vbCrLf & _
"DLL Name: " & DLLName & vbCrLf & _
"Connected: " & CAI.Connect
Else
MsgBox "There are no COM Add-Ins.
End If
End Sub
|
|