Visual Basic 6.0

■　No.2　ツリービューコントロールへの表示を考える。その後・・・

前回の『ツリービューコントロールを考える』から、だいぶ時間がたってしまいましたが、久しぶりにまたこの難題？に取り組むことになりました。今までの勉強で、判ってきたことは、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を理解するのに役立つことが多かったように思います。限りない挑戦はまだまだ続く・・・何チャッテ！！

  メニューＴＯＰへ