VB用TreView罗列出指定目录下的所有目录及文件，并自动加上系统

准备工作需要加入控件，选择与已选中的“Microsoft Windows Common Controls X.X”相关的文件名。对于旧文件，版本号是 5.0，对于新文件，版本号是 6.0。

窗体加入一个按钮，一个Treeview，改名为FileList，一个Imagelist改名为Img，Imagelist的大小我这里设置为16x16,插入一个图标作为文件夹的图标，

窗体中代码好下：

Private Sub Form_Load()
    Me.WindowState = 0
End Sub

Private Sub Command1_Click()
        Dim loaddd As String
        Dim stMap As Object
        MsgBox Command1.Caption & "存档路径没有设置",vbInformation,"技术文件及规范"
        loaddd = "请选择" & Command1.Caption & "存档路径:"
        Set stMap = CreateObject("shell.application").BrowseForFolder(0,loaddd,&H1)
        If Not stMap Is Nothing Then
            FileLoad = stMap.self.Path & ""
        Else
        End If
        Set stMap = Nothing
        On Error Resume Next
        Dir (FileLoad)
        If Err.Number = 52 Then
            MsgBox "没有权限打开指定路径，请确认一下能否连接到服务器","很遗憾"
            Exit Sub
        End If
        FileList.Nodes.Clear
        InfoFiles FileLoad,"*.*"
End Sub

Private Sub FileList_DblClick()
    If FileList.SelectedItem.Children = 0 Then
        FilePath = FileLoad & FileList.SelectedItem.FullPath
        Call ShellExecute(Form1.hwnd,vbNullString,FilePath,1)
    End If
End Sub

Private Sub FileList_NodeClick(ByVal Node As MSComctlLib.Node)
    Dim FilePath As String
    If FileList.SelectedItem.Children = 0 Then
        FilePath = FileLoad & FileList.SelectedItem.FullPath
        InfoFiles FilePath,"*.*"
    End If
End Sub

Public FileLoad As String
Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long,ByVal lpOperation As String,ByVal lpFile As String,ByVal lpParameters As String,ByVal lpDirectory As String,ByVal nShowCmd As Long) As Long

Public Const MAX_PATH As Integer = 260
Public Type TypeIcon
  cbSize As Long
  picType As PictureTypeConstants
  hIcon As Long
End Type
Public Type CLSID
  id(16) As Byte
End Type
Public Type SHFILEINFO
  hIcon As Long
  iIcon As Long
  dwAttributes As Long
  szDisplayName As String * MAX_PATH
  szTypeName As String * 80
End Type
Public Declare Function OleCreatePictureIndirect Lib "oleaut32.dll" (pDicDesc As TypeIcon,riid As CLSID,ByVal fown As Long,lpUnk As Object) As Long
Public Declare Function SHGetFileInfo Lib "shell32.dll" Alias "SHGetFileInfoA" (ByVal pszPath As String,ByVal dwFileAttributes As Long,psfi As SHFILEINFO,ByVal cbFileInfo As Long,ByVal uFlags As Long) As Long
Public Const SHGFI_ICON = &H100
Public Const SHGFI_LARGEICON = &H0
Public Const SHGFI_SMALLICON = &H1

Public Function InfoFiles(Path As String,FileType As String)   '历遍指定路径中的文件
  Dim Files() As String '文件路径
  Dim Folder() As String '文件夹路径
  Dim Father() As String
  Dim a,b As Long
  Dim 后缀名 As String
  Dim sPath As String
  Dim Nodeindex As Node
  Form1.FileList.ImageList = Form1.Img    '图标与图片控件关联
  On Error Resume Next
  If Right(Path,1) <> "" Then Path = Path & ""
  sPath = Dir(Path & FileType) '查找第一个文件
  Do While Len(sPath) '循环到没有文件为止
    后缀名 = Trim(Mid(sPath,InStrRev(sPath,".") + 1))
    Form1.Img.ListImages.Add,后缀名,GetIcon(Path & sPath)
    If Path = FileLoad Then
      Form1.FileList.Nodes.Add,sPath,后缀名
    Else
      Father = Split(Path,"")
      Form1.FileList.Nodes.Add Father(UBound(Split(Path,"")) - 1),tvwChild,后缀名
    End If
    Nodeindex.Sorted = True
    sPath = Dir '查找下一个文件
    DoEvents '让出控制权
  Loop
  sPath = Dir(Path & "",vbDirectory) '查找第一个文件夹
  Do While Len(sPath) '循环到没有文件夹为止
    If Left(sPath,1) <> "." Then '为了防止重复查找
      If GetAttr(Path & "" & sPath) And vbDirectory Then '如果是文件夹则。。。。。。
        a = a + 1
        ReDim Preserve Folder(1 To a)
        Folder(a) = Path & sPath & "" '将目录和文件夹名称组合形成新的目录,并存放到数组中
        If Path = FileLoad Then
          Set Nodeindex = Form1.FileList.Nodes.Add(,1)
        Else
          Father = Split(Path,"")
          Set Nodeindex = Form1.FileList.Nodes.Add(Father(UBound(Split(Path,1)
        End If
        Nodeindex.Sorted = True
      End If
    End If
    sPath = Dir '查找下一个文件夹
    DoEvents '让出控制权
  Loop
  'For b = 1 To a '使用递归方法，遍历所有目录
  '  Form1 Folder(b),FileType
  'Next
End Function

Public Function IconToPicture(hIcon As Long) As IPictureDisp  'ICON 转 Picture
  Dim cls_id As CLSID
  Dim hRes As Long
  Dim new_icon As TypeIcon
  Dim lpUnk As IUnknown
  With new_icon
    .cbSize = Len(new_icon)
    .picType = vbPicTypeIcon
    .hIcon = hIcon
  End With
  With cls_id
    .id(8) = &HC0
    .id(15) = &H46
  End With
  Dim CA As ColorConstants
  hRes = OleCreatePictureIndirect(new_icon,cls_id,1,lpUnk)
  If hRes = 0 Then Set IconToPicture = lpUnk
End Function

Public Function GetIcon(FileName,Optional ByVal SmallIcon As Boolean = True) As IPictureDisp  '获得文件ICON
  Debug.Print FileName
  Dim Index As Integer
  Dim hIcon As Long
  Dim item_num As Long
  Dim icon_pic As IPictureDisp
  Dim sh_info As SHFILEINFO
  If SmallIcon = True Then
    SHGetFileInfo FileName,sh_info,Len(sh_info),SHGFI_ICON + SHGFI_SMALLICON
  Else
    SHGetFileInfo FileName,SHGFI_ICON + SHGFI_LARGEICON
  End If
  hIcon = sh_info.hIcon
  Set icon_pic = IconToPicture(hIcon)
  Set GetIcon = icon_pic
End Function

（编辑：李大同）

【声明】本站内容均来自网络，其相关言论仅代表作者个人观点，不代表本站立场。若无意侵犯到您的权利，请及时与联系站长删除相关内容!