VB and VBA Users Source Code: List/Enumerate all the OCX Controls installed on a computer
[
Home
|
Contents
|
Search
|
Reply
| Previous | Next ]
VB/VBA Source Code
List/Enumerate all the OCX Controls installed on a computer
By:
Andrew Baker
Email (spam proof):
Email the originator of this post
Date:
Monday, April 09, 2001
Hits:
2186
Category:
Visual Basic General
Article:
Listed below is a routine which returns details for all the OCX controls installed on the local machine. The source code for this has been derived (with permission) from code on Edanmo's VB Page (http://www.domaindlx.com/e_morcillo/). The routine enumerates the uses the registry to determine which controls are installed, then checks if the files exist and are correctly registered. The demonstration routine at the bottom of the post populates a listview with the results. PS Thanks to Edanmo for allowing us to use his code. '---Place following code in a module--- Option Explicit Public Type tControlInfo Description As String File As String PROGID As String CLSID As String TYPELIB As String Invalid As Boolean End Type Private Type tIID Data1 As Long Data2 As Integer Data3 As Integer Data4(0 To 7) As Byte End Type 'Registry Access Functions Private Const HKEY_CLASSES_ROOT = &H80000000 Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long Private Declare Function RegEnumKeyEx Lib "advapi32.dll" Alias "RegEnumKeyExA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, lpcbName As Long, ByVal lpReserved As Long, ByVal lpClass As Any, lpcbClass As Long, lpftLastWriteTime As Any) As Long Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long 'Note that if you declare the lpData parameter as String, you must pass it By Value. Private Declare Function RegQueryInfoKey Lib "advapi32.dll" Alias "RegQueryInfoKeyA" (ByVal hKey As Long, ByVal lpClass As String, lpcbClass As Long, ByVal lpReserved As Long, lpcSubKeys As Long, lpcbMaxSubKeyLen As Long, lpcbMaxClassLen As Long, lpcValues As Long, lpcbMaxValueNameLen As Long, lpcbMaxValueLen As Long, lpcbSecurityDescriptor As Long, lpftLastWriteTime As Any) As Long Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long Private Const READ_CONTROL = &H20000 Private Const KEY_QUERY_VALUE = &H1 Private Const KEY_SET_VALUE = &H2 Private Const KEY_CREATE_SUB_KEY = &H4 Private Const KEY_ENUMERATE_SUB_KEYS = &H8 Private Const KEY_NOTIFY = &H10 Private Const KEY_CREATE_LINK = &H20 Private Const KEY_READ = READ_CONTROL Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY Private Const KEY_WRITE = READ_CONTROL Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY Private Const KEY_EXECUTE = KEY_READ Private Const KEY_ALL_ACCESS = &H1F0000 Or KEY_QUERY_VALUE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY Or KEY_CREATE_LINK Private Const REG_SZ = 1 Private Const IMPLEMENTEDCATEGORIES_CONTROL As String = "\Implemented Categories\{40FC6ED4-2438-11CF-A3DB-080036F12502}" Private Const INPROC_SERVER As String = "\InprocServer" Private Const INPROC_SERVER32 As String = "\InprocServer32" Private Const PROGID As String = "\ProgID" Private Const TYPELIB As String = "\TypeLib" Private Const CONTROL As String = "\Control" 'Purpose : Returns a 1d array of all the controls installed on the local machine 'Inputs : Ctrls See outputs 'Outputs : Ctrls(1 to NumControls) containing information on the controls installed. ' Returns a count of the controls found 'Author : Edanmo Morcillo 'Date : 25/11/2000 03:33 'Notes : Originated from http://www.domaindlx.com/e_morcillo 'Revisions : Public Function EnumControls(ByRef Ctrls() As tControlInfo) As Long Dim CLSID As Long, lMaxKeyLen As Long, lIndex As Long, lRetVal As Long Dim sKeyName As String, lKeyNameL As Long, lhwndControlKey As Long Dim tCtrlInfo As tControlInfo, lMax As Long, tIID As tIID ReDim Ctrls(0 To 0) 'Open HKCR\CLSID If RegOpenKeyEx(HKEY_CLASSES_ROOT, "CLSID", 0, KEY_READ, CLSID) = 0 Then 'Get lMax subkeys lenght RegQueryInfoKey CLSID, vbNullString, ByVal 0&, 0&, ByVal 0&, lMaxKeyLen, ByVal 0&, ByVal 0&, ByVal 0&, ByVal 0&, ByVal 0&, ByVal 0& 'Initialize buffer sKeyName = String$(lMaxKeyLen + 1, 0) lKeyNameL = Len(sKeyName) 'Enum HKCR\CLSID subkeys Do While RegEnumKeyEx(CLSID, lIndex, sKeyName, lKeyNameL, 0, 0&, ByVal 0&, ByVal 0&) = 0 'Try to open the subkey HKCR\CLSID\sKeyName\Implemented Categories\{40FC6ED4-2438-11CF-A3DB-080036F12502} '{40FC6ED4-2438-11CF-A3DB-080036F12502} is control category lRetVal = RegOpenKeyEx(CLSID, Left$(sKeyName, lKeyNameL) & IMPLEMENTEDCATEGORIES_CONTROL, 0, KEY_READ, lhwndControlKey) 'If the subkey does not exist try to open 'the subkey HKCR\CLSID\sKeyName\Control If lRetVal <> 0 Then lRetVal = RegOpenKeyEx(CLSID, Left$(sKeyName, lKeyNameL) & CONTROL, 0, KEY_READ, lhwndControlKey) End If If lRetVal = 0 Then 'Get the Info With tCtrlInfo .CLSID = Left$(sKeyName, lKeyNameL) .Description = GetDefaultValue(CLSID, .CLSID) .File = GetDefaultValue(CLSID, .CLSID & INPROC_SERVER32) If Len(.File) = 0 Then 'There's no INPROC_SERVER32. 'Try INPROC_SERVER as the control maybe '16bit. .File = GetDefaultValue(CLSID, .CLSID & INPROC_SERVER) End If .PROGID = GetDefaultValue(CLSID, .CLSID & PROGID) .TYPELIB = GetDefaultValue(CLSID, .CLSID & TYPELIB) .Invalid = (FileExists(.File) = False Or TypeLibExists(.TYPELIB) = False) 'Check if the file is not empty and exist 'and the typelib guid is valid. ReDim Preserve Ctrls(0 To lMax) Ctrls(lMax) = tCtrlInfo lMax = lMax + 1 End With 'Close the subkey RegCloseKey lhwndControlKey End If sKeyName = String$(lMaxKeyLen + 1, 0) lKeyNameL = Len(sKeyName) lIndex = lIndex + 1 Loop 'Close HKCR\CLSID RegCloseKey CLSID End If EnumControls = lMax End Function 'Purpose : Checks if a file exists 'Inputs : sFilePathName The path and file name e.g. "C:\Autoexec.bat" 'Outputs : Returns True if the file exists 'Author : Andrew Baker 'Date : 25/11/2000 03:33 'Notes : 'Revisions : Private Function FileExists(sFilePathName As String) As Boolean On Error GoTo ErrFailed If Len(sFilePathName) Then If (GetAttr(sFilePathName) And vbDirectory) < 1 Then 'File Exists FileExists = True End If End If Exit Function ErrFailed: FileExists = False End Function 'Purpose : Checks if a file exists 'Inputs : sFilePathName The path and file name e.g. "C:\Autoexec.bat" 'Outputs : Returns True if the file exists 'Author : Edanmo Morcillo 'Date : 25/11/2000 03:33 'Notes : Originated from http://www.domaindlx.com/e_morcillo 'Revisions : Private Function GetDefaultValue(ByVal hKey As Long, ByVal SubKey As String) As String Const clMaxLen As Long = 512 Dim sData As String * clMaxLen, lhCLSIDKey As Long, lLenString As Long If RegOpenKeyEx(hKey, SubKey, 0, KEY_READ, lhCLSIDKey) = 0 Then lLenString = clMaxLen If RegQueryValueEx(lhCLSIDKey, vbNullString, 0, REG_SZ, ByVal sData, lLenString) = 0 Then GetDefaultValue = Left$(sData, lLenString - 1) End If RegCloseKey lhCLSIDKey End If End Function 'Purpose : Checks to see if a type library exists by opening a registry key 'Inputs : TYPELIB The type libray GUID 'Outputs : Returns True if the type library has been registered 'Author : Edanmo Morcillo 'Date : 25/11/2000 03:33 'Notes : Originated from http://www.domaindlx.com/e_morcillo 'Revisions : Private Function TypeLibExists(ByVal TYPELIB As String) As Boolean Dim hKey As Long If RegOpenKeyEx(HKEY_CLASSES_ROOT, "TypeLib\" & TYPELIB, 0, KEY_READ, hKey) = 0 Then TypeLibExists = True RegCloseKey hKey End If End Function '---Place following code in a form--- Option Explicit 'Demonstration routine. 'Fills a listview with details of the controls installed 'on the local machine Private Sub Form_Load() Dim Ctrls() As tControlInfo, I As Long Dim Itm As ListItem EnumControls Ctrls lvwControls.ColumnHeaders.Add , , "Control Name" lvwControls.ColumnHeaders.Add , , "GUID" lvwControls.ColumnHeaders.Add , , "File" lvwControls.ColumnHeaders.Add , , "Prog ID" lvwControls.ColumnHeaders.Add , , "Type Lib GUID" lvwControls.ColumnHeaders.Add , , "Invalid" lvwControls.View = lvwReport lvwControls.FullRowSelect = True lvwControls.HideSelection = False For I = 0 To UBound(Ctrls) Set Itm = lvwControls.ListItems.Add(, , Ctrls(I).Description) With Itm .SubItems(1) = Ctrls(I).CLSID .SubItems(2) = Ctrls(I).File .SubItems(3) = Ctrls(I).PROGID .SubItems(4) = Ctrls(I).TYPELIB .SubItems(5) = Ctrls(I).Invalid End With Next End Sub
Terms and Conditions
Support this site
Download a trial version of the Excel Workbook Rebuilder
