带VBA的递归目录列表 [英] Recursive Directory Listings with VBA

问题描述

大家好，我正在为高级研讨会写一些代码作为商业专业，但我不是一个强大的程序员。该项目涉及我在VBA中编写将通过文件目录的代码，并在excel中的单元格中逐行生成规定列表中每个文件的文件路径。

这就是我所拥有的到目前为止，它创建了一个新页面，但是，到目前为止，我没有得到任何输出，但它没有抛出任何错误。它目前只能拉出其他.xls文件进行测试。



如果它有帮助，有问题的文件结构如下所示



''文件'' - > ''伊恩'的东西'' - > ''伊恩'的东西'' - > ''IT商业研讨会'' - > ''IT笔记商务研讨会''





选项明确

Hello everyone, I''m writing some code for a senior seminar as a business major, however I am not a strong programmer. The project involves me writing code in VBA that will go through a file directory, and produce line by line in the cells in excel the file paths for each file in the prescribed listing.
This is what I have so far, it creates a new page, however, so far I am not getting any output, but it throws no errors. It is currently enabled to only pull other .xls files for testing''s sake.

If it helps at all, the file structure in question looks something like the following

''Documents'' --> ''Ian''s Stuff'' --> ''Ian''s Stuff'' --> ''Business Seminar in IT'' --> ''Business Seminar in IT Notes''


Option Explicit

Sub FullDir()
ActiveWorkbook.Sheets.Add
GetFiles "c:\documents\", ".xls"
End Sub

Sub GetFiles(strRootDir As String, Optional strType As String)

Dim strDirName As String
Dim bTypeMatch As Boolean
Dim colDirs As Collection
Dim lDirCounter As Long
Dim lIndex As Long

Set colDirs = New Collection
colDirs.Add strRootDir
lDirCounter = 1
lIndex = 2

''check for sub directories and make a recursive call to the lowest level dirs first

Do While lDirCounter <= colDirs.Count
strRootDir = colDirs(lDirCounter)
strDirName = Dir(strRootDir, vbDirectory + vbNormal)
Do While strDirName <> ""
If strDirName <> "." And strDirName <> ".." Then
If (GetAttr(strRootDir & strDirName) And vbDirectory) = vbDirectory Then

''add to the directories collection so that this will be done later

colDirs.Add strRootDir & strDirName & "\"
Else

''we found a normal file

bTypeMatch = False
If strType = "*.*" Then
bTypeMatch = True
ElseIf UCase(Right(strDirName, Len(strType))) = UCase(strType) Then
bTypeMatch = True
End If
If bTypeMatch = True Then
''we found a valid file

Cells(lIndex, 1) = strRootDir & strDirName
lIndex = lIndex + 1
End If
End If
End If
strDirName = Dir
Loop
lDirCounter = lDirCounter + 1
Loop
End Sub

推荐答案

我修改了解决方案1中的代码以搜索.xls并转到添加到Excel工作表。下面的代码可以复制并粘贴到Excel宏（ThisWorkBook）中。

I modified the code from Solution 1 to search for ".xls" and to add to an Excel worksheet. The code below can be copied and pasted into an Excel Macro (ThisWorkBook).

Option Explicit
''
Dim lIndex
''
Private Sub ProcessItem(ByVal objItem, ByVal strFolderSpec As String)
''
'' Adds a filename to the spreadsheet
''
'' File Attributes are here in case you want to use them for something
''
Dim strAttr
strAttr = Space(4)
If objItem.Attributes And 1 Then
    strAttr = "R   " '' ReadOnly
End If
If objItem.Attributes And 2 Then
    strAttr = Left(strAttr, 1) & "H  " '' Hidden
End If
If objItem.Attributes And 4 Then
    strAttr = Left(strAttr, 2) & "S " '' System
End If
If objItem.Attributes And 32 Then
    strAttr = Left(strAttr, 3) & "A" '' Archive
End If
''
Cells(lIndex, 1) = strFolderSpec & "\" & objItem.Name
lIndex = lIndex + 1
''
End Sub
''
Private Sub ProcessFiles(ByVal strFolderSpec As String, ByVal strFilter As String)
''
'' Processes directories and files in directories
''
Dim objFSO
Dim objFolder
Dim objFileCollection
Dim objFolderCollection
Dim objItem
Dim objSubFolder
Dim strAttr
Set objFSO = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Err.Clear
Set objFolder = objFSO.GetFolder(strFolderSpec)
If Err.Number = 0 Then
    Err.Clear
    Set objFileCollection = objFolder.Files
    If Err.Number = 0 Then
        Err.Clear
        For Each objItem In objFileCollection
            If Not (IsEmpty(objItem)) Then '' Handles fact that some subfolders are not real subfolders
                ''Debug.Print objItem.Name
                ''
                '' Select only those that exactly match the filter
                ''
                If LCase(Right(objItem.Name, Len(strFilter))) = LCase(strFilter) Then
                     Call ProcessItem(objItem, strFolderSpec)
                End If
            End If
        Next
    Else
        Debug.Print Err.Number & " " & Err.Message & " " & objFolder.Path
    End If
    On Error Resume Next
    Err.Clear
    Set objFolderCollection = objFolder.SubFolders
    If Err.Number = 0 Then
        Err.Clear
        For Each objSubFolder In objFolderCollection
            If Not (IsEmpty(objSubFolder)) Then '' Handles fact that some subfolders are not real subfolders
                ''Debug.Print objSubFolder.Path
                ''
                '' Process a subfolder
                ''
                Call ProcessFiles(objSubFolder.Path, strFilter)
            End If
        Next
    Else
        Debug.Print Err.Number & " " & Err.Message & " " & objFolder.Path
    End If
    Set objItem = Nothing
    Set objFileCollection = Nothing
    Set objSubFolder = Nothing
    Set objFolderCollection = Nothing
Else
    MsgBox "GetFolder Error" & vbNewLine & _
        Err.Description & "(" & Err.Number & ")" & vbNewLine & _
        strFolderSpec, vbCritical
    On Error GoTo 0
End If
Set objSubFolder = Nothing
Set objFolder = Nothing
Set objFSO = Nothing
End Sub

Public Sub FullDir()
'' Starts Here
''
lIndex = 2
ActiveWorkbook.Sheets.Add
Call ProcessFiles("C:\Users\<yourusername>\Documents", ".xls")
''
'' Ends  here
''
End Sub

下面是我开发的目录递归的VBScript示例。我把这个文件放在我的SENDTO目录中，这样我就可以右键单击一个目录名，然后从发送到上下文菜单中选择这个脚本文件。

Below is a VBScript example of directory recursion that I developed. I put this file in my SENDTO directory so that I can right-click on a directory name and select this script file from the Send to context menu.

Option Explicit

''
'' CreateDirectoryListing.VBS
'' ===========================
''    Mike Meinz
''    11 Janury 2004
''
''
Const TemporaryFolder = 2
CONST THEFILENAME="_DirectoryListing.TXT"
Const MinWidth = 36
''
Dim objTempFolder 
Dim objArgs
Dim objLogFSO
Dim objLogFile
Dim wshShell
Dim strFileName
''
Sub ProcessItem(ByVal objItem, ByVal intMax)
Dim strAttr
strAttr = Space(4)
If objItem.Attributes And 1 Then
    strAttr = "R   " '' ReadOnly
End If
If objItem.Attributes And 2 Then
    strAttr=LEFT(strAttr, 1) & "H  " '' Hidden
End If
If objItem.Attributes And 4 Then
    strAttr=LEFT(strAttr, 2) & "S " '' System
End If
If objItem.Attributes And 32 Then
    strAttr=LEFT(strAttr,3) &  "A" '' Archive
End If
Call LogIt( _
    Left(objItem.Name & Space(intMax), intMax) & vbTab & _
    objItem.DateCreated & vbTab & _
    objItem.DateLastModified & vbTab & _
    objItem.Size & vbTab & _
    strAttr & vbTab & _
    objItem.Type, True)
End Sub
''
Sub ProcessFiles(ByVal strFolderSpec)
Dim objFSO
Dim objFolder
Dim objFileCollection
Dim objFolderCollection
Dim objItem
Dim objSubFolder
Dim strAttr
Dim intMax
Call LogIt(strFolderSpec, True)
Set objFSO = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Err.Clear
Set objFolder = objFSO.GetFolder(strFolderSpec)
If Err.Number = 0 Then
    On Error GoTo 0
    Set objFileCollection = objFolder.Files
    For Each objItem In objFileCollection
        '' Determine Maximum FileName size
        If intMax < Len(objItem.Name) Then
            intMax = Len(objItem.Name)
        End If
    Next
    If intMax < MinWidth Then 
        intMax = MinWidth '' Minimum Size is MinWidth
    End If
    For Each objItem In objFileCollection
        Call ProcessItem(objItem, intMax)
    Next
    Call LogIt("", True)
    Set objFolderCollection = objFolder.SubFolders
    For Each objSubFolder In objFolderCollection
        Call ProcessFiles(objSubFolder.Path)
    Next
    Set objItem = Nothing
    Set objFileCollection = Nothing
    Set objSubFolder = Nothing
    Set objFolderCollection = Nothing
Else
    MsgBox "GetFolder Error" & vbNewLine & _
        Err.Description & "(" & Err.Number & ")" & vbNewLine & _
        strFolderSpec, vbCritical
    On Error GoTo 0
End If
Set objSubFolder = Nothing
Set objFolder = Nothing
Set objFSO = Nothing
End Sub

Sub LogIt(ByVal strMessage, ByVal bNewLine)
If bNewLine Then
    objLogFile.WriteLine strMessage
Else
    objLogFile.Write strMessage
End If
End Sub
''**********************************************************************
'' Starts Here
''
Set objArgs = WScript.Arguments
Set objLogFSO = CreateObject("Scripting.FileSystemObject")
Set objTempFolder = objLogFSO.GetSpecialFolder(TemporaryFolder)
Set objLogFile = objTempFolder.CreateTextFile(THEFILENAME,True,True)
strFileName = objTempFolder.path & "\" & THEFILENAME
Call LogIt(Left("FileName" + Space(MinWidth), MinWidth) & vbTab & _
    LEFT("DateCreated"+SPACE(20),20) & vbTab & _
    LEFT("DateLastModified"+SPACE(20),20) & vbTab & _
    "Size" & vbTab & _
    "Attr" & vbTab & _
    "FileType", True)
Call ProcessFiles(objArgs(0))
objLogFile.Close
Set objLogFile = Nothing
Set wshShell = CreateObject("WScript.Shell")
wshShell.CurrentDirectory=objTempFolder.path
wshShell.Run ("Notepad.exe " & strFileName)
Set objTempFolder=Nothing
Set objLogFSO = Nothing
Set wshShell = Nothing
Set objArgs = Nothing
''
'' Ends  here
''

这篇关于带VBA的递归目录列表的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！