Option Explicit
    Private Const LB_SETHORIZONTALEXTENT = &H194
    Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

      Private Sub Command1_Click()
              Dim ff    As String
              Dim fn     As Long
              Dim i     As Long
              Dim Fpath As String
              Dim obj As Object

              For Each obj In Me '.Frame1
                If TypeOf obj Is CheckBox Then
                     'obj.Value = True
                    If obj.Value = 1 Then
                         Fpath = Left(obj.Caption, 1) & ":"
                        ' MsgBox Fpath
                          Call FindAllFolder(Fpath)
                    End If
                End If
              Next

             ' Fpath = Text1.Text
             ' If Len(Fpath) = 1 Then Fpath = Fpath & ":"

      End Sub

      Private Function FindAllFolder(ByVal FilePath As String)
              Dim lngIndex      As Long
              Dim strDir        As String
              Dim strSubDirs()  As String
              Dim sFiles As String
              If Right(FilePath, 1) <> "\" Then ''''追加路径
                      FilePath = FilePath & "\"
              End If

              strDir = Dir(FilePath & "*.*") '''获得当前的路径

              Do While Len(strDir) '''''遍历当前文件夹的文件
                  DoEvents

                  sFiles = FilePath & strDir
                  List1.AddItem sFiles
                  strDir = Dir
              Loop

              lngIndex = 0
              strDir = Dir(FilePath & "*.*", 16)
              Do While Len(strDir)
                DoEvents
                 If Left(strDir, 1) <> "." Then
                    If GetAttr(FilePath & strDir) And vbDirectory Then
                        lngIndex = lngIndex + 1
                        ReDim Preserve strSubDirs(1 To lngIndex)
                        strSubDirs(lngIndex) = FilePath & strDir & "\"
                    End If
                 End If
                 strDir = Dir  '''''文件夹下的所有文件 dir("")
              Loop

              For lngIndex = 1 To lngIndex
                    DoEvents
                    Call FindAllFolder(strSubDirs(lngIndex)) '''递归调用
              Next lngIndex
      End Function
    Private Sub Form_Load()
        SendMessage List1.hwnd, LB_SETHORIZONTALEXTENT, 500, 0 '''''list1 添加水平滚动条！
    End Sub