frmmain.frm

超完整的原程序

    Dim fname As String
    
    Set fs = CreateObject("Scripting.FilesystemObject")         '创建文件系统对象并赋给变量
    
    If ButtonMenu.Text = "文件" Then                            '新建文件
        fname = gen_name(False)
        Set l = List.ListItems.Add(, , fname, "file", "file")
        l.ListSubItems.Add , , "文件"
        l.ListSubItems.Add , , "0"
        l.ListSubItems.Add , , Now()
        List.SelectedItem = l
        fs.CreateTextFile List.Tag & "\" & fname, True
        List.StartLabelEdit
    Else                                                         '新建文件夹
        fname = gen_name(True)
    
        Set l = List.ListItems.Add(, , fname, "foldclose", "foldclose")
        l.ListSubItems.Add , , "文件夹"
        l.ListSubItems.Add , , "0"
        l.ListSubItems.Add , , Now()
        List.SelectedItem = l
       ' Set n = Tree.Nodes(List.Tag)
        Tree.Nodes.Add List.Tag, tvwChild, List.Tag & "\" & fname, fname, "foldclose", "foldclose"
        
        fs.CreateFolder List.Tag & "\" & fname
        List.StartLabelEdit
    End If
       
End Sub

Private Sub Tree_AfterLabelEdit(Cancel As Integer, NewString As String)
    Dim n As node, n1 As node
    Dim fs As Object
    Dim f As Object
    '判断是否为文件夹，否则不可编辑
    If InStr(Tree.SelectedItem.Key, "\") = 0 Then Cancel = 1: Exit Sub
    If NewString = "" Then MsgBox "文件名无效。", vbExclamation: Exit Sub

    Set n = Tree.SelectedItem.FirstSibling
    Do Until n Is Nothing           '判断是否已有此名称
        If n.Text = NewString Then
            MsgBox "此名称已存在，不能重命令。", vbCritical: Cancel = 1: Exit Sub
        End If
        Set n = n.Next
    Loop
    
    Set fs = CreateObject("Scripting.FilesystemObject")         '创建文件系统对象并赋给变量
    Set f = fs.GetFolder(Tree.SelectedItem.Key)                 '更改文件夹名称
    f.Name = NewString
    
    Tree.SelectedItem.Key = Tree.SelectedItem.Parent.Key & "\" & NewString '& "\"      '改变键值
    
    Call rename_node(Tree.SelectedItem)
    
    
End Sub

Private Sub Tree_BeforeLabelEdit(Cancel As Integer)
    '判断是否为文件夹，否则不可编辑
    If InStr(Tree.SelectedItem.Key, "\") = 0 Then Cancel = 1: Exit Sub
    If UCase(Tree.SelectedItem.Text) = "RECYCLED" Then Cancel = 1: Exit Sub
End Sub

Private Sub Tree_Collapse(ByVal node As MSComctlLib.node)               '关闭文件夹
    Dim i As Integer, j As Integer
    Dim num As Integer
    Dim s As String
    
    Dim f As Object
    Dim fs As Object
    Dim d As Object
    Dim n As node, sn As node
    
    Set n = node
    Set n = n.Parent
    Do While Not n Is Nothing
        num = num + 1
        Set n = n.Parent
    Loop
    
    If num < 2 Then Exit Sub
    
    Set fs = CreateObject("Scripting.FilesystemObject")         '创建文件系统对象并赋给变量
    Set f = fs.GetFolder(node.Key)
    Set n = node.Child
    Do While Not n Is Nothing
        Do While n.Children > 0
            Set sn = n.Child
            Tree.Nodes.Remove sn.Index
        Loop
        Set n = n.Next
    Loop
    
    If num > 2 And UCase(node.Text) <> "RECYCLED" Then
        node.Image = "foldclose"
    End If
End Sub

Private Sub Tree_Expand(ByVal node As MSComctlLib.node)                     '展开文件夹
    Dim i As Integer
    Dim num As Integer
    Dim s As String
    
    Dim f As Object
    Dim fs As Object
    Dim sf As Object
    Dim ssf As Object
    Dim n As node
    
    
    Set n = node
    Set n = n.Parent
    Do While Not n Is Nothing
        num = num + 1
        Set n = n.Parent
    Loop
    
    If num < 2 Then Exit Sub
    
    Set fs = CreateObject("Scripting.FilesystemObject")         '创建文件系统对象并赋给变量
    Set f = fs.GetFolder(node.Key & "\")                        '此处加“\”，是为了避免得到当前目录  G:和G:\返回结果不同。
    
    For Each sf In f.SubFolders
        If sf.Name <> "System Volume Information" Then
            Set n = Tree.Nodes(sf.Path)
            For Each ssf In sf.SubFolders
                Tree.Nodes.Add n, tvwChild, ssf.Path, ssf.Name, "foldclose"
            Next
        End If
    Next
    
    If num > 2 Then
        node.Image = "foldopen"
    End If
End Sub
Private Sub Tree_NodeClick(ByVal node As MSComctlLib.node)
    Dim i As Integer
    Dim num As Integer
    Dim s As String
    
    Dim f As Object
    Dim fs As Object
    Dim sf As Object
    Dim file As Object
    Dim n As node
    
    Dim li As ListItem
    Dim l As ComboItem
       
    Set n = node
    Set n = n.Parent
    Do While Not n Is Nothing
        num = num + 1
        Set n = n.Parent
    Loop
    
    If num < 2 Then List.ListItems.Clear: Exit Sub
    
    Set fs = CreateObject("Scripting.FilesystemObject")         '创建文件系统对象并赋给变量
       
    If num = 2 Then     '如果点击的是驱动器号，则检查设备是否就绪
        If Not fs.GetDrive(node.Key).IsReady Then
            MsgBox "驱动器" & Left(node.Key, 2) & "未就绪，请插入盘片。", vbInformation
            List.ListItems.Clear
            Exit Sub
        End If
    End If
    
    Set f = fs.GetFolder(node.Key & "\")                        '得到相应的文件夹
    List.Tag = node.Key
    List.ListItems.Clear                                        '在列表中添加文件夹与文件
    For Each sf In f.SubFolders
        Set li = List.ListItems.Add(, , sf.Name, "foldclose", "foldclose")
        li.ListSubItems.Add , , "文件夹"
        li.ListSubItems.Add , , ""                              '文件夹大小，因为计算文件夹的大小非常耗时，所有不计算
        li.ListSubItems.Add , , sf.DateLastModified             '文件夹日期
        li.ListSubItems.Add , , get_attr(sf.Attributes)         '文件夹属性
    Next
    For Each file In f.Files
        Set li = List.ListItems.Add(, , file.Name, "file", "file")
        li.ListSubItems.Add , , "文件"
        li.ListSubItems.Add , , file.Size                       '文件大小
        li.ListSubItems.Add , , file.DateLastModified           '文件日期
        li.ListSubItems.Add , , get_attr(file.Attributes)       '文件属性
    Next
    '在状态栏表示文件与文件夹的数目**********
    
    StatusBar.Panels(1).Text = "文件夹个数：" & f.SubFolders.Count
    StatusBar.Panels(2).Text = "文件个数：" & f.Files.Count
    
    If Not node.Expanded Then node.Expanded = True
    
    '在图像组合框中显示内容***********
    '
    num = 0
    Set n = node
    Dim nodearray() As node
    Do Until n Is Nothing
        num = num + 1
        ReDim Preserve nodearray(num)
        Set nodearray(num) = n
        Set n = n.Parent
    Loop
    
    ImageCombo1.ComboItems.Clear
    
    Set n = Tree.Nodes(1)               '桌面，根节点
    ImageCombo1.ComboItems.Add , , n.Text, n.Image
    Set n = n.Child                     '我的电脑
    ImageCombo1.ComboItems.Add , , n.Text, n.Image, , 1
    Set n = n.Child
   
    Do While Not n Is Nothing
        ImageCombo1.ComboItems.Add , , n.Text, n.Image, , 2
        If n Is nodearray(num - 2) Then
            For i = num - 3 To 1 Step -1
                 Set l = ImageCombo1.ComboItems.Add(, , nodearray(i).Text, "foldclose", , 1 + num - i)
                 l.Tag = nodearray(i)
            Next
        End If
        Set n = n.Next
    Loop
    
    ImageCombo1.Text = node.Key
End Sub
Private Function get_attr(a As Integer) As String                 '得到文件或文件夹的属性
    If a And 1 Then get_attr = "R"
    If a And 2 Then get_attr = get_attr & "H"
    If a And 4 Then get_attr = get_attr & "S"
End Function

Private Sub List_DblClick()
    Dim n As node
    
    If List.SelectedItem Is Nothing Then Exit Sub
    
    If List.SelectedItem.ListSubItems(1).Text <> "文件夹" Then Exit Sub   '如果双击不是文件夹，则什么也不做
    
    Set n = Tree.Nodes(List.Tag)     '得到双击文件夹的父文件夹所对应的树型节点
    Set n = n.Child
    Do
        If n.Text = List.SelectedItem.Text Then
            Set Tree.SelectedItem = n
            Call Tree_NodeClick(n)
            Exit Sub
        End If
        Set n = n.Next
    Loop
End Sub

Private Sub rename_node(n As node)              '使用递归修改一节点下所有节点的键值
    Dim n1 As node
    Set n1 = n.Child
    Do While Not n1 Is Nothing
        n1.Key = n1.Parent.Key & "\" & n1.Text
        If Not n1.Child Is Nothing Then
            Call rename_node(n1)
        End If
        Set n1 = n1.Next
    Loop
End Sub

Private Function gen_name(b As Boolean) As String           '产生一个不重复的文件或文件夹名
    Dim i As Integer, j As Integer
    Dim s As String
    Dim fname() As String
    
    If b Then
        s = "新建文件夹"
    Else
        s = "新建文件"
    End If

    ReDim fname(List.ListItems.Count)
    For i = 1 To List.ListItems.Count
        fname(i) = List.ListItems(i).Text
    Next
    j = 1
    Do
       For i = 1 To List.ListItems.Count
           If s & j = fname(i) Then Exit For
       Next
       If i > List.ListItems.Count Then Exit Do
       j = j + 1
    Loop
    gen_name = s & j
End Function