Solved

PART 2 - Enumerate valid choices for properties

Posted on 2007-03-26
5
364 Views
Last Modified: 2012-06-27
Previously I asked about how to enumerate valid choices or enumerations for properties.  Danaseaman provided a good answer that worked, as follows:  "Assuming you know the name of the Enum, add a reference to TlbInf32.Dll and use Public Function GetEnumNames" (which code he provided).
That question can be found at: http://www.experts-exchange.com/Microsoft/Development/MS_Access/Q_22455539.html
Now for part 2.  I opened tlbInf32.dll in the Object Browser, and it looks like it would be possible to loop through the controls (both activeX and native Access controls) on a form, get the names of the properties, and the range or list of valid values, withot having to know the enum name first, that is, retrieve the class names of TKIND_ENUM and also the alias or property names that you would find in the property sheet.  What I want to do is have a data grid with the property name in the first column (e.g., DayOfWeek), the enum name in the second column (e.g., enumDayOfWeek), and the enumerated values (e.g., 1,2,3,4,5,6,7, each on a separate row).  THe link above has the code that is a starting point.
0
Comment
Question by:gcheatham
  • 4
5 Comments
 
LVL 22

Accepted Solution

by:
danaseaman earned 500 total points
ID: 18849882
The code to do this is not trivial and would probably take several days to put it all together.

My previous answer touched on getting Enum names and values using TlnInf32.Dll. Here is a starting point on how to enumerate the Forms controls and get the TypeLib info. The sequence it to enumerate the controls collection and then retrieve the physical control location on disk so you can pass that to TlbInf32.

Start by getting the ProgID, then use registry to lookup CLSID and finally InProcServer32 value. You may need to get ProgID from registry "VersionIndependentProgID" vs using function BestClassInfo. For example BestClassInfo returns "MSComctlLib.ListView" whereas the correct value from VersionIndependentProgID is "MSComctlLib.ListViewCtrl".

Once you have the physical control location on disk create a TypeLibInfo for the control. From there you can document the entire control just as you would see in Vb Object Browser of OleView.Exe using code at http://www.vbaccelerator.com/home/VB/Utilities/ActiveX_Documenter/article.asp or retrieve only the information you are interested in.
 
'In Form:
Option Explicit

Dim cReg                As New cRegistry
Private m_cTLI          As TypeLibInfo

Private Sub Form_Load()
   With ListView1
      .ColumnHeaders.Add , , "Object"
      .ColumnHeaders.Add , , "Enum"
      .ColumnHeaders.Add , , "Member"
      .ColumnHeaders.Add , , "Value"
   End With
End Sub

Private Sub cmdGo_Click()
   Dim ctl              As Control
   Dim oTL              As TypeInfo
   Dim m_iCount         As Long
   Dim item             As ListItem
   Dim ProgID           As String
   Dim CLSID            As String
   Dim sFileName        As String
   Dim iTypeInfo        As Long
   Dim iDefaultInterface As Long
   Dim iDefaultEvents   As Long

   For Each ctl In Me.Controls
      Debug.Print ctl.Name, TypeName(ctl)
      Set oTL = BestClassInfo(ctl)
      If Not oTL Is Nothing Then
         ProgID = oTL.Parent & "." & oTL.Name
         If ProgID = "MSComctlLib.ListView" Then
            ProgID = "MSComctlLib.ListViewCtrl" '???
         End If
         cReg.ClassKey = HKEY_CLASSES_ROOT
         cReg.SectionKey = ProgID & "\" & "CLSID"
         CLSID = cReg.Value
         cReg.SectionKey = "CLSID" & "\" & CLSID & "\InProcServer32"
         sFileName = cReg.Value

         Set m_cTLI = TLI.TypeLibInfoFromFile(sFileName)
         
         If Not m_cTLI Is Nothing Then
            With m_cTLI
               m_iCount = .TypeInfoCount
               For iTypeInfo = 1 To m_iCount
                  'Add only desired info to Listview
                  Set item = ListView1.ListItems.Add(, , m_cTLI.Name)
                  'item.SubItems(1) = .TypeInfos(iTypeInfo).Name
               Next iTypeInfo
            End With
         End If
      End If
   Next

   Exit Sub
pGetTypeLibInfoError:
   MsgBox "Failed to get type lib info for file: '" & sFileName & "'" & vbCrLf & vbCrLf & Err.Description, vbExclamation
   Set m_cTLI = Nothing
   Exit Sub
End Sub

Function BestClassInfo(ByVal Object As Object) As TypeInfo
   On Error GoTo NotAvailable
   Set BestClassInfo = TLI.ClassInfoFromObject(Object)

   With BestClassInfo.Parent
      With TLI.TypeLibInfoFromRegistry _
         (.Guid, .MajorVersion, .MinorVersion, .LCID)
         Set BestClassInfo = .Me.TypeInfos.IndexedItem(BestClassInfo.TypeInfoNumber)
      End With
   End With
   Exit Function
NotAvailable:
   Err.Clear
End Function

'Registry Class:
Option Explicit

' =========================================================
' Class:    cRegistry
' Author:   Steve McMahon
' Date  :   21 Feb 1997
'
' A nice class wrapper around the registry functions
' Allows searching,deletion,modification and addition
' of Keys or Values.
'
' Updated 29 April 1998 for VB5.
'   * Fixed GPF in EnumerateValues
'   * Added support for all registry types, not just strings
'   * Put all declares in local class
'   * Added VB5 Enums
'   * Added CreateKey and DeleteKey methods
' =========================================================

'Registry Specific Access Rights
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_ALL_ACCESS = &H3F

'Open/Create Options
Private Const REG_OPTION_NON_VOLATILE = 0&
Private Const REG_OPTION_VOLATILE = &H1

'Key creation/open disposition
Private Const REG_CREATED_NEW_KEY = &H1
Private Const REG_OPENED_EXISTING_KEY = &H2

'masks for the predefined standard access types
Private Const STANDARD_RIGHTS_ALL = &H1F0000
Private Const SPECIFIC_RIGHTS_ALL = &HFFFF

'Define severity codes
Private Const ERROR_SUCCESS = 0&
Private Const ERROR_ACCESS_DENIED = 5
Private Const ERROR_INVALID_DATA = 13&
Private Const ERROR_MORE_DATA = 234 '  dderror
Private Const ERROR_NO_MORE_ITEMS = 259


'Structures Needed For Registry Prototypes
Private Type SECURITY_ATTRIBUTES
  nLength As Long
  lpSecurityDescriptor As Long
  bInheritHandle As Boolean
End Type

Private Type FILETIME
  dwLowDateTime As Long
  dwHighDateTime As Long
End Type

'Registry Function Prototypes
Private Declare Function RegOpenKeyEx Lib "advapi32" 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 RegSetValueExStr Lib "advapi32" Alias "RegSetValueExA" _
  (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, _
   ByVal dwType As Long, ByVal szData As String, ByVal cbData As Long) As Long
Private Declare Function RegSetValueExLong Lib "advapi32" Alias "RegSetValueExA" _
  (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, _
   ByVal dwType As Long, szData As Long, ByVal cbData As Long) As Long
Private Declare Function RegSetValueExByte Lib "advapi32" Alias "RegSetValueExA" _
  (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, _
   ByVal dwType As Long, szData As Byte, ByVal cbData As Long) As Long

Private Declare Function RegCloseKey Lib "advapi32" (ByVal hKey As Long) As Long

Private Declare Function RegQueryValueExStr Lib "advapi32" Alias "RegQueryValueExA" _
  (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, _
   ByRef lpType As Long, ByVal szData As String, ByRef lpcbData As Long) As Long
Private Declare Function RegQueryValueExLong Lib "advapi32" Alias "RegQueryValueExA" _
  (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, _
   ByRef lpType As Long, szData As Long, ByRef lpcbData As Long) As Long
Private Declare Function RegQueryValueExByte Lib "advapi32" Alias "RegQueryValueExA" _
  (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, _
   ByRef lpType As Long, szData As Byte, ByRef lpcbData As Long) As Long
   
Private Declare Function RegCreateKeyEx Lib "advapi32" Alias "RegCreateKeyExA" _
  (ByVal hKey As Long, ByVal lpSubKey As String, ByVal Reserved As Long, _
   ByVal lpClass As String, ByVal dwOptions As Long, ByVal samDesired As Long, _
   lpSecurityAttributes As SECURITY_ATTRIBUTES, phkResult As Long, _
   lpdwDisposition 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 String, _
   lpcbClass As Long, lpftLastWriteTime As FILETIME) As Long

Private Declare Function RegEnumKey Lib "advapi32.dll" Alias "RegEnumKeyA" ( _
    ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, _
    ByVal cbName As Long) As Long

Private Declare Function RegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" _
  (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, _
   lpcbValueName As Long, ByVal lpReserved As Long, ByVal lpType As Long, _
   ByVal lpData As Long, ByVal lpcbData As Long) As Long
   
Private Declare Function RegEnumValueLong Lib "advapi32.dll" Alias "RegEnumValueA" _
  (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, _
   lpcbValueName As Long, ByVal lpReserved As Long, lpType As Long, _
   lpData As Long, lpcbData As Long) As Long
Private Declare Function RegEnumValueStr Lib "advapi32.dll" Alias "RegEnumValueA" _
  (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, _
   lpcbValueName As Long, ByVal lpReserved As Long, lpType As Long, _
   ByVal lpData As String, lpcbData As Long) As Long
Private Declare Function RegEnumValueByte Lib "advapi32.dll" Alias "RegEnumValueA" _
  (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, _
   lpcbValueName As Long, ByVal lpReserved As Long, lpType As Long, _
   lpData As Byte, lpcbData As Long) As Long

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 Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" _
  (ByVal hKey As Long, ByVal lpValueName As String) As Long

' Other declares:
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
    lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
Private Declare Function ExpandEnvironmentStrings Lib "kernel32" Alias "ExpandEnvironmentStringsA" (ByVal lpSrc As String, ByVal lpDst As String, ByVal nSize As Long) As Long


Public Enum ERegistryClassConstants
    HKEY_CLASSES_ROOT = &H80000000
    HKEY_CURRENT_USER = &H80000001
    HKEY_LOCAL_MACHINE = &H80000002
    HKEY_USERS = &H80000003
End Enum

Public Enum ERegistryValueTypes
'Predefined Value Types
    REG_NONE = (0)                         'No value type
    REG_SZ = (1)                           'Unicode nul terminated string
    REG_EXPAND_SZ = (2)                    'Unicode nul terminated string w/enviornment var
    REG_BINARY = (3)                       'Free form binary
    REG_DWORD = (4)                        '32-bit number
    REG_DWORD_LITTLE_ENDIAN = (4)          '32-bit number (same as REG_DWORD)
    REG_DWORD_BIG_ENDIAN = (5)             '32-bit number
    REG_LINK = (6)                         'Symbolic Link (unicode)
    REG_MULTI_SZ = (7)                     'Multiple Unicode strings
    REG_RESOURCE_LIST = (8)                'Resource list in the resource map
    REG_FULL_RESOURCE_DESCRIPTOR = (9)     'Resource list in the hardware description
    REG_RESOURCE_REQUIREMENTS_LIST = (10)
End Enum

Private m_hClassKey As Long
Private m_sSectionKey As String
Private m_sValueKey As String
Private m_vValue As Variant
Private m_sSetValue As String
Private m_vDefault As Variant
Private m_eValueType As ERegistryValueTypes

Public Property Get KeyExists() As Boolean
    'KeyExists = bCheckKeyExists( _
    '                m_hClassKey, _
    '                m_sSectionKey _
    '            )
Dim hKey As Long
    If RegOpenKeyEx(m_hClassKey, m_sSectionKey, 0, 1, hKey) = ERROR_SUCCESS Then
        KeyExists = True
        RegCloseKey hKey
    Else
        KeyExists = False
    End If
   
End Property
Public Function CreateKey() As Boolean
Dim tSA As SECURITY_ATTRIBUTES
Dim hKey As Long
Dim lCreate As Long
Dim e As Long

    'Open or Create the key
    e = RegCreateKeyEx(m_hClassKey, m_sSectionKey, 0, "", REG_OPTION_NON_VOLATILE, _
                 KEY_ALL_ACCESS, tSA, hKey, lCreate)
    If e Then
        Err.Raise 26001, App.EXEName & ".cRegistry", "Failed to create registry Key: '" & m_sSectionKey
    Else
        CreateKey = (e = ERROR_SUCCESS)
        'Close the key
        RegCloseKey hKey
    End If
End Function
Public Function DeleteKey() As Boolean
Dim e As Long
    e = RegDeleteKey(m_hClassKey, m_sSectionKey)
    If e Then
        Err.Raise 26001, App.EXEName & ".cRegistry", "Failed to delete registry Key: '" & m_hClassKey & "',Section: '" & m_sSectionKey
    Else
        DeleteKey = (e = ERROR_SUCCESS)
    End If
   
End Function
Public Function DeleteValue() As Boolean
Dim e As Long
Dim hKey As Long

    e = RegOpenKeyEx(m_hClassKey, m_sSectionKey, 0, KEY_ALL_ACCESS, hKey)
    If e Then
        Err.Raise 26001, App.EXEName & ".cRegistry", "Failed to open key '" & m_hClassKey & "',Section: '" & m_sSectionKey & "' for delete access"
    Else
        e = RegDeleteValue(hKey, m_sValueKey)
        If e Then
            Err.Raise 26001, App.EXEName & ".cRegistry", "Failed to delete registry Key: '" & m_hClassKey & "',Section: '" & m_sSectionKey & "',Key: '" & m_sValueKey
        Else
            DeleteValue = (e = ERROR_SUCCESS)
        End If
    End If

End Function
Public Property Get Value() As Variant
Dim vValue As Variant
Dim cData As Long, sData As String, ordType As Long, e As Long
Dim hKey As Long

    e = RegOpenKeyEx(m_hClassKey, m_sSectionKey, 0, KEY_QUERY_VALUE, hKey)
    'ApiRaiseIf e

    e = RegQueryValueExLong(hKey, m_sValueKey, 0&, ordType, 0&, cData)
    If e And e <> ERROR_MORE_DATA Then
        Value = m_vDefault
        Exit Property
    End If
   
    m_eValueType = ordType
    Select Case ordType
    Case REG_DWORD, REG_DWORD_LITTLE_ENDIAN
        Dim iData As Long
        e = RegQueryValueExLong(hKey, m_sValueKey, 0&, _
                               ordType, iData, cData)
        vValue = CLng(iData)
       
    Case REG_DWORD_BIG_ENDIAN  ' Unlikely, but you never know
        Dim dwData As Long
        e = RegQueryValueExLong(hKey, m_sValueKey, 0&, _
                               ordType, dwData, cData)
        vValue = SwapEndian(dwData)
       
    Case REG_SZ, REG_MULTI_SZ ' Same thing to Visual Basic
        sData = String$(cData - 1, 0)
        e = RegQueryValueExStr(hKey, m_sValueKey, 0&, _
                               ordType, sData, cData)
        vValue = sData
       
    Case REG_EXPAND_SZ
        sData = String$(cData - 1, 0)
        e = RegQueryValueExStr(hKey, m_sValueKey, 0&, _
                               ordType, sData, cData)
        vValue = ExpandEnvStr(sData)
       
    ' Catch REG_BINARY and anything else
    Case Else
        Dim abData() As Byte
        ReDim abData(cData)
        e = RegQueryValueExByte(hKey, m_sValueKey, 0&, _
                                ordType, abData(0), cData)
        vValue = abData
       
    End Select
    Value = vValue
   
End Property
Public Property Let Value( _
        ByVal vValue As Variant _
    )
Dim ordType As Long
Dim c As Long
Dim hKey As Long
Dim e As Long
Dim lCreate As Long
Dim tSA As SECURITY_ATTRIBUTES

    'Open or Create the key
    e = RegCreateKeyEx(m_hClassKey, m_sSectionKey, 0, "", REG_OPTION_NON_VOLATILE, _
                 KEY_ALL_ACCESS, tSA, hKey, lCreate)
   
    If e Then
        Err.Raise 26001, App.EXEName & ".cRegistry", "Failed to set registry value Key: '" & m_hClassKey & "',Section: '" & m_sSectionKey & "',Key: '" & m_sValueKey & "' to value: '" & m_vValue & "'"
    Else

        Select Case m_eValueType
        Case REG_BINARY
            If (VarType(vValue) = vbArray + vbByte) Then
                Dim ab() As Byte
                ab = vValue
                ordType = REG_BINARY
                c = UBound(ab) - LBound(ab) - 1
                e = RegSetValueExByte(hKey, m_sValueKey, 0&, ordType, ab(0), c)
            Else
                Err.Raise 26001
            End If
        Case REG_DWORD, REG_DWORD_BIG_ENDIAN, REG_DWORD_LITTLE_ENDIAN
            If (VarType(vValue) = vbInteger) Or (VarType(vValue) = vbLong) Then
                Dim i As Long
                i = vValue
                ordType = REG_DWORD
                e = RegSetValueExLong(hKey, m_sValueKey, 0&, ordType, i, 4)
            End If
        Case REG_SZ, REG_EXPAND_SZ
            Dim s As String, iPos As Long
            s = vValue
            ordType = REG_SZ
            ' Assume anything with two non-adjacent percents is expanded string
            iPos = InStr(s, "%")
            If iPos Then
                If InStr(iPos + 2, s, "%") Then ordType = REG_EXPAND_SZ
            End If
            c = Len(s) + 1
            e = RegSetValueExStr(hKey, m_sValueKey, 0&, ordType, s, c)
           
        ' User should convert to a compatible type before calling
        Case Else
            e = ERROR_INVALID_DATA
           
        End Select
       
        If Not e Then
            m_vValue = vValue
        Else
            Err.Raise vbObjectError + 1048 + 26001, App.EXEName & ".cRegistry", "Failed to set registry value Key: '" & m_hClassKey & "',Section: '" & m_sSectionKey & "',Key: '" & m_sValueKey & "' to value: '" & m_vValue & "'"
        End If
       
        'Close the key
        RegCloseKey hKey
   
    End If
   
End Property
Public Function EnumerateValues( _
        ByRef sKeyNames() As String, _
        ByRef iKeyCount As Long _
    ) As Boolean
Dim lResult As Long
Dim hKey As Long
Dim sName As String
Dim lNameSize As Long
Dim sData As String
Dim lIndex As Long
Dim cJunk As Long
Dim cNameMax As Long
Dim ft As Currency
   
   ' Log "EnterEnumerateValues"

   iKeyCount = 0
   Erase sKeyNames()
   
   lIndex = 0
   lResult = RegOpenKeyEx(m_hClassKey, m_sSectionKey, 0, KEY_QUERY_VALUE, hKey)
   If (lResult = ERROR_SUCCESS) Then
      ' Log "OpenedKey:" & m_hClassKey & "," & m_sSectionKey
      lResult = RegQueryInfoKey(hKey, "", cJunk, 0, _
                               cJunk, cJunk, cJunk, cJunk, _
                               cNameMax, cJunk, cJunk, ft)
       Do While lResult = ERROR_SUCCESS
   
           'Set buffer space
           lNameSize = cNameMax + 1
           sName = String$(lNameSize, 0)
           If (lNameSize = 0) Then lNameSize = 1
           
           ' Log "Requesting Next Value"
         
           'Get value name:
           lResult = RegEnumValue(hKey, lIndex, sName, lNameSize, _
                                  0&, 0&, 0&, 0&)
           ' Log "RegEnumValue returned:" & lResult
           If (lResult = ERROR_SUCCESS) Then
       
                ' Although in theory you can also retrieve the actual
                ' value and type here, I found it always (ultimately) resulted in
                ' a GPF, on Win95 and NT.  Why?  Can anyone help?
       
               sName = Left$(sName, lNameSize)
               ' Log "Enumerated value:" & sName
                 
               iKeyCount = iKeyCount + 1
               ReDim Preserve sKeyNames(1 To iKeyCount) As String
               sKeyNames(iKeyCount) = sName
           End If
           lIndex = lIndex + 1
       Loop
   End If
   If (hKey <> 0) Then
      RegCloseKey hKey
   End If

   ' Log "Exit Enumerate Values"
   EnumerateValues = True
   Exit Function
   
EnumerateValuesError:
   If (hKey <> 0) Then
      RegCloseKey hKey
   End If
   Err.Raise vbObjectError + 1048 + 26003, App.EXEName & ".cRegistry", Err.Description
   Exit Function

End Function
Public Function EnumerateSections( _
        ByRef sSect() As String, _
        ByRef iSectCount As Long _
    ) As Boolean
Dim lResult As Long
Dim hKey As Long
Dim dwReserved As Long
Dim szBuffer As String
Dim lBuffSize As Long
Dim lIndex As Long
Dim lType As Long
Dim sCompKey As String
Dim iPos As Long

On Error GoTo EnumerateSectionsError

   iSectCount = 0
   Erase sSect
'
   lIndex = 0

   lResult = RegOpenKeyEx(m_hClassKey, m_sSectionKey, 0, KEY_ENUMERATE_SUB_KEYS, hKey)
   Do While lResult = ERROR_SUCCESS
       'Set buffer space
       szBuffer = String$(255, 0)
       lBuffSize = Len(szBuffer)
     
      'Get next value
       lResult = RegEnumKey(hKey, lIndex, szBuffer, lBuffSize)
                             
       If (lResult = ERROR_SUCCESS) Then
           iSectCount = iSectCount + 1
           ReDim Preserve sSect(1 To iSectCount) As String
           iPos = InStr(szBuffer, Chr$(0))
           If (iPos > 0) Then
              sSect(iSectCount) = Left(szBuffer, iPos - 1)
           Else
              sSect(iSectCount) = Left(szBuffer, lBuffSize)
           End If
       End If
       
       lIndex = lIndex + 1
   Loop
   If (hKey <> 0) Then
      RegCloseKey hKey
   End If
   EnumerateSections = True
   Exit Function

EnumerateSectionsError:
   If (hKey <> 0) Then
      RegCloseKey hKey
   End If
   Err.Raise vbObjectError + 1048 + 26002, App.EXEName & ".cRegistry", Err.Description
   Exit Function
End Function
Public Sub CreateEXEAssociation( _
        ByVal sExePath As String, _
        ByVal sClassName As String, _
        ByVal sClassDescription As String, _
        ByVal sAssociation As String, _
        Optional ByVal lDefaultIconIndex As Long = -1 _
    )
    ClassKey = HKEY_CLASSES_ROOT
    SectionKey = "." & sAssociation
    ValueKey = ""
    Value = sClassName
    SectionKey = "." & sAssociation & "\shell\open\command"
    ValueKey = ""
    Value = sExePath & " ""%1"""
   
    SectionKey = sClassName
    ValueKey = ""
    Value = sClassDescription
    SectionKey = sClassName & "\shell\open\command"
    ValueKey = sExePath & " ""%1"""
    If lDefaultIconIndex > -1 Then
        SectionKey = sClassName & "\DefaultIcon"
        ValueKey = ""
        Value = sExePath & "," & CStr(lDefaultIconIndex)
    End If
   
End Sub
Public Property Get ValueType() As ERegistryValueTypes
    ValueType = m_eValueType
End Property
Public Property Let ValueType(ByVal eValueType As ERegistryValueTypes)
    m_eValueType = eValueType
End Property
Public Property Get ClassKey() As ERegistryClassConstants
    ClassKey = m_hClassKey
End Property
Public Property Let ClassKey( _
        ByVal eKey As ERegistryClassConstants _
    )
    m_hClassKey = eKey
End Property
Public Property Get SectionKey() As String
    SectionKey = m_sSectionKey
End Property
Public Property Let SectionKey( _
        ByVal sSectionKey As String _
    )
    m_sSectionKey = sSectionKey
End Property
Public Property Get ValueKey() As String
    ValueKey = m_sValueKey
End Property
Public Property Let ValueKey( _
        ByVal sValueKey As String _
    )
    m_sValueKey = sValueKey
End Property
Public Property Get Default() As Variant
    Default = m_vDefault
End Property
Public Property Let Default( _
        ByVal vDefault As Variant _
    )
    m_vDefault = vDefault
End Property
Private Function SwapEndian(ByVal dw As Long) As Long
    CopyMemory ByVal VarPtr(SwapEndian) + 3, dw, 1
    CopyMemory ByVal VarPtr(SwapEndian) + 2, ByVal VarPtr(dw) + 1, 1
    CopyMemory ByVal VarPtr(SwapEndian) + 1, ByVal VarPtr(dw) + 2, 1
    CopyMemory SwapEndian, ByVal VarPtr(dw) + 3, 1
End Function
Private Function ExpandEnvStr(sData As String) As String
    Dim c As Long, s As String
    ' Get the length
    s = "" ' Needed to get around Windows 95 limitation
    c = ExpandEnvironmentStrings(sData, s, c)
    ' Expand the string
    s = String$(c - 1, 0)
    c = ExpandEnvironmentStrings(sData, s, c)
    ExpandEnvStr = s
End Function
0
 

Author Comment

by:gcheatham
ID: 18862208
What would be the appropriate way to handle this question - since it is a multi-day project, would I split it up over several more questions, or if it too big a question to be asking on this site, and should I simply hire the remaining coding out?  Let me know.  Meanwhile, I am awarding the points to you.
0
 
LVL 22

Expert Comment

by:danaseaman
ID: 18862541
You could try http://www.rentacoder.com/RentACoder/default.asp where you should be able to find someone that can do this for a reasonable fee.
0
 
LVL 22

Expert Comment

by:danaseaman
ID: 18862692
BTW you can get TlbInf32.chm at:
http://download.microsoft.com/download/vstudio60pro/doc/1/WIN98/EN-US/Tlbinf32.exe
Note that this .exe contains only the zipped Tlbinf32.chm file, which was last modified October, 1998.
0
 
LVL 22

Expert Comment

by:danaseaman
ID: 18876400
This only works in the IDE but I think it comes close to what you are looking for:

'In Form
Option Explicit

Private Sub Form_Load()
   With ListView1
      .ColumnHeaders.Add , , "Object"
      .ColumnHeaders.Add , , "Property Let"
      .ColumnHeaders.Add , , "VarType"
      .ColumnHeaders.Add , , "Range", 4500
      .ColumnHeaders.Add , , "Member"
      .ColumnHeaders.Add , , "Value"
   End With

   Dim ctl              As Control
   For Each ctl In Me.Controls
      EnumPropertiesIDE ListView1, ctl
   Next
End Sub

'In Module
Option Explicit

'This works in IDE only
Public Sub EnumPropertiesIDE(LV As ListView, oObj As Object)

   Dim TLInfo           As TLI.InterfaceInfo
   Dim SR               As TLI.SearchResults
   Dim SI               As TLI.SearchItem
   Dim TLIMemInfo       As TLI.MemberInfo
   Dim oTLI             As TLI.TypeLibInfo

   Dim item             As ListItem
   Dim oCol             As Collection
   Dim sEnum            As String
   Dim i                As Long

   On Error Resume Next

   Set TLInfo = TLI.InterfaceInfoFromObject(oObj)
   
   Set oTLI = TLInfo.Parent

   Set SR = TLInfo.Members.GetFilteredMembers(False)

   For Each SI In SR  'loop through attribute members of the object
      If (SI.InvokeKinds And INVOKE_PROPERTYPUT) = INVOKE_PROPERTYPUT Then
         Set TLIMemInfo = TLInfo.GetMember(SI.MemberId)
         Set item = LV.ListItems.Add(, , pGetControlId(oObj))
         item.SubItems(1) = SI.Name
         item.SubItems(2) = TLIMemInfo.ReturnType & " - " & TypeToString(TLIMemInfo.ReturnType)
         Set oCol = GetEnumNames(oTLI, TypeToString(TLIMemInfo.ReturnType))
         If Not oCol Is Nothing Then 'is it an enum?
            sEnum = ""
            For i = 1 To oCol.Count
               sEnum = sEnum & oCol.item(i) & ", "
            Next
            item.SubItems(3) = sEnum
         Else
            item.SubItems(3) = TypeToRange(TLIMemInfo.ReturnType)
         End If
      End If
   Next

ErrorHandler:
   Set TLInfo = Nothing
   Set oTLI = Nothing
End Sub

' Function returns control's name & control's index combination
Private Function pGetControlId(ByRef oCtl As Control) As String
  On Error Resume Next
 
  Dim sCtlName As String
  Dim iCtlIndex As Integer
 
  iCtlIndex = -1
 
  sCtlName = oCtl.Name
  iCtlIndex = oCtl.Index
  If iCtlIndex = -1 Then
     pGetControlId = sCtlName
  Else
     pGetControlId = sCtlName & "(" & iCtlIndex & ")"
  End If
 
End Function

Public Function GetEnumNames(oTLI As TypeLibInfo, _
   ByVal EnumName As String) As Collection
   
   Dim oTL              As TypeInfo
   Dim oTLMember        As MemberInfo
   Dim col              As Collection
   
   On Error GoTo Error_GetEnumName
   Set col = New Collection
   For Each oTL In oTLI.TypeInfos
      If oTL.TypeKind = TKIND_ENUM And oTL.Name = EnumName Then
         'Add Names and Values to colelction
         For Each oTLMember In oTL.Members
            col.Add oTLMember.Name & " = " & oTLMember.Value
         Next oTLMember
      End If
   Next oTL
   If col.Count Then
      Set GetEnumNames = col
   End If
   Set col = Nothing
   Exit Function

Error_GetEnumName:

   Debug.Print "Error " & Err.Number & " " & Err.Description
   
End Function

Private Function TypeToString(rType As Object, Optional Normalize As Boolean = False) As String
   Dim st               As String, rt As Long, udrt As Object, IsArr As Boolean
   rt = rType.VarType

   If (rt And VT_ARRAY) = VT_ARRAY Then
      st = "Array("
      IsArr = True
      rt = rt - VT_ARRAY
   End If
   Select Case rt
      Case vbEmpty      ' Empty (uninitialized)
         'st = st + "Empty"
         st = st + rType.TypeInfo.Name
      Case vbNull       ' Null (no valid data)
         st = st + "Null"
      Case vbInteger    ' Integer
         st = st + "Integer"
      Case vbLong       ' Long integer
         st = st + "Long"
      Case vbSingle     ' Single-precision floating-point number
         st = st + "Single"
      Case vbDouble     ' Double-precision floating-point number
         st = st + "Double"
      Case vbCurrency   ' Currency value
         st = st + "Currency"
      Case vbDate       ' Date value
         st = st + "Date"
      Case vbString     ' String
         st = st + "String"
      Case vbObject     ' Object
         st = st + "Object"
      Case vbError      ' Error value
         st = st + "Error"
      Case vbBoolean    ' Boolean value
         st = st + "Boolean"
      Case vbVariant    ' Variant (used only with arrays of variants)
         st = st + "Variant"
      Case vbDataObject ' A data access object
         st = st + "DataObject"
      Case vbDecimal    ' Decimal value
         st = st + "Decimal"
      Case vbByte       ' Byte value
         st = st + "Byte"
      Case vbArray      ' Array
         st = st + "Array"
      Case VT_VOID
         st = st
      Case VT_PTR
         st = st + TypeToString(rType.PointerDesc)
      Case VT_USERDEFINED
         Set udrt = rType.UserDefinedDesc
         st = st + udrt.Name
      Case VT_I1                    ' signed char
         st = st + "*signed char*"
      Case VT_UI1                   ' unsigned char
         st = st + "*unsigned char*"
      Case VT_UI2                   ' unsigned short
         st = st + "*signed short*"
      Case VT_UI4                   ' unsigned short
         'st = st + "*unsigned short*"
         st = st + "OLE_COLOR"
      Case VT_I8                    ' signed 64-bit int
         st = st + "*signed 64-bit int*"
      Case VT_UI8                   ' unsigned 64-bit int
         st = st + "*unsigned 64-bit int*"
      Case VT_INT                   ' signed machine int
         st = st + "*signed machine int*"
      Case VT_UINT                  ' unsigned machine int
         st = st + "*unsigned machine int*"
      Case VT_HRESULT               '
         st = st + "*HRESULT*"
      Case VT_SAFEARRAY             ' (use VT_ARRAY in VARIANT)
         st = st + "*SAFEARRAY*"
      Case VT_CARRAY                ' C style array
         st = st + "*C style array*"
      Case VT_LPSTR                 ' null terminated string
         st = st + "*LPSTR*"
      Case VT_LPWSTR                ' wide null terminated string
         st = st + "*LPWSTR*"
      Case Else
         st = st + "*Unknown* (&H" & Hex(rt) & ")"
   End Select
   If IsArr Then st = st + ")"
   If Normalize Then st = TypeStrNormalized(st)
   TypeToString = st
End Function

Private Function TypeStrNormalized(sType As String) As String
   If Left$(sType, 1) = "*" And Right$(sType, 1) = "*" Then
      TypeStrNormalized = "<?>"
   Else
      TypeStrNormalized = sType
   End If
End Function

Private Function TypeToRange(rType As Object, Optional Normalize As Boolean = False) As String
   Dim st               As String, rt As Long, udrt As Object, IsArr As Boolean
   rt = rType.VarType

   If (rt And VT_ARRAY) = VT_ARRAY Then
      st = "Array("
      IsArr = True
      rt = rt - VT_ARRAY
   End If
   Select Case rt
      Case vbEmpty      ' Empty (uninitialized)
         'st = st + "Empty"
         st = st + rType.TypeInfo.Name
      Case vbNull       ' Null (no valid data)
         st = st + "Null"
      Case vbInteger    ' Integer
         'st = st + "Integer"
         st = st + "-32,768 to 32,767"
      Case vbLong       ' Long integer
         st = st + "-2,147,483,648 to 2,147,483,647"
      Case vbSingle     ' Single-precision floating-point number
         st = st + "1.401298e-45 to 3.402823e38"
      Case vbDouble     ' Double-precision floating-point number
         st = st + "4.94065645841247e-324 to 1.79769313486232e308"
      Case vbCurrency   ' Currency value
         st = st + "Currency"
      Case vbDate       ' Date value
         st = st + "Date"
      Case vbString     ' String
         st = st + "String"
      Case vbObject     ' Object
         st = st + "Object"
      Case vbError      ' Error value
         st = st + "Error"
      Case vbBoolean    ' Boolean value
         st = st + "True (-1) or False (0)"
      Case vbVariant    ' Variant (used only with arrays of variants)
         st = st + "Variant"
      Case vbDataObject ' A data access object
         st = st + "DataObject"
      Case vbDecimal    ' Decimal value
         st = st + "Decimal"
      Case vbByte       ' Byte value
         st = st + "0 to 255"
      Case vbArray      ' Array
         st = st + "Array"
      Case VT_VOID
         st = st
      Case VT_PTR
         st = st + TypeToString(rType.PointerDesc)
      Case VT_USERDEFINED
         Set udrt = rType.UserDefinedDesc
         st = st + udrt.Name
      Case VT_I1                    ' signed char
         st = st + "*signed char*"
      Case VT_UI1                   ' unsigned char
         st = st + "*unsigned char*"
      Case VT_UI2                   ' unsigned short
         st = st + "*signed short*"
      Case VT_UI4                   ' unsigned short
         'st = st + "*unsigned short*"
         st = st + "0 to 16777215, SysColors &H80000000 to &H80000018"
      Case VT_I8                    ' signed 64-bit int
         st = st + "*signed 64-bit int*"
      Case VT_UI8                   ' unsigned 64-bit int
         st = st + "*unsigned 64-bit int*"
      Case VT_INT                   ' signed machine int
         st = st + "*signed machine int*"
      Case VT_UINT                  ' unsigned machine int
         st = st + "*unsigned machine int*"
      Case VT_HRESULT               '
         st = st + "*HRESULT*"
      Case VT_SAFEARRAY             ' (use VT_ARRAY in VARIANT)
         st = st + "*SAFEARRAY*"
      Case VT_CARRAY                ' C style array
         st = st + "*C style array*"
      Case VT_LPSTR                 ' null terminated string
         st = st + "*LPSTR*"
      Case VT_LPWSTR                ' wide null terminated string
         st = st + "*LPWSTR*"
      Case Else
         st = st + "*Unknown* (&H" & Hex(rt) & ")"
   End Select
   If IsArr Then st = st + ")"
   If Normalize Then st = TypeStrNormalized(st)
   TypeToRange = st
End Function


0

Featured Post

Maximize Your Threat Intelligence Reporting

Reporting is one of the most important and least talked about aspects of a world-class threat intelligence program. Here’s how to do it right.

Join & Write a Comment

In a multiple monitor setup, if you don't want to use AutoCenter to position your popup forms, you have a problem: where will they appear?  Sometimes you may have an additional problem: where the devil did they go?  If you last had a popup form open…
You can of course define an array to hold data that is of a particular type like an array of Strings to hold customer names or an array of Doubles to hold customer sales, but what do you do if you want to coordinate that data? This article describes…
Familiarize people with the process of utilizing SQL Server functions from within Microsoft Access. Microsoft Access is a very powerful client/server development tool. One of the SQL Server objects that you can interact with from within Microsoft Ac…
Basics of query design. Shows you how to construct a simple query by adding tables, perform joins, defining output columns, perform sorting, and apply criteria.

747 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

14 Experts available now in Live!

Get 1:1 Help Now