Lotusnut >> Soft >> Visual Basic >> TreeView2

Visual Basic 6.0

前回の『ツリービューコントロールを考える』から、だいぶ時間がたってしまいましたが、久しぶりにまたこの難題?に取り組むことになりました。今までの勉強で、判ってきたことは、VB6標準の(Common Controls 6.0 SP4)ツリービューコントロールの欠点?というかあえてそのような設計をしているというか?必要最低限の機能しか備わってないのかな?と感じてきました。特にエクスプローラ風な作り方を考えた場合。そんな短絡的な結論になってしまうのです。データベースをツリーで表示する場合は、速度に関しても適度な設計が初心者の私でも可能なのですが、ノードの数が一定でない前出のエクスプローラ風は、今回でも勉強のし甲斐がありました。インターネットで検索してもエクスプローラ風ツリービューをVBでという人は、なかなかサンプルが見つかりません。中には目から鱗で、DriveListBoxとFileListBoxを巧みに使いツリービューに組み合わせて、プログラムを作っている方もいました。しかし、私は何とか標準のTreeViewControlで速度的にもデザイン的にも適度なコードを書きたい。そんな思いに駆られるのです。そんなわけで、ながなが講釈を述べてしまいましたが、取敢えず、今の段階で納得の行くソースができましたので、見てやってください。・・・まだまだ苦難は続くのですが・・・

  • Option Explicit
  • Private Sub Form_Load()
  • 'システム関数のラップ
  • On Error GoTo ErrTrap
  • 'ローカル変数の宣言
  • Dim spfmsg As String
  • 'イメージリストの関連付
  • Set tvTreeView.ImageList = imlTVIcon
  • 'フォームレジストリの取得
  • spfmsg = sfFormGetReg(frmMain)
  • '表示の停止
  • Screen.MousePointer = vbHourglass
  • '最初のノード設定
  • spfmsg = sfGetDriveList(tvTreeView)
  • 'ディスクトップノードを展開表示
  • tvTreeView.Nodes(1).Expanded = True
  • '表示の復活
  • Screen.MousePointer = vbDefault
  • Exit Sub
  • 'エラートラップ
  • ErrTrap:
  • Debug.Print "Form_Loadエラー" & Err.Description
      On Error GoTo 0
  • End Sub
  • Private Sub tvTreeView_Expand(ByVal Node As MSComctlLib.Node)
  • 'システム関数のラップ
  • On Error GoTo ErrTrap
  • 'ローカル変数の宣言
  • Dim spfmsg As String
  • Dim lngresult As Long
  • '***** プロシージャ処理の実行 *****
  • 'Dumyを消去して、サブディレクトリを展開する
  • If Node.Child.Text = "" Then
  • 'マウスアイコンを砂時計にし再描画を抑止
  • Screen.MousePointer = vbHourglass
        lngresult = SendMessage(tvTreeView.hWnd, _
                        WM_SETREDRAW, _
                        0, ByVal CLng(0))
  • 'Dumy を削除
  • tvTreeView.Nodes.Remove (Node.Index + 1)
    spfmsg = sfNodeAdd(tvTreeView, Node.Key)
    '表示の復活
    Screen.MousePointer = vbDefault
    lngresult = SendMessage(tvTreeView.hWnd, _
    WM_SETREDRAW, _
    1, ByVal CLng(0))
    End If
    Exit Sub
    'エラートラップ
    ErrTrap:
    MsgBox "tvTreeView_NodeClick プロシージャエラーです:" & Err.Number & ">"
      On Error GoTo 0
    End Sub
  • '***** ツリービューコントロール操作Class - clsUser - *****
  • 注;ここからは、オリジナルは別のモジュールに書いています。
    '***** Soft Ver 0.0.0 2002/11/11 Original
  • Option Explicit
  • 'ファイルスクリプトの宣言
  • Dim FileSysObj As Scripting.FileSystemObject
  • Function sfNodeAdd(ByVal TvwName As Variant, _
                  ByVal strpath As String) As String
  • ' 作  メ(Writer) : lotusnut
  • ' 目  的(Aim) : ツリービューにおけるノードを追加するプロシジャをを作成する
  • ' 入  力(Input) : 引数 tvwctrl - ツリービューコントロール
  • ' strpath -パス名が関連付けになる
  • ' 戻  値(Return) : 安全エラーメッセージ
  • ' 使用方法(Usage) : sfNodeAdd(Tvwctrl, strPathname)
  • ' 履  歴(History) : Ver 0.0.0 2002/11/12 Original
  • On Error GoTo ErrTrap
  • '変数スクリプトオブジェクトの宣言
  • Dim ScrFolder As Folder
      Dim ScrFolders As Folders
      Dim mynode As Node
      Dim spfmsg As String
  • '戻り値の初期化
  • sfNodeAdd = ""
  • '引数の検証および変換
  • If Not TypeOf TvwName Is TreeView Then
        sfNodeAdd = "sfNodeAddエラー:ツリービューコントロールが不正です"
        Exit Function
      End If
  • 'フォルダーオブジェクトのセット
  • Set FileSysObj = CreateObject("Scripting.FileSystemObject")
      Set ScrFolder = FileSysObj.GetFolder(strpath)
      Set ScrFolders = ScrFolder.SubFolders
  • '子ノードの追加
  • For Each ScrFolder In ScrFolders
        If ScrFolder.Name = "Recycled" Then
  • '何もしない
  • Else
          Set mynode = TvwName.Nodes.Add(strpath, tvwChild, ScrFolder.Path, _
                                 ScrFolder.Name, "Close", "Open")
  • 'ここで、+サインを表示する目的で、ダミ-のサブフォルダを作る
  • If IsSubFolder(ScrFolder.Path) Then
      Set mynode = TvwName.Nodes.Add(ScrFolder.Path, tvwChild,_
      ScrFolder.Name,"", "Close")
      End If
      End If
  • 'ダミーサブフォルダーを作らず素直にドライブのフォルダーを取得するのに再帰を使うなら
  • '上記の部分で以下のソースを入れる
  • spfmsg = sfNodeAdd(TvwName, ScrFolder)
  • '再帰
  • Next
  • 'オブジェクトの開放
  • Set ScrFolder = Nothing
      Set ScrFolders = Nothing
      Set FileSysObj = Nothing
  • Exit Function
  • ErrTrap:
  • 'エラーを返す
  •   sfNodeAdd = "sfNodeAddエラー:" & Err.Description
      On Error GoTo 0
  • End Function
  • Function sfGetDriveList(ByVal TvwName As Variant) As String
  • ' 作  者(Writer) : lotusnut
  • ' 目  的(Aim) : ローカルディスクのドライブ名を取得する
  • ' 受け渡し(Delivery): TvwName - ツリービュー名
  • ' 戻  値(Return) : 安全なエラーメッセージ
  • ' 注  釈(Notes) : ここからフォルダーの格納が始まる
  • ' 使用方法(Usage) : count = dfGetDriveList
  • ' 履  歴(History) : Ver 0.0.0 2001/12/12 Original
  • On Error GoTo ErrTrap
  • '変数スクリプトオブジェクトの宣言
  • Dim ScrDrive As Scripting.Drive
      Dim ScrDrives As Scripting.Drives
      Dim DrvName As String
      Dim DrvImgList As Integer
      Dim mynode As Node
      Dim imgkey As String
      Const INDENT As Long = 250
  • '戻り値の初期化
  • sfGetDriveList = ""
  • '引数を検証する
  • If Not TypeOf TvwName Is TreeView Then
        sfGetDriveList = "sfGetDriveListが不正--" & Err.Description
        Exit Function
      End If
  • Set FileSysObj = CreateObject("Scripting.FileSystemObject")
      Set ScrDrives = FileSysObj.Drives
  • 'ルートの設定
  • Set mynode = TvwName.Nodes.Add(, , "Root", "ディスクトップ", "DeskTop")
      Set mynode = TvwName.Nodes.Add("Root", tvwChild, "Mycom", "マイ コンピュータ", "MyCom")
  •   For Each ScrDrive In ScrDrives
        Select Case ScrDrive.DriveType
          Case 0: DrvName = "不明"
          Case 1: DrvName = "3.5インチFD" & _
                       "(" & ScrDrive.DriveLetter & ":)"
                 imgkey = "35fd"
          Case 2: DrvName = ScrDrive.VolumeName & _
                       "(" & ScrDrive.DriveLetter & ":)"
                 imgkey = "Hdd"
          Case 3: DrvName = "ネットワーク" & ScrDrive.ShareName
                 imgkey = "Netw"
          '準備ができているかの確認
          Case 4: imgkey = "CdRom"
            If ScrDrive.IsReady Then
              DrvName = ScrDrive.VolumeName & _
                      "(" & ScrDrive.DriveLetter & ":)"
            Else
              DrvName = "CD-ROM" & _
                      "(" & ScrDrive.DriveLetter & ":)"
            End If
          Case 5: DrvName = "RAM-DISK" & _
                       "(" & ScrDrive.DriveLetter & ":)"
                 imgkey = "Hdd"
        End Select
        'ツリービュ-に追加
        Set mynode = TvwName.Nodes.Add("Mycom", tvwChild, _
                               ScrDrive.Path & "\", DrvName, imgkey)
        Set mynode = TvwName.Nodes.Add(ScrDrive.Path & "\", tvwChild, _
                               ScrDrive.DriveLetter, "", "Close")
      Next
  • 'スタイルの設定(インデント幅を少し狭くする)
  • TvwName.Indentation = INDENT
  • '初期設定ラベルの変数不可
  • TvwName.LabelEdit = tvwManual
  • 'ファイルオブジェクトの開放
  • Set ScrDrives = Nothing
      Set FileSysObj = Nothing
      Set mynode = Nothing
  • Exit Function
  • ErrTrap:
  •   sfGetDriveList = "sfGetDriveListエラ-です" & Err.Description
      On Error GoTo 0
  • End Function
    Function IsSubFolder(ByVal strFolder As String) As Boolean
    '
    ' 作  者(Writer) : lotusnut)
    ' 目  的(Aim) : * フォルダーにサブフォルダーがあるか確認する
    ' 入  力(Input) : * フォルダー名
    ' 受け渡し(Delivery): *
    ' 戻  値(Return) : * フォルダーの有無
    ' 出  力(Output) : *
    ' 注  釈(Notes) : *
    ' 使用方法(Usage) : *
    ' 履  歴(History) : Ver 0.0.0 2002/11/12 Original


      On Error GoTo ErrTrap
      '変数スクリプトオブジェクトの宣言
      Dim ScrFolder As Folder
      Dim ScrFolders As Folders
      Dim cvt As New clsVntTo

      '戻り値の初期化
      IsSubFolder = False
      '引数の検証&変換
      strFolder = cvt.dfVntToTrimStr(strFolder)
      'フォルダーオブジェクトのセット
      Set FileSysObj = CreateObject("Scripting.FileSystemObject")
      Set ScrFolder = FileSysObj.GetFolder(strFolder)
      Set ScrFolders = ScrFolder.SubFolders

      '***** プロシージャ処理の実行 *****
      If ScrFolders.Count = 0 Then Exit Function
      'ひとつでもサブフォルダーがあるなら真を返す
      IsSubFolder = True
      'オブジェクトの開放
      Set ScrFolder = Nothing
      Set ScrFolders = Nothing
      Set FileSysObj = Nothing

      Exit Function

      'エラートラップ
    ErrTrap:
      Debug.Print " プロシージャエラーです<ErrorNum:" & Err.Number & ">"
      On Error GoTo 0

    End Function
    追記;
    賢明な方はお分かりとは思いますが、もちろんこのコードだけでは正常に動きません。参考ということで、お許しください。
    サードパーティ製のACtiveTreeViewのように、展開マークの+を独自のプロパティで表示できるもの(逆にサブがあっても+マークを消せるとか)が標準TreeViewで、備わっていれば・・・とか TreeView事態にグラフィックのRedraw(Excel VBAの Application.ScreenUpdatingみたいな)が操作できるとか・・・そんな初心者ならではの欲望が・・・でも今回の勉強はかなりVBを理解するのに役立つことが多かったように思います。限りない挑戦はまだまだ続く・・・何チャッテ!!

    メニューTOPへ