The Registry Class - You will Learn to Love it
The dad gum forum won't let me post this whole class at once, so I will do it piece by piece until I get it all.
Registry Class (Part III)
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
Private Sub pSetClassValue(ByVal sValue As String)
Dim sSection As String
ClassKey = HKEY_CLASSES_ROOT
Value = sValue
sSection = SectionKey
ClassKey = HKEY_LOCAL_MACHINE
SectionKey = "SOFTWARE\Classes\" & sSection
Value = sValue
SectionKey = sSection
End Sub
Public Sub CreateEXEAssociation( _
ByVal sExePath As String, _
ByVal sClassName As String, _
ByVal sClassDescription As String, _
ByVal sAssociation As String, _
Optional ByVal sOpenMenuText As String = "&Open", _
Optional ByVal bSupportPrint As Boolean = False, _
Optional ByVal sPrintMenuText As String = "&Print", _
Optional ByVal bSupportNew As Boolean = False, _
Optional ByVal sNewMenuText As String = "&New", _
Optional ByVal bSupportInstall As Boolean = False, _
Optional ByVal sInstallMenuText As String = "", _
Optional ByVal lDefaultIconIndex As Long = -1 _
)
' Check if path is wrapped in quotes:
sExePath = Trim$(sExePath)
If (Left$(sExePath, 1) <> """") Then
sExePath = """" & sExePath
End If
If (Right$(sExePath, 1) <> """") Then
sExePath = sExePath & """"
End If
' Create the .File to Class association:
SectionKey = "." & sAssociation
ValueType = REG_SZ
ValueKey = ""
pSetClassValue sClassName
' Create the Class shell open command:
SectionKey = sClassName
pSetClassValue sClassDescription
SectionKey = sClassName & "\shell\open"
If (sOpenMenuText = "") Then sOpenMenuText = "&Open"
ValueKey = ""
pSetClassValue sOpenMenuText
SectionKey = sClassName & "\shell\open\command"
ValueKey = ""
pSetClassValue sExePath & " ""%1"""
If (bSupportPrint) Then
SectionKey = sClassName & "\shell\print"
If (sPrintMenuText = "") Then sPrintMenuText = "&Print"
ValueKey = ""
pSetClassValue sPrintMenuText
SectionKey = sClassName & "\shell\print\command"
ValueKey = ""
pSetClassValue sExePath & " /p ""%1"""
End If
If (bSupportInstall) Then
If (sInstallMenuText = "") Then
sInstallMenuText = "&Install " & sAssociation
End If
SectionKey = sClassName & "\shell\add"
ValueKey = ""
pSetClassValue sInstallMenuText
SectionKey = sClassName & "\shell\add\command"
ValueKey = ""
pSetClassValue sExePath & " /a ""%1"""
End If
If (bSupportNew) Then
SectionKey = sClassName & "\shell\new"
ValueKey = ""
If (sNewMenuText = "") Then sNewMenuText = "&New"
pSetClassValue sNewMenuText
SectionKey = sClassName & "\shell\new\command"
ValueKey = ""
pSetClassValue sExePath & " /n ""%1"""
End If
If lDefaultIconIndex > -1 Then
SectionKey = sClassName & "\DefaultIcon"
ValueKey = ""
pSetClassValue sExePath & "," & CStr(lDefaultIconIndex)
End If
End Sub
Public Sub CreateAdditionalEXEAssociations( _
ByVal sClassName As String, _
ParamArray vItems() As Variant _
)
Dim iItems As Long
Dim iItem As Long
On Error Resume Next
iItems = UBound(vItems) + 1
If (iItems Mod 3) <> 0 Or (Err.Number <> 0) Then
Err.Raise vbObjectError + 1048 + 26004, App.EXEName & ".cRegistry", "Invalid parameter list passed to CreateAdditionalEXEAssociations - expected Name/Text/Command"
Else
' Check if it exists:
SectionKey = sClassName
If Not (KeyExists) Then
Err.Raise vbObjectError + 1048 + 26005, App.EXEName & ".cRegistry", "Error - attempt to create additional associations before class defined."
Else
For iItem = 0 To iItems - 1 Step 3
ValueType = REG_SZ
SectionKey = sClassName & "\shell\" & vItems(iItem)
ValueKey = ""
pSetClassValue vItems(iItem + 1)
SectionKey = sClassName & "\shell\" & vItems(iItem) & "\command"
ValueKey = ""
pSetClassValue vItems(iItem + 2)
Next iItem
End If
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