[分享]我的自制目录文件浏览窗

donghan

挺漂亮的截面呢

ningyong58

VBA密码-31QR
这个程序在VB示例中有.只是在VBA中用的较少而宜.
'*********************
'名称：文件浏览器
'代码：ldhyob
'日期：2003.06
'*********************
Dim nodx As Node
Dim qu, currentpath As String '当前所选驱动器根目录及路径
Dim oldl As Integer

Private Sub ComboBox1_Click()
Dim fs, f, f1, fc
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(currentpath)
Set fc = f.Files
Me.ListBox1.Clear
If Me.ComboBox1.Value <> "图形文件(*.jpg;*.bmp;*.wmf;*.gif)" Then
   Me.Left = oldl
   Me.Width = 323.25
Else
   Me.Left = oldl - 151.5 / 2
   Me.Width = 474.75
End If
For Each f1 In fc
    Select Case Me.ComboBox1.Value
        Case "全部文件(*.*)"
             Me.ListBox1.AddItem f1.Name
        Case "图形文件(*.jpg;*.bmp;*.wmf;*.gif)"
        If VBA.LCase(VBA.Right(f1.Name, 3)) = "jpg" Or VBA.LCase(VBA.Right(f1.Name, 3)) = "bmp" _
        Or VBA.LCase(VBA.Right(f1.Name, 3)) = "wmf" Or VBA.LCase(VBA.Right(f1.Name, 3)) = "gif" Then Me.ListBox1.AddItem f1.Name
        Case "EXCEL文档(*.xls;*.xla)"
        If VBA.LCase(VBA.Right(f1.Name, 3)) = "xls" Or VBA.LCase(VBA.Right(f1.Name, 3)) = "xla" Then Me.ListBox1.AddItem f1.Name
        Case "DOC文档(*.doc)"
        If VBA.LCase(VBA.Right(f1.Name, 3)) = "doc" Then Me.ListBox1.AddItem f1.Name
        Case "文本文件(*.txt;*.ini)"
        If VBA.LCase(VBA.Right(f1.Name, 3)) = "txt" Or VBA.LCase(VBA.Right(f1.Name, 3)) = "ini" Then Me.ListBox1.AddItem f1.Name
        Case "可执行文件(*.exe;*.com;*.bat;*.dll)"
        If VBA.LCase(VBA.Right(f1.Name, 3)) = "exe" Or VBA.LCase(VBA.Right(f1.Name, 3)) = "com" _
        Or VBA.LCase(VBA.Right(f1.Name, 3)) = "bat" Or VBA.LCase(VBA.Right(f1.Name, 3)) = "dll" Then Me.ListBox1.AddItem f1.Name
    End Select
Next
End Sub

Private Sub CommandButton1_Click()
  MsgBox "您选择的文件是：" & currentpath & ListBox1.Value, 0, "ldhyob的文件浏览器"
End Sub

Private Sub CommandButton2_Click()
   Unload Me
End Sub

Private Sub ImageCombo1_Click()
Dim fs, f1, dc
Dim ss2 As String
On Error Resume Next
For i = 1 To ImageCombo1.ComboItems.Count
   If ImageCombo1.ComboItems.Item(i).Selected Then
       qu = VBA.Left(ImageCombo1.ComboItems.Item(i), 1) & ":\"
   End If
Next i
Set fs = CreateObject("Scripting.FileSystemObject")
Set dc = fs.Drives
Set f = fs.GetFolder(qu)
Set sf = f.subfolders
TreeView1.Nodes.Clear
For Each f1 In sf
    Set nodx = TreeView1.Nodes.Add(, , f1.Name, f1.Name, 4)
Next
Set fc = f.Files
Me.ListBox1.Clear
For Each f1 In fc
    Select Case Me.ComboBox1.Value
        Case "全部文件(*.*)"
             Me.ListBox1.AddItem f1.Name
        Case "图形文件(*.jpg;*.bmp;*.wmf;*.gif)"
        If VBA.LCase(VBA.Right(f1.Name, 3)) = "jpg" Or VBA.LCase(VBA.Right(f1.Name, 3)) = "bmp" _
        Or VBA.LCase(VBA.Right(f1.Name, 3)) = "wmf" Or VBA.LCase(VBA.Right(f1.Name, 3)) = "gif" Then Me.ListBox1.AddItem f1.Name
        Case "EXCEL文档(*.xls;*.xla)"
        If VBA.LCase(VBA.Right(f1.Name, 3)) = "xls" Or VBA.LCase(VBA.Right(f1.Name, 3)) = "xla" Then Me.ListBox1.AddItem f1.Name
        Case "DOC文档(*.doc)"
        If VBA.LCase(VBA.Right(f1.Name, 3)) = "doc" Then Me.ListBox1.AddItem f1.Name
        Case "文本文件(*.txt;*.ini)"
        If VBA.LCase(VBA.Right(f1.Name, 3)) = "txt" Or VBA.LCase(VBA.Right(f1.Name, 3)) = "ini" Then Me.ListBox1.AddItem f1.Name
        Case "可执行文件(*.exe;*.com;*.bat;*.dll)"
        If VBA.LCase(VBA.Right(f1.Name, 3)) = "exe" Or VBA.LCase(VBA.Right(f1.Name, 3)) = "com" _
        Or VBA.LCase(VBA.Right(f1.Name, 3)) = "bat" Or VBA.LCase(VBA.Right(f1.Name, 3)) = "dll" Then Me.ListBox1.AddItem f1.Name
    End Select
Next
End Sub

Private Sub ListBox1_Click()
On Error Resume Next
If Me.ComboBox1.Value = "图形文件(*.jpg;*.bmp;*.wmf;*.gif)" Then
   Me.Image1.Picture = LoadPicture(currentpath & ListBox1.Value)
End If
End Sub

Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
  MsgBox "您选择的文件是：" & currentpath & ListBox1.Value, 0, "ldhyob的文件浏览窗"
End Sub
Private Sub TreeView1_NodeClick(ByVal Node As MSComctlLib.Node)
  Dim ss As String
  Dim fs, f, f2, f1, fc
  Set fs = CreateObject("Scripting.FileSystemObject")
  If TreeView1.SelectedItem.Children = 0 Then '若当前节点并无子节点
    For i = 1 To TreeView1.Nodes.Count
    If TreeView1.Nodes(i).Selected Then
         Set f = fs.GetFolder(qu & TreeView1.Nodes(i).FullPath & "\")
        If f.subfolders.Count <> 0 Then '若该目录下存有子目录
            For Each f2 In f.subfolders
                Set nodx = TreeView1.Nodes.Add(Replace(TreeView1.Nodes(i).FullPath, "\", ""), tvwChild, Replace(TreeView1.Nodes(i).FullPath, "\", "") & f2.Name, f2.Name, 4)
            Next
        End If
    End If
    Next i
  End If
  For i = 1 To TreeView1.Nodes.Count
      If TreeView1.Nodes(i).Selected Then
         currentpath = qu & TreeView1.Nodes(i).FullPath & "\"
      End If
  Next i
         Set f = fs.GetFolder(currentpath)
         Set fc = f.Files
         Me.ListBox1.Clear
         For Each f1 In fc
          Select Case Me.ComboBox1.Value
           Case "全部文件(*.*)"
                 Me.ListBox1.AddItem f1.Name
           Case "图形文件(*.jpg;*.bmp;*.wmf;*.gif)"
              If VBA.LCase(VBA.Right(f1.Name, 3)) = "jpg" Or VBA.LCase(VBA.Right(f1.Name, 3)) = "bmp" _
              Or VBA.LCase(VBA.Right(f1.Name, 3)) = "wmf" Or VBA.LCase(VBA.Right(f1.Name, 3)) = "gif" Then Me.ListBox1.AddItem f1.Name
           Case "EXCEL文档(*.xls;*.xla)"
              If VBA.LCase(VBA.Right(f1.Name, 3)) = "xls" Or VBA.LCase(VBA.Right(f1.Name, 3)) = "xla" Then Me.ListBox1.AddItem f1.Name
           Case "DOC文档(*.doc)"
              If VBA.LCase(VBA.Right(f1.Name, 3)) = "doc" Then Me.ListBox1.AddItem f1.Name
           Case "文本文件(*.txt;*.ini)"
              If VBA.LCase(VBA.Right(f1.Name, 3)) = "txt" Or VBA.LCase(VBA.Right(f1.Name, 3)) = "ini" Then Me.ListBox1.AddItem f1.Name
           Case "可执行文件(*.exe;*.com;*.bat;*.dll)"
              If VBA.LCase(VBA.Right(f1.Name, 3)) = "exe" Or VBA.LCase(VBA.Right(f1.Name, 3)) = "com" _
              Or VBA.LCase(VBA.Right(f1.Name, 3)) = "bat" Or VBA.LCase(VBA.Right(f1.Name, 3)) = "dll" Then Me.ListBox1.AddItem f1.Name
          End Select
        Next
End Sub

Private Sub UserForm_Activate()
oldl = Me.Left
End Sub

Private Sub UserForm_Initialize()
Dim i As Integer
Dim fs, f1, f2, d, dc, n
Dim s As String
On Error Resume Next
ImageCombo1.ImageList = ImageList1
Set fs = CreateObject("Scripting.FileSystemObject")
Set dc = fs.Drives
i = 0
For Each d In dc
    i = i + 1
    s = ""
    s = s & d.DriveLetter & " - "
    If d.DriveType = 3 Then
        n = d.ShareName
    Else
        n = d.VolumeName
    End If
    s = s & n & vbCrLf
    ImageCombo1.ComboItems.Add i, "", s, GetDriveType(VBA.Left(s, 1) & ":")
Next
ImageCombo1.ComboItems.Item(2).Selected = True
qu = VBA.Left(ImageCombo1.ComboItems.Item(2), 1) & ":\"
currentpath = qu
TreeView1.LineStyle = tvwTreeLines
TreeView1.ImageList = ImageList1
TreeView1.Style = tvwTreelinesPlusMinusPictureText
Set f = fs.GetFolder("c:\")
s = qu
Set sf = f.subfolders
For Each f1 In sf
    Set nodx = TreeView1.Nodes.Add(, , f1.Name, f1.Name, 4)
    s = qu & f1.Name & "\"
    'GetSubFolder s, f1.Name '为提高效率先不全盘列出所有目录
Next
Me.ComboBox1.AddItem "全部文件(*.*)"
Me.ComboBox1.AddItem "图形文件(*.jpg;*.bmp;*.wmf;*.gif)"
Me.ComboBox1.AddItem "EXCEL文档(*.xls;*.xla)"
Me.ComboBox1.AddItem "DOC文档(*.doc)"
Me.ComboBox1.AddItem "文本文件(*.txt;*.ini)"
Me.ComboBox1.AddItem "可执行文件(*.exe;*.com;*.bat;*.dll)"
Me.ComboBox1.Value = "全部文件(*.*)"
Set f = fs.GetFolder(folderspec)
Set fc = f.Files
For Each f1 In fc
    Me.ListBox1.AddItem f1.Name
Next
Me.Width = 323.25
End Sub
Sub GetSubFolder(ss As String, sn As String)  '此为递归算法,用来遍历取出所有子目录
Dim f2, fs
Set fs = CreateObject("Scripting.FileSystemObject")
If fs.GetFolder(ss).subfolders.Count <> 0 Then
       For Each f2 In fs.GetFolder(ss).subfolders
         Set nodx = TreeView1.Nodes.Add(sn, tvwChild, sn & f2.Name, f2.Name, 4)
         GetSubFolder ss & f2.Name & "\", sn & f2.Name
         DoEvents
       Next
End If
End Sub
Sub ShowDriveList()
    Dim fs, d, dc, s, n
    On Error Resume Next
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set dc = fs.Drives
    For Each d In dc
        s = s & d.DriveLetter & " - "
        If d.DriveType = 3 Then
            n = d.ShareName
        Else
            n = d.VolumeName
        End If
        s = s & n & vbCrLf
    Next
    MsgBox s
End Sub
Function GetDriveType(drvpath) As Integer
    Dim fs, d, s, t
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set d = fs.GetDrive(drvpath)
    GetDriveType = 2
    Select Case d.DriveType
        Case 0: t = "Unknown"
        Case 1: t = "Removable"
            GetDriveType = 1
        Case 2: t = "Fixed"
        Case 3: t = "Network"
        Case 4: t = "CD-ROM"
            GetDriveType = 3
        Case 5: t = "RAM Disk"
    End Select
End Function
Sub ShowFolderList(folderspec)
    Dim fs, f, f1, s, sf
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(folderspec)
    Set sf = f.subfolders
    For Each f1 In sf
        s = s & f1.Name
        s = s & vbCrLf
    Next
    MsgBox s
End Sub
Sub ShowfilesList(folderspec)
    Dim fs, f, f1, fc, s
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(folderspec)
    Set fc = f.Files
    For Each f1 In fc
        s = s & f1.Name
        s = s & vbCrLf
    Next
    MsgBox s
End Sub
Private Sub TreeView1_Expand(ByVal Node As MSComctlLib.Node)
  Node.ExpandedImage = 5
End Sub

Private Sub UserForm_Terminate()
   Me.Image1.Picture = LoadPicture("")
   Application.DisplayAlerts = False
   ThisWorkbook.Close
End Sub

boatwxp

谢谢分享，好好学习学习！！！

北方的狼2009

顶一个，如果双击可以打开文件就更好了

easy863

楼主强大……

飞云楼主

淘金，学习学习。

txh6692

窗口及功能不错！强收了！可出现错误提示,不知为何？？

zhangfz18

正是我想要的！

fengzhikuye

找好长时间了

hhp1598011

不愧为精华!