cRegistry Class (6K)
VB5 Registry Editor Demonstration (59K)
VB6 Registry Editor Demonstration (52K)
Bugs: 0 / 1
Issues: 1 / 2
Questions: 0 / 0
23 Jan 2004
Added remote registry connection through the Machine. Many thanks to Yaron Lavi for providing the code.
Fixed problem with saving zero length strings. Thanks to Shane Marsden for providing the fix.
Fixed problem with truncation of binary data. Thanks to Morten Egelund Rasmussen (and many others!) for providing the fix.
vbAccelerator - Contents of code file: fTestReg.frm
VERSION 5.00
Object = "{6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.3#0"; "COMCTL32.OCX"
Begin VB.Form frmRegEdit
Caption = "vbAccelerator VB Registry Editor"
ClientHeight = 5895
ClientLeft = 4710
ClientTop = 3090
ClientWidth = 6720
Icon = "fTestReg.frx":0000
LinkTopic = "Form1"
ScaleHeight = 5895
ScaleWidth = 6720
Begin ComctlLib.StatusBar sbrMain
Align = 2 'Align Bottom
Height = 315
Left = 0
TabIndex = 3
Top = 5580
Width = 6720
_ExtentX = 11853
_ExtentY = 556
SimpleText = ""
_Version = 327682
BeginProperty Panels {0713E89E-850A-101B-AFC0-4210102A8DA7}
NumPanels = 1
BeginProperty Panel1 {0713E89F-850A-101B-AFC0-4210102A8DA7}
AutoSize = 1
Object.Width = 11430
TextSave = ""
Key = ""
Object.Tag = ""
EndProperty
EndProperty
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
End
Begin VB.PictureBox picSplitter
Height = 5595
Left = 2700
ScaleHeight = 5535
ScaleWidth = 15
TabIndex = 2
Top = 0
Width = 75
End
Begin ComctlLib.ListView lvwReg
Height = 4815
Left = 2760
TabIndex = 1
Top = 0
Width = 3915
_ExtentX = 6906
_ExtentY = 8493
LabelWrap = -1 'True
HideSelection = 0 'False
_Version = 327682
ForeColor = -2147483640
BackColor = -2147483643
BorderStyle = 1
Appearance = 1
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
NumItems = 0
End
Begin ComctlLib.TreeView tvwReg
Height = 4815
Left = 60
TabIndex = 0
Top = 0
Width = 2595
_ExtentX = 4577
_ExtentY = 8493
_Version = 327682
HideSelection = 0 'False
Indentation = 441
LineStyle = 1
Sorted = -1 'True
Style = 7
Appearance = 1
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
End
Begin ComctlLib.ImageList ilsIcons
Left = 5700
Top = 4980
_ExtentX = 1005
_ExtentY = 1005
BackColor = -2147483643
ImageWidth = 16
ImageHeight = 16
MaskColor = 12632256
_Version = 327682
BeginProperty Images {0713E8C2-850A-101B-AFC0-4210102A8DA7}
NumListImages = 3
BeginProperty ListImage1 {0713E8C3-850A-101B-AFC0-4210102A8DA7}
Picture = "fTestReg.frx":014A
Key = "OPENFOLDER"
EndProperty
BeginProperty ListImage2 {0713E8C3-850A-101B-AFC0-4210102A8DA7}
Picture = "fTestReg.frx":0464
Key = "DATAITEM"
EndProperty
BeginProperty ListImage3 {0713E8C3-850A-101B-AFC0-4210102A8DA7}
Picture = "fTestReg.frx":077E
Key = "CLOSEDFOLDER"
EndProperty
EndProperty
End
Begin VB.Menu mnuFileTOP
Caption = "&File"
Begin VB.Menu mnuFile
Caption = "&Print"
Index = 0
End
Begin VB.Menu mnuFile
Caption = "-"
Index = 1
End
Begin VB.Menu mnuFile
Caption = "E&xit"
Index = 2
End
End
Begin VB.Menu mnuEditTOP
Caption = "&Edit"
Begin VB.Menu mnuEdit
Caption = "&New..."
Index = 0
Shortcut = ^N
End
Begin VB.Menu mnuEdit
Caption = "-"
Index = 1
End
Begin VB.Menu mnuEdit
Caption = "&Modify..."
Index = 2
End
Begin VB.Menu mnuEdit
Caption = "&Delete..."
Index = 3
End
Begin VB.Menu mnuEdit
Caption = "-"
Index = 4
End
Begin VB.Menu mnuEdit
Caption = "&Find..."
Index = 5
Shortcut = ^F
End
End
Begin VB.Menu mnuViewTOP
Caption = "&View"
Begin VB.Menu mnuView
Caption = "&Status Bar"
Checked = -1 'True
Index = 0
End
Begin VB.Menu mnuView
Caption = "-"
Index = 1
End
Begin VB.Menu mnuView
Caption = "&Refresh"
Index = 2
Shortcut = {F5}
End
End
Begin VB.Menu mnuHelpTOP
Caption = "&Help"
Begin VB.Menu mnuHelp
Caption = "&About..."
Index = 0
End
End
End
Attribute VB_Name = "frmRegEdit"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private WithEvents m_cSplit As cSplitter
Attribute m_cSplit.VB_VarHelpID = -1
Private cReg As New cRegistry
Private Sub Form_Load()
Dim nodX As Node
Set m_cSplit = New cSplitter
m_cSplit.Initialise picSplitter, Me
tvwReg.ImageList = ilsIcons
Set nodX = tvwReg.Nodes.Add(, , "K" & HKEY_CLASSES_ROOT,
"HKEY_CLASSES_ROOT", "CLOSEDFOLDER")
tvwReg.Nodes.Add nodX, tvwChild, , "Unexpanded"
Set nodX = tvwReg.Nodes.Add(, , "K" & HKEY_CURRENT_USER,
"HKEY_CURRENT_USER", "CLOSEDFOLDER")
tvwReg.Nodes.Add nodX, tvwChild, , "Unexpanded"
Set nodX = tvwReg.Nodes.Add(, , "K" & HKEY_LOCAL_MACHINE,
"HKEY_LOCAL_MACHINE", "CLOSEDFOLDER")
tvwReg.Nodes.Add nodX, tvwChild, , "Unexpanded"
Set nodX = tvwReg.Nodes.Add(, , "K" & HKEY_USERS, "HKEY_USERS",
"CLOSEDFOLDER")
tvwReg.Nodes.Add nodX, tvwChild, , "Unexpanded"
lvwReg.SmallIcons = ilsIcons
lvwReg.ColumnHeaders.Add , , "Key"
lvwReg.ColumnHeaders.Add , , "Value"
lvwReg.View = lvwReport
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y
As Single)
m_cSplit.MouseMove X
End Sub
Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As
Single)
m_cSplit.MouseUp X
End Sub
Private Sub Form_Resize()
Dim lM As Long
Dim lL As Long
Dim lH As Long
On Error Resume Next
' Do resize
With tvwReg
lH = Me.ScaleHeight - .Top * 2 - sbrMain.Height * -1 * sbrMain.Visible
lM = picSplitter.Left - 2 * Screen.TwipsPerPixelX
.Move .Left, .Top, lM, lH
lL = lM + picSplitter.Width + 2 * Screen.TwipsPerPixelX
lvwReg.Move lL, .Top, Me.ScaleWidth - lL - 4 * Screen.TwipsPerPixelX, lH
End With
With picSplitter
.Move .Left, tvwReg.Top, .Width, lH
End With
End Sub
Private Sub lvwReg_ColumnClick(ByVal ColumnHeader As ComctlLib.ColumnHeader)
Dim i As Long
For i = 1 To lvwReg.ColumnHeaders.Count
If (i <> ColumnHeader.Index) Then
lvwReg.ColumnHeaders(i).Tag = ""
End If
Next i
If ColumnHeader.Tag = "ASC" Then
ColumnHeader.Tag = "DESC"
lvwReg.SortOrder = lvwDescending
Else
ColumnHeader.Tag = "ASC"
lvwReg.SortOrder = lvwAscending
End If
lvwReg.SortKey = ColumnHeader.Index - 1
lvwReg.Sorted = True
End Sub
Private Sub lvwReg_DblClick()
mnuEdit_Click 2
End Sub
Private Sub m_cSplit_DoSplit(bSplit As Boolean)
' Can cancell split here
End Sub
Private Sub m_cSplit_SplitComplete()
Form_Resize
End Sub
Private Sub pGetSectionClassKey(ByRef sP As String, ByRef sK As String, ByRef l
As Long)
Dim nodX As Node
Dim iPos As Long
With tvwReg
If (InStr(.SelectedItem.Key, ",") = 0) Then
' We are at a class key:
sP = ""
sK = ""
l = CLng(Mid$(.SelectedItem.Key, 2))
Else
' We are at a sub key:
sK = tvwReg.SelectedItem.Key
iPos = InStr(sK, ",")
l = CLng(Mid$(.SelectedItem.Key, 2, (iPos - 2)))
sK = .SelectedItem.Text
Set nodX = .SelectedItem.Parent
Do While Not (nodX Is Nothing)
If (InStr(nodX.Key, ",") <> 0) Then
sP = nodX.Text & "\" & sP
End If
Set nodX = nodX.Parent
Loop
If (Len(sP) > 0) Then
sP = Left$(sP, Len(sP) - 1)
End If
End If
End With
End Sub
Private Function Normalize(ByVal sParent As String, ByVal sKey As String) As
String
' this wouldn't usually be required as you don't tend to create keys under
' the HKEY_CLASSES_* sections (ie. sectionkey = ""):
If (Trim$(sParent) = "") Then
Normalize = sKey
Else
Normalize = Trim$(sParent) & "\" & sKey
End If
End Function
Private Sub mnuEdit_Click(Index As Integer)
Dim sK As String
Dim sParent As String
Dim sTHisKey As String
Dim iPos As Long
Dim f As New fNewItem
Dim lClassKey As Long
Select Case Index
Case 0
' New:
pGetSectionClassKey sParent, sTHisKey, lClassKey
f.mode = eNew
If (sParent <> "") Then
f.Parent = sParent & "\" & sTHisKey
Else
f.Parent = sTHisKey
End If
f.Show vbModal, Me
If Not (f.Cancelled) Then
If (f.ItemType = 0) Then
cReg.ClassKey = lClassKey
cReg.SectionKey = Normalize(f.Parent, f.ItemName)
cReg.CreateKey
Else
cReg.ClassKey = lClassKey
cReg.SectionKey = f.Parent
cReg.ValueKey = f.ItemName
If (f.ItemValueType = 0) Then
cReg.ValueType = REG_SZ
cReg.Value = f.ItemValue
ElseIf (f.ItemValueType = 1) Then
cReg.ValueType = REG_DWORD
cReg.Value = CLng(f.ItemValue)
Else
cReg.ValueType = REG_BINARY
cReg.Value = f.ItemValue
'MsgBox "Sorry, entering BINARY values is not supported by
this demo. An example of binary writing is provided in
the TestBinary sub.", vbInformation
End If
End If
' Refresh:
tvwReg.SelectedItem.Expanded = False
tvwReg_Collapse tvwReg.SelectedItem
If (tvwReg.SelectedItem.Children = 0) Then
tvwReg.Nodes.Add tvwReg.SelectedItem, tvwChild, , "Unexpanded"
End If
mnuView_Click 2
End If
Case 2
' update
pGetSectionClassKey sParent, sTHisKey, lClassKey
f.mode = eUpdate
If Not (lvwReg.SelectedItem Is Nothing) Then
' Modifying a value:
f.Parent = Normalize(sParent, sTHisKey)
f.ItemName = lvwReg.SelectedItem.Text
f.ItemValue = lvwReg.SelectedItem.SubItems(1)
f.ItemType = 1
f.ItemValueType = CLng(lvwReg.SelectedItem.Tag)
f.Show vbModal
If Not (f.Cancelled) Then
cReg.ClassKey = lClassKey
cReg.SectionKey = f.Parent
If (lvwReg.SelectedItem.Text <> f.ItemName) Then
' Delete the existing value:
cReg.ValueKey = lvwReg.SelectedItem.Text
cReg.DeleteValue
End If
cReg.ValueKey = f.ItemName
If (f.ItemValueType = 0) Then
cReg.ValueType = REG_SZ
cReg.Value = f.ItemValue
ElseIf (f.ItemValueType = 1) Then
cReg.ValueType = REG_DWORD
cReg.Value = CLng(f.ItemValue)
Else
cReg.ValueType = REG_BINARY
cReg.Value = f.ItemValue
'MsgBox "Sorry, entering BINARY values is not supported by
this demo. An example of binary writing is provided in
the TestBinary sub.", vbInformation
End If
End If
' Refresh:
tvwReg_NodeClick tvwReg.SelectedItem
Else
' Modifying a key:
If (vbOK = MsgBox("Warning: In this sample, renaming a key will
delete all its contents. Ok to continue?", vbOKCancel Or
vbExclamation Or vbDefaultButton2)) Then
f.Parent = sParent
f.ItemName = sTHisKey
f.ItemType = 0
f.Show vbModal, Me
If Not (f.Cancelled) Then
cReg.ClassKey = lClassKey
' Delete the original key:
cReg.SectionKey = Normalize(f.Parent, sTHisKey)
cReg.DeleteKey
' Rename
cReg.SectionKey = Normalize(f.Parent, f.ItemName)
cReg.CreateKey
' Refresh:
tvwReg.SelectedItem.Parent.Expanded = False
tvwReg_Collapse tvwReg.SelectedItem.Parent
If (tvwReg.SelectedItem.Parent.Children = 0) Then
tvwReg.Nodes.Add tvwReg.SelectedItem.Parent, tvwChild,
, "Unexpanded"
End If
End If
End If
End If
Case 3
' delete
pGetSectionClassKey sParent, sTHisKey, lClassKey
If Not (lvwReg.SelectedItem Is Nothing) Then
If (vbYes = MsgBox("Are you sure you want to delete the value '" &
lvwReg.SelectedItem.Text & "'?", vbYesNo Or vbQuestion)) Then
cReg.SectionKey = Normalize(sParent, sTHisKey)
cReg.ValueKey = lvwReg.SelectedItem.Text
cReg.DeleteValue
' Refresh:
tvwReg.SelectedItem.Expanded = False
tvwReg_Collapse tvwReg.SelectedItem
If (tvwReg.SelectedItem.Children = 0) Then
tvwReg.Nodes.Add tvwReg.SelectedItem, tvwChild, ,
"Unexpanded"
End If
mnuView_Click 2
End If
Else
If (vbYes = MsgBox("Are you sure you want to delete the key '" &
tvwReg.SelectedItem.Text & "'?", vbYesNo Or vbQuestion)) Then
cReg.SectionKey = Normalize(sParent, sTHisKey)
cReg.DeleteKey
' Refresh:
tvwReg.SelectedItem.Expanded = False
tvwReg_Collapse tvwReg.SelectedItem
If (tvwReg.SelectedItem.Children = 0) Then
tvwReg.Nodes.Add tvwReg.SelectedItem, tvwChild, ,
"Unexpanded"
End If
mnuView_Click 2
End If
End If
Case 5
' find:
MsgBox "Find: Left as an exercise...", vbInformation
End Select
End Sub
Private Sub mnuEditTOP_Click()
Dim bDisableEdit As Boolean
Dim iPos As Long
Dim sKey As String
If (lvwReg.SelectedItem Is Nothing) Then
If (tvwReg.SelectedItem Is Nothing) Then
bDisableEdit = True
Else
sKey = tvwReg.SelectedItem.Key
iPos = InStr(sKey, ",")
If (iPos = 0) Then
bDisableEdit = True
End If
End If
End If
mnuEdit(1).Enabled = Not (tvwReg.SelectedItem Is Nothing)
mnuEdit(2).Enabled = Not (bDisableEdit)
mnuEdit(3).Enabled = Not (bDisableEdit)
End Sub
Private Sub mnuFile_Click(Index As Integer)
Select Case Index
Case 0
MsgBox "Print: Left as exercise...", vbInformation
Case 2
Unload Me
End Select
End Sub
Private Sub mnuHelp_Click(Index As Integer)
MsgBox "VB Registry Editor using cRegistry Class" & vbCrLf & vbCrLf &
"Copyright 1998-2000 Steve McMahon (steve@vbaccelerator.com)" & vbCrLf &
"/home/VB/Code/Libraries/Registry_and_Ini_Files/Complete_Registry_Control/On_the_web_http/vbaccelerator.com", vbInformation
End Sub
Private Sub mnuView_Click(Index As Integer)
Dim bExpanded As Boolean
Select Case Index
Case 0
mnuView(Index).Checked = Not (mnuView(Index).Checked)
sbrMain.Visible = mnuView(Index).Checked
Form_Resize
Case 2
' Remove current node's contents:
bExpanded = tvwReg.SelectedItem.Expanded
tvwReg.SelectedItem.Expanded = False
' Rebuild:
tvwReg_NodeClick tvwReg.SelectedItem
tvwReg.SelectedItem.Expanded = bExpanded
tvwReg.SelectedItem.EnsureVisible
End Select
End Sub
Private Sub picSplitter_MouseDown(Button As Integer, Shift As Integer, X As
Single, Y As Single)
m_cSplit.MouseDown X
End Sub
Private Sub tvwReg_Collapse(ByVal Node As ComctlLib.Node)
Dim lNode As Long
Dim sText As String
Dim sKey As String
Dim nodX As Node
Dim nodParent As Node
Node.Image = "CLOSEDFOLDER"
Screen.MousePointer = vbHourglass
If Node.Children > 0 Then
' The quickest way to remove a large number of nodes is to remove the
' node itself:
If Not (Node.Parent Is Nothing) Then
Set nodParent = Node.Parent
End If
sText = Node.Text
sKey = Node.Key
tvwReg.Nodes.Remove Node.Index
If Not (nodParent Is Nothing) Then
Set nodX = tvwReg.Nodes.Add(nodParent, tvwChild, sKey, sText,
"CLOSEDFOLDER")
Else
Set nodX = tvwReg.Nodes.Add(, , sKey, sText, "CLOSEDFOLDER")
End If
tvwReg.Nodes.Add nodX, tvwChild, , "Unexpanded"
nodX.Selected = True
End If
Screen.MousePointer = vbDefault
End Sub
Private Sub tvwReg_Expand(ByVal Node As ComctlLib.Node)
Dim sSect() As String
Dim iSectCount As Long
Dim sKey As String
Dim iPos As Long
Dim iSect As Long
Dim nodX As Node
Screen.MousePointer = vbHourglass
If Node.Children > 0 Then
If (Node.Child.Text = "Unexpanded") Then
tvwReg.Nodes.Remove Node.Child.Index
sKey = Node.Key
iPos = InStr(sKey, ",")
If (iPos > 0) Then
cReg.ClassKey = CLng(Mid$(sKey, 2, (iPos - 2)))
cReg.SectionKey = Mid$(sKey, (iPos + 2))
Else
cReg.ClassKey = CLng(Mid$(sKey, 2))
sKey = sKey & ","
cReg.SectionKey = ""
End If
' Log "EnumeratingSection:" & cReg.ClassKey & "," & cReg.SectionKey
cReg.EnumerateSections sSect(), iSectCount
' Log "DisplayingSection:" & cReg.ClassKey & "," & cReg.SectionKey
If (iSectCount > 0) Then
For iSect = 1 To iSectCount
' Log "Key = " & sKey & "\" & sSect(iSect) & ",Value = '" &
sSect(iSect) & "'"
Set nodX = tvwReg.Nodes.Add(Node, tvwChild, sKey & "\" &
sSect(iSect), sSect(iSect), "CLOSEDFOLDER")
tvwReg.Nodes.Add nodX, tvwChild, , "Unexpanded"
Next iSect
Node.Sorted = True
End If
End If
End If
Node.Image = "OPENFOLDER"
Screen.MousePointer = vbNormal
End Sub
Private Sub tvwReg_NodeClick(ByVal Node As ComctlLib.Node)
Dim sKeyNames() As String
Dim iValueCount As Long
Dim iValue As Long
Dim sKey As String
Dim iPos As Long
Dim itmX As ListItem
Dim vValue As Variant
Dim iMax As Long, i As Long
Dim sOut As String
Screen.MousePointer = vbHourglass
lvwReg.ListItems.Clear
tvwReg_Expand Node
sKey = Node.Key
iPos = InStr(sKey, ",")
If (iPos > 0) Then
cReg.ClassKey = CLng(Mid$(sKey, 2, (iPos - 2)))
cReg.SectionKey = Mid$(sKey, (iPos + 2))
Else
cReg.ClassKey = CLng(Mid$(sKey, 2))
sKey = sKey & ","
cReg.SectionKey = ""
End If
' Log "EnumeratingValueNames:" & cReg.ClassKey & "," & cReg.SectionKey
cReg.EnumerateValues sKeyNames(), iValueCount
' Log "DisplayingValues:" & cReg.ClassKey & "," & cReg.SectionKey
' Log "ValueCount:" & iValueCount
For iValue = 1 To iValueCount
If (sKeyNames(iValue) = "") Then
Set itmX = lvwReg.ListItems.Add(, , "(default)", , "DATAITEM")
Else
Set itmX = lvwReg.ListItems.Add(, , sKeyNames(iValue), , "DATAITEM")
End If
cReg.ValueKey = sKeyNames(iValue)
vValue = cReg.Value
If cReg.ValueType <> REG_BINARY Then
itmX.SubItems(1) = vValue
Else
iMax = UBound(vValue)
If (iMax > 255) Then iMax = 255
For i = LBound(vValue) To iMax
If (vValue(i) < &H10) Then
sOut = sOut & "0"
End If
sOut = sOut & Hex$(vValue(i)) & " "
Next i
itmX.SubItems(1) = sOut
End If
' Should break down into individual types:
If cReg.ValueType = REG_SZ Then
itmX.Tag = "0"
ElseIf cReg.ValueType = REG_BINARY Then
itmX.Tag = "2"
Else
itmX.Tag = "1"
End If
Next iValue
lvwReg.SortKey = 0
lvwReg.SortOrder = lvwAscending
lvwReg.Sorted = True
lvwReg.ColumnHeaders(1).Tag = "ASC"
Screen.MousePointer = vbNormal
' Log "Exit NodeClick:" & iValueCount
End Sub
Private Sub Testbinary()
Dim cR As New cRegistry
Dim i As Long
Dim lC As Long
Dim bR As Byte
Dim bG As Byte
Dim bB As Byte
Dim bOut() As Byte
ReDim bOut(0 To 15 * 3 - 1) As Byte
For i = 1 To 15
' Get the Red, Green, Blue for the QBColor at index i:
lC = QBColor(i)
bR = (lC And &HFF&)
bG = ((lC And &HFF00&) \ &H100&)
bB = ((lC And &HFF0000) \ &H10000)
' Add Red, Green, Blue to the byte array to store:
bOut((i - 1) * 3) = bR
bOut((i - 1) * 3 + 1) = bG
bOut((i - 1) * 3 + 2) = bB
Next i
With cR
.ClassKey = HKEY_CURRENT_USER
.SectionKey = "software\vbaccelerator\cRegistry\Binary Test"
.ValueKey = "QBColors"
.ValueType = REG_BINARY
.Value = bOut()
End With
End Sub