VBレスキュー(花ちゃん) - VBレスキュー(花ちゃん)の投稿サンプル用掲示板

　　　　　サンプル投稿用掲示板　　 VB2005 ～用トップページ　　 VB6.0 用トップページ

ツリービューにフォルダとファイルを表示する(VB6.0)_1 ( No.1 ) 　[親スレッドへ]

日時： 2010/01/10 13:12
名前： 魔界の仮面弁士: ***********************************************************************************
* カテゴリー：[ツリービュー][ファイル][] 　　　                                   *
* キーワード：全ファイル,サブフォルダー以下,,,,                                   *
***********************************************************************************

列挙するフォルダ数が多いと、再帰検索に膨大な時間がかかるので、
サブフォルダの読み込み処理を遅延させることで、疑似的に高速化させてみました。

下記では、すべてのドライブを列挙してツリーを構築しています。

Option Explicit

Private Declare Function LockWindowUpdate Lib "user32" _
    (ByVal hWndLock As Long) As Long

Private FSO As Scripting.FileSystemObject
Private IncludFiles As Boolean

Private Sub Form_Initialize()
    IncludFiles = True
    Set FSO = New Scripting.FileSystemObject
End Sub

Private Sub Form_Load()
    Command1.Caption = "表示"

    TreeView1.Indentation = 360
    TreeView1.LabelEdit = tvwManual
    TreeView1.LineStyle = tvwRootLines
End Sub

Private Sub Command1_Click()
    If MsgBox("ファイルを含めますか?", vbQuestion Or vbYesNo) = vbYes Then
        BuildRootTree TreeView1, True
    Else
        BuildRootTree TreeView1, False
    End If
End Sub

Private Sub TreeView1_Expand(ByVal Node As Node)
    If CBool(Node.Tag) Then
        Exit Sub
    End If

    BuildSubTree TreeView1, Node
End Sub

Friend Sub BuildRootTree(ByVal tv As TreeView, ByVal IncludFiles As Boolean)
    LockWindowUpdate tv.hWnd

    tv.Nodes.Clear
    tv.Tag = IncludFiles

    Dim drv As Scripting.Drive
    Dim rootNode As Node
    For Each drv In FSO.Drives
        Set rootNode = tv.Nodes.Add(Text:=drv.path & "\")
        If drv.IsReady Then
            rootNode.Tag = False
            tv.Nodes.Add rootNode, tvwChild
        Else
            rootNode.Tag = True
        End If
    Next

    LockWindowUpdate 0
End Sub

Private Sub BuildSubTree(ByVal tv As TreeView, ByVal location As Node)
    If location Is Nothing Then
        Exit Sub
    ElseIf CBool(location.Tag) Then
        '構築済み
        Exit Sub
    End If

    LockWindowUpdate tv.hWnd

Try: On Error GoTo Finally
    location.Tag = Empty
    tv.Nodes.Remove location.Child.Index

    Dim path As String
    path = location.FullPath
    path = Left(path, 2) & Replace(Mid(path, 3), "\\", "\")

    Dim pFolder As Scripting.Folder
    Set pFolder = FSO.GetFolder(path)

    Dim cFolder As Scripting.Folder
    Dim cNode As Node
    Dim hasChildren As Boolean
    For Each cFolder In pFolder.SubFolders
        Set cNode = tv.Nodes.Add(location, tvwChild, , cFolder.Name)
        hasChildren = False
        On Error Resume Next
        hasChildren = CBool(cFolder.SubFolders.Count > 0)
        If hasChildren = False And CBool(tv.Tag) Then
            hasChildren = CBool(cFolder.Files.Count > 0)
        End If
        On Error GoTo Finally
        If hasChildren Then
            tv.Nodes.Add cNode, tvwChild
            cNode.Tag = False
        Else
            cNode.Tag = True
        End If
    Next

    If CBool(tv.Tag) Then
        'ファイルも列挙
        Dim cFile As Scripting.File
        For Each cFile In pFolder.Files
            tv.Nodes.Add location, tvwChild, , cFile.Name
        Next
    End If

Finally:
    If Err.Number <> 0 Then
        Debug.Print Err.Description
    End If
    location.Tag = True
    LockWindowUpdate 0
End Sub