Binaryworld - SaveRegToFile - Save a registry subkey to a .reg file ... [ VB -> Windows ]

Private Const HKEY_CLASSES_ROOT = &H80000000
Private Const HKEY_CURRENT_CONFIG = &H80000005
Private Const HKEY_CURRENT_USER = &H80000001
Private Const HKEY_LOCAL_MACHINE = &H80000002
Private Const HKEY_USERS = &H80000003

'Save the specified registry's key and (optionally) its subkeys to a REG file
' that can be loaded later
' - hKey is the root key
' - sKeyName is the key to save to the file
' - sRegFile is the target file where the text will be saved
' - bIncludeSubKeys specifies whether the routine will save also the subkeys
' - bAppendToFile specifies wheter the generated text will be appended to an
' existent file
'Example:
' SaveRegToFile HKEY_CURRENT_USER, "Software\Microsoft\Visual Basic\6.0",
' "C:\vb6.reg"

'NOTE: this routine requires EnumRegistryKeys and EnumRegistryValuesEx

Sub SaveRegToFile(ByVal hKey As Long, ByVal sKeyName As String, _
  ByVal sRegFile As String, Optional ByVal bIncludeSubKeys As Boolean = True, _
  Optional ByVal bAppendToFile As Boolean = False)

  Dim handle As Integer
  Dim sFirstKeyPart As String
  Dim col As New Collection
  Dim regItem As Variant
  Dim sText As String
  Dim sQuote As String
  Dim sTemp As String
  Dim sHex As String
  Dim i As Long
  Dim vValue As Variant
  Dim iPointer As MousePointerConstants
  Dim sValueName As String

  sQuote = Chr$(34)

  On Error Resume Next

  'conver the hKey value to the descriptive string
  Select Case hKey
    Case HKEY_CLASSES_ROOT: sFirstKeyPart = "HKEY_CLASSES_ROOT\"
    Case HKEY_CURRENT_CONFIG: sFirstKeyPart = "HKEY_CURRENT_CONFIG\"
    Case HKEY_CURRENT_USER: sFirstKeyPart = "HKEY_CURRENT_USER\"
    Case HKEY_LOCAL_MACHINE: sFirstKeyPart = "HKEY_LOCAL_MACHINE\"
    Case HKEY_USERS: sFirstKeyPart = "HKEY_USERS\"
  End Select

  'this can be a long operation
  iPointer = Screen.MousePointer
  Screen.MousePointer = vbHourglass

  'if the text won't be appended, add the "REGEDIT4" header
  If bAppendToFile = False Then
    sText = "REGEDIT4" & vbCrLf & vbCrLf
  Else
    'add the same header if the text will be appended to an
    'existent file that does not contain the header.
    ' This works only if the file exists but is empty.
    handle = FreeFile
    Open sRegFile For Binary As #handle
    ' read the string and close the file
    sTemp = Space$(LOF(handle))
    Get #handle, , sTemp
    Close #handle
    'if not found, add it
    If InStr(1, sTemp, "REGEDIT4") = 0 Then
      sText = "REGEDIT4" & vbCrLf & vbCrLf
    End If
  End If

  'save the key name with the format [keyname]
  sText = sText & "[" & sFirstKeyPart & sKeyName & "]" & vbCrLf

  'get the collection with all the values under this key
  Set col = EnumRegistryValuesEx(hKey, sKeyName)
  For Each regItem In col
    vValue = regItem(1)
    Select Case regItem(2)
      Case vbString
        'if the value is a string, check if it's a path by looking if
        ' the 3 characters
        'are in the form X:\. If so, replace a single "\" with "\\"
        If Left$(vValue, 3) Like "[A-Z,a-z]:\" Then vValue = Replace _
          (vValue, "\", "\\")
        'quote it
        sTemp = sQuote & vValue & sQuote
      Case vbLong
        'if it's a long, save it with the format dword:num
        sTemp = "dword:" & CLng(vValue)
      Case vbArray + vbByte
        'if it's an array of bytes, save it with the format hex:num1,
        ' num2,num3,...
        sTemp = "hex:"
        For i = 0 To UBound(vValue)
          sHex = Hex$(vValue(i))
          'convert from long to hex
          If Len(sHex) < 2 Then sHex = "0" & sHex
          sTemp = sTemp & sHex & ","
        Next
        'remove the last comma
        sTemp = Left$(sTemp, Len(sTemp) - 1)
      Case Else
        sTemp = ""
    End Select
    'get the value name: if the string is empty, take @,
    ' else take that name and quote it
    sValueName = IIf(Len(regItem(0)) > 0, sQuote & regItem(0) & sQuote, "@")
    'save this line to the temporary text that will be saved
    sText = sText & sValueName & "=" & sTemp & vbCrLf
  Next
  sText = sText & vbCrLf

  handle = FreeFile
  'open the target file with Append or Output mode,
  ' according to the bAppendToFile parameter
  If bAppendToFile Then
    Open sRegFile For Append As #handle
  Else
    Open sRegFile For Output As #handle
  End If
  'save the text
  Print #handle, sText;
  Close #handle

  'call recursively this routine to save all the subkeys,
  ' if the bIncludeSubKeys param is true
  If bIncludeSubKeys Then
    Set col = EnumRegistryKeys(hKey, sKeyName)
    For Each regItem In col
      'note: the text will be added to the file just created for the
      'values in the root key
      SaveRegToFile hKey, sKeyName & "\" & regItem, sRegFile, True, True
    Next
  End If

  Screen.MousePointer = iPointer

End Sub