form1.frm

vb控件vb控件vb控件vb控件vb控件vb控件vb控件

VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form Form1 
   BorderStyle     =   4  'Fixed ToolWindow
   ClientHeight    =   7335
   ClientLeft      =   45
   ClientTop       =   225
   ClientWidth     =   10485
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   7335
   ScaleWidth      =   10485
   ShowInTaskbar   =   0   'False
   StartUpPosition =   3  '窗口缺省
   Begin VB.CommandButton Command2 
      Caption         =   "退出(&E)"
      Height          =   390
      Left            =   8970
      TabIndex        =   4
      Top             =   6810
      Width           =   1440
   End
   Begin VB.CommandButton Command1 
      Caption         =   "导出(&T)"
      Height          =   390
      Left            =   7305
      TabIndex        =   3
      Top             =   6810
      Width           =   1440
   End
   Begin VB.TextBox Text1 
      Height          =   6675
      Left            =   6405
      MultiLine       =   -1  'True
      ScrollBars      =   3  'Both
      TabIndex        =   2
      Top             =   30
      Width           =   3990
   End
   Begin MSComctlLib.ImageList ImageList1 
      Left            =   1230
      Top             =   3600
      _ExtentX        =   1005
      _ExtentY        =   1005
      BackColor       =   -2147483643
      ImageWidth      =   16
      ImageHeight     =   16
      MaskColor       =   16777215
      _Version        =   393216
      BeginProperty Images {2C247F25-8591-11D1-B16A-00C0F0283628} 
         NumListImages   =   4
         BeginProperty ListImage1 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "Form1.frx":0000
            Key             =   ""
         EndProperty
         BeginProperty ListImage2 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "Form1.frx":0118
            Key             =   ""
         EndProperty
         BeginProperty ListImage3 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "Form1.frx":0230
            Key             =   ""
         EndProperty
         BeginProperty ListImage4 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "Form1.frx":0348
            Key             =   ""
         EndProperty
      EndProperty
   End
   Begin MSComctlLib.TreeView Trw 
      Height          =   6660
      Index           =   0
      Left            =   45
      TabIndex        =   0
      Top             =   30
      Width           =   3075
      _ExtentX        =   5424
      _ExtentY        =   11748
      _Version        =   393217
      Style           =   7
      ImageList       =   "ImageList1"
      Appearance      =   1
      OLEDropMode     =   1
   End
   Begin MSComctlLib.TreeView Trw 
      Height          =   6660
      Index           =   1
      Left            =   3225
      TabIndex        =   1
      Top             =   30
      Width           =   3075
      _ExtentX        =   5424
      _ExtentY        =   11748
      _Version        =   393217
      Style           =   7
      ImageList       =   "ImageList1"
      Appearance      =   1
      OLEDropMode     =   1
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim FSO As New Scripting.FileSystemObject
Dim SourceTreeView As Treeview
Dim SourceNode As Node
Dim ShiftState As Integer

Private Sub AddMyComputer(Treeview As Treeview)
    Dim dr As Scripting.Drive
    Dim RootNode As Node
    Dim nd As Node
    On Error Resume Next
    Set RootNode = Treeview.Nodes.Add(, , "My Computer", "My Computer", 1)
    RootNode.Expanded = True
    For Each dr In FSO.Drives
        If dr.Path <> "A:" Then
            '添加电脑驱动器除A：驱以外
            Set nd = Treeview.Nodes.Add(RootNode, tvwChild, dr.Path & "\", dr.Path & dr.VolumeName, 2)
            AddDynamicNode Treeview, nd
        End If
    Next
End Sub

Private Sub AddDynamicNode(Treeview As Treeview, Node As MSComctlLib.Node)
    If Node.Children = 0 Then
        Treeview.Nodes.Add Node.Key, tvwChild, , "***"
    End If
End Sub

Private Sub Command1_Click()
    Text1.Text = ExportTrToString(Trw(0))
End Sub

Private Sub Command2_Click()
    End
End Sub

Function ExportTrToString(Treeview As Treeview, Optional StartNode As Node) As String
    Dim i As Integer
    Dim ChildNd As Node, nd As Node
    Dim Str As String
    Static Leave As Integer
    If Treeview.Nodes.Count = 0 Then Exit Function
    If StartNode Is Nothing Then
        Set nd = Treeview.Nodes(1).Root.FirstSibling
    Else
        Set nd = StartNode
    End If
    Str = String$(Leave, vbTab) & nd.Text & vbCrLf
    If nd.Children And nd.Expanded Then
        Leave = Leave + 1
        Set ChildNd = nd.Child
        For i = 1 To nd.Children
            Str = Str & ExportTrToString(Treeview, ChildNd)
            Set ChildNd = ChildNd.Next
        Next
        Leave = Leave - 1
    End If
    ExportTrToString = Str
    
End Function


Private Sub Trw_OLEDragDrop(Index As Integer, Data As MSComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)
    Dim Des As Node, nd As Node
    Set Des = Trw(Index).DropHighlight
    If Des Is Nothing Then
        Set nd = Trw(Index).Nodes.Add(, , , SourceNode.Text, SourceNode.Image)
    Else
        If SourceTreeView Is Trw(Index) Then
            Set nd = Des
            '不能拖放目标节点到源节点或源节点的子节点
            Do
              If nd Is SourceNode Then
                    MsgBox "目标节点不能为源节点...", vbInformation
                    Exit Sub
              End If
              Set nd = nd.Parent
            Loop Until nd Is Nothing
         End If
        Set nd = Trw(Index).Nodes.Add(Des, tvwChild, , SourceNode.Text, SourceNode.Image)
        nd.ExpandedImage = SourceNode.ExpandedImage
    End If
    CopySubNode SourceTreeView, SourceNode, Trw(Index), nd
    If Effect And vbDropEffectMove Then
        DeleteNode SourceTreeView, SourceNode
    End If
End Sub

Private Sub Trw_OLEDragOver(Index As Integer, Data As MSComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single, State As Integer)
    Set Trw(Index).DropHighlight = Trw(Index).HitTest(x, y)
End Sub

Private Sub Trw_OLEStartDrag(Index As Integer, Data As MSComctlLib.DataObject, AllowedEffects As Long)
    Data.SetData SourceNode.Key
    If ShiftState And vbCtrlMask Then
        AllowedEffects = vbDropEffectCopy
    Else
        AllowedEffects = vbDropEffectMove
    End If
End Sub

Private Sub Form_Load()
    AddMyComputer Trw(0)
End Sub

'添加哑节点(为添加+号效果)
Private Sub Trw_Expand(Index As Integer, ByVal Node As MSComctlLib.Node)
    '如果节点没有子节点或子节点多于1个，退出过程
    If Node.Children = 0 Or Node.Children > 1 Then Exit Sub
    '如果第一个子节点的Text属性不为***,退出过程
    If Node.Child.Text <> "***" Then Exit Sub
    '删除哑节点
    Trw(Index).Nodes.Remove Node.Child.Index
    AddSubFolder Trw(Index), Node
End Sub

Private Sub AddSubFolder(Treeview As Treeview, Node As MSComctlLib.Node)
    On Error Resume Next
    Dim fl As Scripting.Folder
    Dim nd As Node
    For Each fl In FSO.GetFolder(Node.Key).SubFolders
        Set nd = Treeview.Nodes.Add(Node, tvwChild, fl.Path, fl.Name, 3)
        nd.ExpandedImage = 4
        If fl.SubFolders.Count Then AddDynamicNode Treeview, nd
    Next
End Sub

Private Sub Trw_MouseDown(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button <> 2 Then Exit Sub
    Set SourceNode = Trw(Index).HitTest(x, y)
    If SourceNode Is Nothing Then Exit Sub
    Set SourceTreeView = Trw(Index)
    ShiftState = Shift
    Trw(Index).OLEDrag
End Sub