frmmain.frm

图象压缩算法 图象压缩算法 图象压缩算法 图象压缩算法 图象压缩算法 图象压缩算法 图象压缩算法

            End If
        Else 'normal import mode
            If (MsgBox("Are you sure you want to add" & vbNewLine & cmd & _
                vbNewLine & "registry information in registry database?", _
                                                vbYesNo, "Confirm") = vbYes) Then
                ret = Regy.ImportFromReg(cmd)
                If ret = 0 Then
                    MsgBox "Error importing file to registry.", vbExclamation, "Error"
                Else
                    MsgBox "Successufuly entered data into registry.", vbInformation, "Registry Editor"
                End If
            End If
        End If
        
        On Error Resume Next
        End 'close
    End If
    
    Set cSplit = New clsSplitter
    
    If InitXPStyles = False Then
        MsgBox "Error instalizing XP visual styles.", vbInformation, "Error"
    End If
    
    cSplit.Initialise picSplitter, Me  'init splitter
    
    Set nodX = tvwKeys.Nodes.Add(, , "COMP", "My Computer", 5) 'add 'My Computer' node
    nodX.Expanded = True 'and set it expanded
    
    Set lastNode = nodX
    
    'add main hkeys
    Set nodX = tvwKeys.Nodes.Add("COMP", tvwChild, "HKEY_CLASSES_ROOT", "HKEY_CLASSES_ROOT", 1)
    Set nodX = tvwKeys.Nodes.Add("COMP", tvwChild, "HKEY_CURRENT_USER", "HKEY_CURRENT_USER", 1)
    Set nodX = tvwKeys.Nodes.Add("COMP", tvwChild, "HKEY_LOCAL_MACHINE", "HKEY_LOCAL_MACHINE", 1)
    Set nodX = tvwKeys.Nodes.Add("COMP", tvwChild, "HKEY_USERS", "HKEY_USERS", 1)
    Set nodX = tvwKeys.Nodes.Add("COMP", tvwChild, "HKEY_CURRENT_CONFIG", "HKEY_CURRENT_CONFIG", 1)
    Set nodX = tvwKeys.Nodes.Add("COMP", tvwChild, "HKEY_DYN_DATA", "HKEY_DYN_DATA", 1)
    'add empty nodes, so hkeys may be expandeable
    Set nodX = tvwKeys.Nodes.Add("HKEY_CLASSES_ROOT", tvwChild)
    Set nodX = tvwKeys.Nodes.Add("HKEY_CURRENT_USER", tvwChild)
    Set nodX = tvwKeys.Nodes.Add("HKEY_LOCAL_MACHINE", tvwChild)
    Set nodX = tvwKeys.Nodes.Add("HKEY_USERS", tvwChild)
    Set nodX = tvwKeys.Nodes.Add("HKEY_CURRENT_CONFIG", tvwChild)
    Set nodX = tvwKeys.Nodes.Add("HKEY_DYN_DATA", tvwChild)
    
    opened = ":"
    
    Exit Sub
errTrap:
    Dim msg As String
    msg = "An error ocured!" & vbCrLf
    msg = msg & "Description: " & Err.Description & String(2, vbCrLf)
    MsgBox msg, vbExclamation, "Error: " & Err.Number
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    Unload Me
End Sub

'---------[ Resizing & Splitter thing... ]
Private Sub Form_Resize()
    On Error Resume Next
    Dim s As Single
    
    tvwKeys.Left = 3: tvwKeys.Top = 0
    
    s = Me.ScaleHeight + stbStatus.Height * mnuStatus.Checked
    'dunno why vb raises error here if s < 0???
    If s > 0 Then tvwKeys.Height = s
    
    tvwKeys.Width = picSplitter.Left
    picSplitter.Top = 0
    
    s = Me.ScaleHeight + stbStatus.Height * mnuStatus.Checked
    If s > 0 Then picSplitter.Height = s
    
    lvwData.Top = -1
    lvwData.Left = picSplitter.Left + 6
    
    s = Me.ScaleHeight + 2 + stbStatus.Height * mnuStatus.Checked
    If s > 0 Then lvwData.Height = s
    
    s = Me.ScaleWidth - picSplitter.Left - 7
    If s > 0 Then lvwData.Width = s
    
    Call txtOutput_Change
    
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    cSplit.MouseMove X
End Sub
Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    cSplit.MouseUp X
End Sub
Private Sub picSplitter_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    cSplit.MouseDown X
End Sub
Private Sub cSplit_SplitComplete()
    Call Form_Resize
End Sub
'---------------------------------------

'---------[ Nodes... ]
Private Sub tvwKeys_Collapse(ByVal Node As MSComctlLib.Node)
    On Error Resume Next
    If Node.Key <> "COMP" Then Node.Image = 1 'set "close folder" image
    txtOutput.Text = Node.Key
    Call tvwKeys_NodeClick(Node)
End Sub
Private Sub tvwKeys_Expand(ByVal Node As MSComctlLib.Node)
    On Error GoTo errTrap
    Dim rKey       As String
    Dim keyCnt      As Long
    Dim Keys()      As String
    Dim k           As Long
    
    Screen.MousePointer = vbHourglass 'set pointer
    
    rKey = Node.Key
    
    'if this key wasn't loaded yet then load it!
    If InStr(1, opened, ":" & rKey & ":") < 1 Then

        keyCnt = Regy.EnumKeys(rKey, Keys()) 'get subkeys
        
        Node.Expanded = False
        DoEvents
        
        tvwKeys.Nodes.Remove Node.Child.Index 'removes empty node
        
        curSubkeys = ":"
        For k = 0 To keyCnt - 1 'for each subkey in subkeys
            'add new node
            Set nodX = tvwKeys.Nodes.Add(rKey, tvwChild, rKey & "\" & Keys(k), Keys(k), 1)
            curSubkeys = curSubkeys & Keys(k) & ":"
            'add empty node if this key has atleast 1 subkey
            If Regy.HaveSubkey(rKey & "\" & Keys(k)) Then
                Set nodX = tvwKeys.Nodes.Add(rKey & "\" & Keys(k), tvwChild)
            End If
        Next

        'remember this key (so we won't try to load it twice!)
        opened = opened & rKey & ":"
        
        Node.Sorted = True 'sort added keys ;)
        
        Node.Expanded = True 'on end, expande it!
        
        txtOutput.Text = rKey
    End If
    
    If Node.Key <> "COMP" Then Node.Image = 2 'set "open folder" image
    Screen.MousePointer = vbNormal
    
    Set lastListItem = Nothing
    mnuModify.Enabled = False
    mnuKillValue.Enabled = False
    
    Exit Sub
errTrap:
    Dim msg As String
    msg = "An error ocured!" & vbCrLf
    msg = msg & "Description: " & Err.Description & String(2, vbCrLf)
    MsgBox msg, vbExclamation, "Error: " & Err.Number
End Sub
Private Sub tvwKeys_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = 2 Then
        Me.PopupMenu popKey
    End If
End Sub

Private Sub tvwKeys_NodeClick(ByVal Node As MSComctlLib.Node)
    On Error GoTo errTrap
    Dim valCnt      As Long
    Dim valName()   As String
    Dim valData()   As Variant
    Dim k           As Long
    Dim tmp         As String
    
    Set lastNode = Node 'remmeber this node, so we can refresh it
    
    txtOutput.Text = Node.Key
    
    'enable menus
    mnuCopyName.Enabled = Node.Key <> "COMP"
    mnuNewKey.Enabled = Node.Key <> "COMP"
    mnuNewString.Enabled = Node.Key <> "COMP"
    mnuNewBinary.Enabled = Node.Key <> "COMP"
    mnuNewDWORD.Enabled = Node.Key <> "COMP"
    mnuKillKey.Enabled = Node.Key <> "COMP"
    
    lvwData.ListItems.Clear 'first clear all values from listview
    
    If Node.Key = "COMP" Then Exit Sub 'exit if is clicked on 'My Computer'

    'then add all string values from this key to listview
    valCnt = Regy.EnumValues(Node.Key, valName(), valData(), REG_SZ)
    
    curValues = ":(Default):"
    
    'add all data of string type
    For k = 0 To valCnt - 1
        If Len(valName(k)) > 0 Then
            Set lstX = lvwData.ListItems.Add(, , valName(k), , 3)
            lstX.Tag = REG_SZ
            lstX.ListSubItems.Add , , Chr$(34) & valData(k) & Chr$(34)
            curValues = curValues & valName(k) & ":"
        End If
    Next
    'now add '(Default)' value
    Set lstX = lvwData.ListItems.Add(, , "(Default)", , 3)
    lstX.Tag = REG_SZ
    'and set its data:
    tmp = Regy.ReadString(Node.Key, "")
    If Len(tmp) = 0 Then tmp = "(value not set)" Else tmp = Chr$(34) & tmp & Chr$(34)
    lstX.ListSubItems.Add , , tmp
    
    'reset arrays
    Erase valName
    Erase valData
    
    'now lets get all DWORD's
    valCnt = Regy.EnumValues(Node.Key, valName(), valData(), REG_DWORD)
    For k = 0 To valCnt - 1
        If Len(valName(k)) > 0 Then
            Set lstX = lvwData.ListItems.Add(, , valName(k), , 4)
            lstX.Tag = REG_DWORD
            lstX.ListSubItems.Add , , formatDWORD(valData(k))
            curValues = curValues & valName(k) & ":"
        End If
    Next
    'reset arrays
    Erase valName
    Erase valData

    'after that, we'll read all Binary data from this key
    valCnt = Regy.EnumValues(Node.Key, valName(), valData(), REG_BINARY)
    For k = 0 To valCnt - 1
        If Len(valName(k)) > 0 Then
            Set lstX = lvwData.ListItems.Add(, , valName(k), , 4)
            lstX.Tag = REG_BINARY
            tmp = valData(k)
            If Len(tmp) = 0 Then tmp = "(zero-length binary value)"
            lstX.ListSubItems.Add , , tmp
            curValues = curValues & valName(k) & ":"
        End If
    Next
    
    Set lastListItem = Nothing
    mnuModify.Enabled = False
    mnuKillValue.Enabled = False
    
    Exit Sub 'exit before error handler
errTrap:
    Dim msg As String
    msg = "An error ocured!" & vbCrLf
    msg = msg & "Description: " & Err.Description & String(2, vbCrLf)
    MsgBox msg, vbExclamation, "Error: " & Err.Number
End Sub

Private Sub txtExport_Change()
    Me.Caption = "Exporting - " & txtExport.Text
End Sub
Private Sub txtOutput_Change()
    On Error Resume Next
    Dim txt As String
    
    txt = lastNode.FullPath
    
    'i know, this not work....
    If Me.TextWidth(txt) > stbStatus.Width Then
        Do While Not Me.TextWidth(txt) = stbStatus.Width ' - Me.TextWidth("...")
            If Len(txt) > 1 Then
                txt = Left$(txt, Len(txt) - 1)
            Else
                Exit Do
            End If
        Loop
        txt = txt & "..."
    End If
    
    stbStatus.SimpleText = txt '& " [" & lastNode.Index & "]"
End Sub

'this will format DWORD value in same way as regedit does, e.g. '0x000055be (21950)'
Function formatDWORD(dValue As Variant) As String
    On Error GoTo errTrap
    
    formatDWORD = "0x" & Right$("00000000" & Hex$(dValue), 8) & " (" & dValue & ")"
    
errTrap:
End Function
'-------------------------------------------------

'----------[ Data View.... ]
Private Sub lvwData_ItemClick(ByVal Item As MSComctlLib.ListItem)
    Set lastListItem = Item
    mnuModify.Enabled = True
    mnuKillValue.Enabled = True
End Sub
Private Sub lvwData_DblClick()
    If IsObject(lastListItem) Then
        Call mnuModify_Click
    End If
End Sub
Private Sub lvwData_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = 2 Then 'right click
        Set lastListItem = lvwData.SelectedItem
        mnuModify.Enabled = True
        mnuKillValue.Enabled = True
        
        popModify.Enabled = IsObject(lastListItem)
        popKillValue.Enabled = IsObject(lastListItem)
        
        Me.PopupMenu popData, , , , popModify
    End If
End Sub
'-------------------------------------------------

'----------[ Menus.... ]
Private Sub mnuStatus_Click()
'shows/hides status bar
    mnuStatus.Checked = Not mnuStatus.Checked
    stbStatus.Visible = mnuStatus.Checked
    Call Form_Resize 'resize controls
End Sub
Private Sub mnuExit_Click()
    Unload Me 'Quit!
End Sub
Private Sub mnuRefresh_Click()
    'reload contents of selected key
    Call tvwKeys_NodeClick(lastNode)
End Sub
Private Sub mnuCopyName_Click() 'copy key path to clipboard
    On Error Resume Next
    Clipboard.Clear 'clear clipboard
    Clipboard.SetText lastNode.Key 'and set text
End Sub
Private Sub mnuKillKey_Click() 'delete key
    On Error Resume Next
    Dim Index As Integer, sRem As String
    
    If (InStr(1, lastNode.Key, "\") < 1) Then
        MsgBox "Cannot delete root keys!", vbExclamation, "Error"
    Else
        If (MsgBox("Are you sure you want to delete current key?", _
                            vbYesNo + vbQuestion, "Confirm") = vbYes) Then
            Regy.KillKey (lastNode.Key)
            
            sRem = lastNode.Key
            Index = lastNode.Index
            Call tvwKeys_NodeClick(lastNode.Parent) 'set focus to its parent
            tvwKeys.Nodes.Remove Index 'remove node
            opened = Replace(opened, sRem, "")
        End If
    End If