EXCEL vba 读取指定文件夹的名字和循环打开文件夹

Question

EXCEL vba
（1）读取指定文件夹下所有文件夹的名字，并储存在指定的excel表格中。
（2）根据储存在excel表格中的文件夹名字顺序，打开每个文件夹，然后再关闭该文件夹，如此循环，直到依次打开和关闭指定文件夹所有文件夹位置。

Answer 1

'------------------------------------------------------------------------------

'

' Form Code

'

'------------------------------------------------------------------------------

Option Explicit

Private row As Integer, col As Integer

Private Sub CloseWindows_Click()

    If TextStartRow.Text = "" Then TextStartRow = 0

    If TextStartCol = "" Then TextStartCol = 0

    If TextPath = "" Then TextPath = "D:\"

    CloseMyDialog TextStartRow, TextStartCol

End Sub

Private Sub GetDir_Click()

    If TextStartRow.Text = "" Then TextStartRow = 0

    If TextStartCol = "" Then TextStartCol = 0

    If TextPath = "" Then

        TextPath = "D:\"

    ElseIf Right(TextPath, 1) <> "\" Then

        TextPath = TextPath & "\"

        End If

    doGetDir TextPath, Val(TextStartRow), Val(TextStartCol)

End Sub

Private Sub ShowWindows_Click()

    If TextStartRow.Text = "" Then TextStartRow = 0

    If TextStartCol = "" Then TextStartCol = 0

    If TextPath = "" Then TextPath = "D:\"

    ShowMyDialog Application.hWnd, TextStartRow, TextStartCol

End Sub

上面是Form上面的

Option Explicit

Dim MyFile, Mypath, MyName

Dim i%, j%

    Dim DirPath() As String

    

Sub GetDir(ByVal Mypath As String, row As Integer, col As Integer)

    ' 显示 C:\ 目录下的名称。

'    MyPath = "d:\电大\"    ' 指定路径。

    MyName = Dir(Mypath, vbDirectory)    ' 找寻第一项。

    Do While MyName <> ""    ' 开始循环。

        ' 跳过当前的目录及上层目录。

        If MyName <> "." And MyName <> ".." Then

            ' 使用位比较来确定 MyName 代表一目录。

            If (GetAttr(Mypath & MyName) And vbDirectory) = vbDirectory Then

                Cells(row + i, col) = Mypath & MyName ' 如果它是一个目录，将其名称显示出来。

                ReDim Preserve DirPath(i)

                DirPath(i) = Mypath & MyName & "\"

                i = i + 1

            End If

        End If

        MyName = Dir    ' 查找下一个目录。

        

    Loop

End Sub

Public Sub doGetDir(ByVal TextPath$, ByVal TextStartRow%, ByVal TextStartCol%)

    j = 1

    i = 1

    Mypath = TextPath

        

    GetDir Mypath, TextStartRow, TextStartCol

    For j = 1 To i - 1

        GetDir DirPath(j), TextStartRow, TextStartCol

        

    Next

    

    

End Sub

'end code---------------------------------------------------

Option Explicit

Public Const OFN_ALLOWMULTISELECT As Long = &H200

Public Const OFN_CREATEPROMPT As Long = &H2000

Public Const OFN_ENABLEHOOK As Long = &H20

Public Const OFN_ENABLETEMPLATE As Long = &H40

Public Const OFN_ENABLETEMPLATEHANDLE As Long = &H80

Public Const OFN_EXPLORER As Long = &H80000

Public Const OFN_EXTENSIONDIFFERENT As Long = &H400

Public Const OFN_FILEMUSTEXIST As Long = &H1000

Public Const OFN_HIDEREADONLY As Long = &H4

Public Const OFN_LONGNAMES As Long = &H200000

Public Const OFN_NOCHANGEDIR As Long = &H8

Public Const OFN_NODEREFERENCELINKS As Long = &H100000

Public Const OFN_NOLONGNAMES As Long = &H40000

Public Const OFN_NONETWORKBUTTON As Long = &H20000

Public Const OFN_NOREADONLYRETURN As Long = &H8000& '*see comments

Public Const OFN_NOTESTFILECREATE As Long = &H10000

Public Const OFN_NOVALIDATE As Long = &H100

Public Const OFN_OVERWRITEPROMPT As Long = &H2

Public Const OFN_PATHMUSTEXIST As Long = &H800

Public Const OFN_READONLY As Long = &H1

Public Const OFN_SHAREAWARE As Long = &H4000

Public Const OFN_SHAREFALLTHROUGH As Long = 2

Public Const OFN_SHAREWARN As Long = 0

Public Const OFN_SHARENOWARN As Long = 1

Public Const OFN_SHOWHELP As Long = &H10

Public Const OFS_MAXPATHNAME As Long = 260

Public Const OFS_FILE_OPEN_FLAGS = OFN_EXPLORER _

             Or OFN_LONGNAMES _

             Or OFN_CREATEPROMPT _

             Or OFN_NODEREFERENCELINKS

Public Const OFS_FILE_SAVE_FLAGS = OFN_EXPLORER _

             Or OFN_LONGNAMES _

             Or OFN_OVERWRITEPROMPT _

             Or OFN_HIDEREADONLY

Public Type OPENFILENAME

  nStructSize       As Long

  hWndOwner         As Long

  hInstance         As Long

  sFilter           As String

  sCustomFilter     As String

  nMaxCustFilter    As Long

  nFilterIndex      As Long

  sFile             As String

  nMaxFile          As Long

  sFileTitle        As String

  nMaxTitle         As Long

  sInitialDir       As String

  sDialogTitle      As String

  flags             As Long

  nFileOffset       As Integer

  nFileExtension    As Integer

  sDefFileExt       As String

  nCustData         As Long

  fnHook            As Long

  sTemplateName     As String

End Type

Public OFN As OPENFILENAME

Public Const WM_CLOSE = &H10

Public Declare Function GetOpenFileName Lib "comdlg32" _

    Alias "GetOpenFileNameA" _

   (pOpenfilename As OPENFILENAME) As Long

Public Declare Function GetSaveFileName Lib "comdlg32" _

   Alias "GetSaveFileNameA" _

  (pOpenfilename As OPENFILENAME) As Long

Public Declare Function GetShortPathName Lib "kernel32" _

    Alias "GetShortPathNameA" _

   (ByVal lpszLongPath As String, _

    ByVal lpszShortPath As String, _

    ByVal cchBuffer As Long) As Long

Public Const WM_INITDIALOG = &H110

Private Const SW_SHOWNORMAL = 1

Public Type RECT

   Left As Long

   Top As Long

   Right As Long

   Bottom As Long

End Type

Public Declare Function GetParent Lib "user32" _

  (ByVal hWnd As Long) As Long

Public Declare Function SetWindowText Lib "user32" _

   Alias "SetWindowTextA" _

  (ByVal hWnd As Long, _

   ByVal lpString As String) As Long

   

Public Declare Function MoveWindow Lib "user32" _

  (ByVal hWnd As Long, _

   ByVal x As Long, _

   ByVal y As Long, _

   ByVal nWidth As Long, _

   ByVal nHeight As Long, _

   ByVal bRepaint As Long) As Long

   

Public Declare Function GetWindowRect Lib "user32" _

  (ByVal hWnd As Long, _

   lpRect As RECT) As Long

   

Public Declare Function SendMessage Lib "user32" _

   Alias "SendMessageA" _

  (ByVal hWnd As Long, _

   ByVal wMsg As Long, _

   ByVal wParam As Long, _

   lParam As Any) As Long

Public Declare Function FindWindow Lib "user32" _

   Alias "FindWindowA" _

  (ByVal lpClassName As Long, _

   ByVal lpWindowName As String) As Long

Public Function FARPROC(ByVal pfn As Long) As Long

 

  FARPROC = pfn

End Function

Public Function OFNHookProc(ByVal hWnd As Long, _

                            ByVal uMsg As Long, _

                            ByVal wParam As Long, _

                            ByVal lParam As Long) As Long

                                   

  

   Dim hwndParent As Long

   Dim rc As RECT

   

   Dim newLeft As Long

   Dim newTop As Long

   Dim dlgWidth As Long

   Dim dlgHeight As Long

   Dim scrWidth As Long

   Dim scrHeight As Long

            

   Select Case uMsg

      Case WM_INITDIALOG

      

         hwndParent = GetParent(hWnd)

         

         If hwndParent <> 0 Then

         

         Call GetWindowRect(hwndParent, rc)

            dlgWidth = rc.Right - rc.Left

            dlgHeight = rc.Bottom - rc.Top

            

            Call MoveWindow(hwndParent, newLeft, newTop, dlgWidth, dlgHeight, True)

            

            OFNHookProc = 1

            

         End If

         

         Case Else:

         

   End Select

End Function

Public Sub ShowFolder(hWnd As Long, Mypath$)

   Dim sFilters As String

   Dim pos As Long

   Dim buff As String

   Dim sLongname As String

   Dim sShortname As String

 

   With OFN

      .nStructSize = Len(OFN)

      .hWndOwner = hWnd

      .sFilter = sFilters

      .nFilterIndex = 2

      .sFile = Space$(1024) & vbNullChar & vbNullChar

      .nMaxFile = Len(.sFile)

      .sDefFileExt = "bas" & vbNullChar & vbNullChar

      .sFileTitle = vbNullChar & Space$(512) & vbNullChar & vbNullChar

      .nMaxTitle = Len(OFN.sFileTitle)

      .sInitialDir = Mypath & vbNullChar & vbNullChar

      .sDialogTitle = Mypath & vbNullChar & vbNullChar

      .flags = OFS_FILE_OPEN_FLAGS Or _

               OFN_ALLOWMULTISELECT Or _

               OFN_EXPLORER Or _

               OFN_ENABLEHOOK

      .fnHook = FARPROC(AddressOf OFNHookProc)

   End With

   

   GetOpenFileName OFN

   

   End Sub

Public Sub CloseFolder(Mypath As String)

Dim hWnd As Long

    hWnd = FindWindow(0, Mypath)

    Call SendMessage(hWnd, WM_CLOSE, 0&, ByVal 0&)

End Sub

Public Sub ShowMyDialog(MyhWnd As Long, TextStartRow As Integer, TextStartCol As Integer)

    Dim row, col

    Dim i

    Dim hWnd As Long

    hWnd = MyhWnd

     i = 1: row = TextStartRow: col = TextStartCol

   

   Do While Cells(i + row, col) <> ""

   

        Shell "C:\Windows\explorer.exe " & Cells(i + row, col)

    

'        ShowFolder hWnd, Cells(i + row, col)

'        hWnd = FindWindow(0, Cells(i + row, col))

        i = i + 1

    Loop

End Sub

Public Sub CloseMyDialog(TextStartRow As Integer, TextStartCol As Integer)

    

        Dim row, col

    Dim i

    

     i = 1: row = TextStartRow: col = TextStartCol

   

   Do While Cells(i + row, col) <> ""

        CloseFolder pathToName(Cells(i + row, col))

        i = i + 1

    Loop

End Sub

Private Function pathToName(Mypath$) As String

    Dim str() As String

    str = Split(Mypath, "\")

    pathToName = str(UBound(str))

End Function

Answer 2

就是遍历文件夹嘛,关键代码如下
在工程-引用里添加 microsoft scripting run time
然后用下面的两个函数递归遍历 就可以了
sub main()
Dim objFSO As Object
Dim objTemplateFolder As Object
Set objFSO = New Scripting.FileSystemObject
Set objTemplateFolder = objFSO.GetFolder(“D:\”)
getFiles objTemplateFolder
end sub

Sub getFiles(ByRef theFolder As Object)
Dim folder As Object
Dim c As New Scripting.FileSystemObject
‘此处执行你的操作：打开关闭文件夹，取名字等
For Each folder In theFolder.subFolders
getFiles folder ’递归遍历子文件夹
Next
End Sub

Answer 3

我以前编制过生成当前文件夹下所有目录的代码，给我邮箱，我发给你。