vba

Question

• में उपनिवेशियों की सूची प्राप्त करें मैं एक फ़ोल्डर में सभी subdirs की एक सूची प्राप्त करना चाहता हूँ।
• यदि यह काम करता है तो मैं इसे एक पुनरावर्ती फ़ंक्शन में विस्तारित करना चाहता हूं।

हालांकि उपनिवेश प्राप्त करने के लिए मेरा प्रारंभिक दृष्टिकोण विफल रहता है। यह बस फ़ाइलों सहित सब कुछ पता चलता है:

sDir = Dir(sPath, vbDirectory) 
Do Until LenB(sDir) = 0 
    Debug.Print sDir 
    sDir = Dir 
Loop 

सूची के साथ शुरू होता है '..' और कई फ़ोल्डर्स और '.txt' फाइलों के साथ समाप्त होता है।

संपादित करें: मैं जोड़ने चाहिए कि इस पद में चलाना चाहिए, नहीं एक्सेल (कई कार्यों वर्ड में उपलब्ध नहीं हैं) और यह Office 2010

संपादित है 2:

एक प्रकार निर्धारित कर सकते हैं

iAtt = GetAttr(sPath & sDir) 
If CBool(iAtt And vbDirectory) Then 
    ... 
End If 

लेकिन का उपयोग कर परिणाम की है कि मुझे, नई समस्याओं को दे दिया ताकि मैं अब Scripting.FileSystemObject के आधार पर एक कोड का उपयोग कर रहा हूँ।

Answer 1

अपडेट किया गया जुलाई 2014: जोड़ा PowerShell विकल्प और फ़ोल्डरों केवल

सूची में कटौती दूसरा कोड

नीचे दिए गए तरीके FileSearch के स्थान पर एक पूर्ण रिकर्सिव प्रक्रिया चलाते हैं जिसे Office 2007 में बहिष्कृत किया गया था। (बाद के दो कोड केवल आउटपुट के लिए Excel का उपयोग करते हैं - इस आउटपुट को Word में चलाने के लिए हटाया जा सकता है)

1. शैल PowerShell
2. छानने फ़ाइल प्रकार के लिए Dir साथ FSO का उपयोग करना। इस EE answer से सोर्स किया गया जो ईई पेवॉल के पीछे बैठता है। यह आपके द्वारा पूछे जाने वाले (फ़ोल्डरों की एक सूची) से अधिक लंबा है, लेकिन मुझे लगता है कि यह उपयोगी है क्योंकि यह आपको
3. Dir का उपयोग करके आगे काम करने के लिए परिणामों की एक श्रृंखला देता है। इस उदाहरण मेरा उत्तर से आता है किसी और स्थल

1. सी नीचे सभी फ़ोल्डर डंप करने के लिए PowerShell का उपयोग पर आपूर्ति: एक csv फ़ाइल

Sub Comesfast() 
X2 = Shell("powershell.exe Get-ChildItem c:\temp -Recurse | ?{ $_.PSIsContainer } | export-csv C:\temp\filename.csv", 1) 
End Sub 

2 में \ अस्थायी।FileScriptingObject का उपयोग सी नीचे सभी फ़ोल्डर डंप करने के लिए: Excel में \ अस्थायी

Public Arr() As String 
Public Counter As Long 

Sub LoopThroughFilePaths() 
Dim myArr 
Dim strPath As String 
strPath = "c:\temp\" 
myArr = GetSubFolders(strPath) 
[A1].Resize(UBound(myArr, 1), 1) = Application.Transpose(myArr) 
End Sub 


Function GetSubFolders(RootPath As String) 
Dim fso As Object 
Dim fld As Object 
Dim sf As Object 
Dim myArr 

Set fso = CreateObject("Scripting.FileSystemObject") 
Set fld = fso.GetFolder(RootPath) 
For Each sf In fld.SUBFOLDERS 
    ReDim Preserve Arr(Counter) 
    Arr(Counter) = sf.Path 
    Counter = Counter + 1 
    myArr = GetSubFolders(sf.Path) 
Next 
GetSubFolders = Arr 
Set sf = Nothing 
Set fld = Nothing 
Set fso = Nothing 
End Function 

3 यहाँ Dir

Option Explicit 

    Public StrArray() 
    Public lngCnt As Long 
    Public b_OS_XP As Boolean 

    Public Enum MP3Tags 
    ' See http://www.kixtart.org/forums/ubbthreads.php?ubb=showflat&Number=160880&page=1 for OS specific attribute lists 
    XP_Artist = 16 
    XP_AlbumTitle = 17 
    XP_SongTitle = 10 
    XP_TrackNumber = 19 
    XP_RecordingYear = 18 
    XP_Genre = 20 
    XP_Duration = 21 
    XP_BitRate = 22 
    Vista_W7_Artist = 13 
    Vista_W7_AlbumTitle = 14 
    Vista_W7_SongTitle = 21 
    Vista_W7_TrackNumber = 26 
    Vista_W7_RecordingYear = 15 
    Vista_W7_Genre = 16 
    Vista_W7_Duration = 17 
    Vista_W7_BitRate = 28 
    End Enum 

    Public Sub Main() 
    Dim objws 
    Dim objWMIService 
    Dim colOperatingSystems 
    Dim objOperatingSystem 
    Dim objFSO 
    Dim objFolder 
    Dim Wb As Workbook 
    Dim ws As Worksheet 
    Dim strobjFolderPath As String 
    Dim strOS As String 
    Dim strMyDoc As String 
    Dim strComputer As String 

    'Setup Application for the user 
    With Application 
     .ScreenUpdating = False 
     .DisplayAlerts = False 
    End With  

    'reset public variables 
    lngCnt = 0 
    ReDim StrArray(1 To 10, 1 To 1000) 

    ' Use wscript to automatically locate the My Documents directory 
    Set objws = CreateObject("wscript.shell") 
    strMyDoc = objws.SpecialFolders("MyDocuments") 


    strComputer = "." 
    Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2") 
    Set colOperatingSystems = objWMIService.ExecQuery("Select * from Win32_OperatingSystem") 
    For Each objOperatingSystem In colOperatingSystems 
     strOS = objOperatingSystem.Caption 
    Next 

    Set objFSO = CreateObject("Scripting.FileSystemObject") 
    If InStr(strOS, "XP") Then 
     b_OS_XP = True 
    Else 
     b_OS_XP = False 
    End If 


    ' Format output sheet 
    Set Wb = Workbooks.Add(1) 
    Set ws = Wb.Worksheets(1) 
    ws.[a1] = Now() 
    ws.[a2] = strOS 
    ws.[a3] = strMyDoc 
    ws.[a1:a3].HorizontalAlignment = xlLeft 

    ws.[A4:J4].Value = Array("Folder", "File", "Artist", "Album Title", "Song Title", "Track Number", "Recording Year", "Genre", "Duration", "Bit Rate") 
    ws.Range([a1], [j4]).Font.Bold = True 
    ws.Rows(5).Select 
    ActiveWindow.FreezePanes = True 


    Set objFSO = CreateObject("Scripting.FileSystemObject") 
    Set objFolder = objFSO.GetFolder(strMyDoc) 

    ' Start the code to gather the files 
    ShowSubFolders objFolder, True 
    ShowSubFolders objFolder, False 

    If lngCnt > 0 Then 
     ' Finalise output 
     With ws.Range(ws.[a5], ws.Cells(5 + lngCnt - 1, 10)) 
      .Value2 = Application.Transpose(StrArray) 
      .Offset(-1, 0).Resize(Rows.Count - 3, 10).AutoFilter 
      .Offset(-4, 0).Resize(Rows.Count, 10).Columns.AutoFit 
     End With 
     ws.[a1].Activate 
    Else 
     MsgBox "No files found!", vbCritical 
     Wb.Close False 
    End If 

    ' tidy up 

    Set objFSO = Nothing 
    Set objws = Nothing 

    With Application 
     .ScreenUpdating = True 
     .DisplayAlerts = True 
     .StatusBar = vbNullString 
    End With 
    End Sub 

    Sub ShowSubFolders(ByVal objFolder, bRootFolder As Boolean) 
    Dim objShell 
    Dim objShellFolder 
    Dim objShellFolderItem 
    Dim colFolders 
    Dim objSubfolder 


    'strName must be a variant, as ParseName does not work with a string argument 
    Dim strFname 
    Set objShell = CreateObject("Shell.Application") 
    Set colFolders = objFolder.SubFolders 
    Application.StatusBar = "Processing " & objFolder.Path 

    If bRootFolder Then 
     Set objSubfolder = objFolder 
     GoTo OneTimeRoot 
    End If 

    For Each objSubfolder In colFolders 
     'check to see if root directory files are to be processed 
    OneTimeRoot: 
     strFname = Dir(objSubfolder.Path & "\*.mp3") 
     Set objShellFolder = objShell.Namespace(objSubfolder.Path) 
     Do While Len(strFname) > 0 
      lngCnt = lngCnt + 1 
      If lngCnt Mod 1000 = 0 Then ReDim Preserve StrArray(1 To 10, 1 To (lngCnt + 1000)) 
      Set objShellFolderItem = objShellFolder.ParseName(strFname) 
      StrArray(1, lngCnt) = objSubfolder 
      StrArray(2, lngCnt) = strFname 
      If b_OS_XP Then 
       StrArray(3, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.XP_Artist) 
       StrArray(4, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.XP_AlbumTitle) 
       StrArray(5, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.XP_SongTitle) 
       StrArray(6, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.XP_TrackNumber) 
       StrArray(7, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.XP_RecordingYear) 
       StrArray(8, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.XP_Genre) 
       StrArray(9, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.XP_Duration) 
       StrArray(10, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.XP_BitRate) 
      Else 
       StrArray(3, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.Vista_W7_Artist) 
       StrArray(4, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.Vista_W7_AlbumTitle) 
       StrArray(5, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.Vista_W7_SongTitle) 
       StrArray(6, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.Vista_W7_TrackNumber) 
       StrArray(7, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.Vista_W7_RecordingYear) 
       StrArray(8, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.Vista_W7_Genre) 
       StrArray(9, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.Vista_W7_Duration) 
       StrArray(10, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.Vista_W7_BitRate) 
      End If 
      strFname = Dir 
     Loop 
     If bRootFolder Then 
      bRootFolder = False 
      Exit Sub 
     End If 
     ShowSubFolders objSubfolder, False 
    Next 
    End Sub 

Answer 2

आप FileSystemObject से बेहतर होंगे। मुझे लगता है।

इस तुम सिर्फ जरूरत है फोन करने के लिए, कहते हैं: listfolders "c: \ डेटा"

Sub listfolders(startfolder) 
''Reference Windows Script Host Object Model 
''If you prefer, just Dim everything as Object 
''and use CreateObject("Scripting.FileSystemObject") 
Dim fs As New FileSystemObject 
Dim fl1 As Folder 
Dim fl2 As Folder 

Set fl1 = fs.GetFolder(startfolder) 

For Each fl2 In fl1.SubFolders 
    Debug.Print fl2.Path 
    listfolders fl2.Path 
Next 

End Sub 

Answer 3

का उपयोग Scripting.FileSystemObject का उपयोग कर, क्योंकि मैं यह धीमी और अविश्वसनीय पाया के बिना एक सरल संस्करण है। विशेष रूप से .Name विधि, सब कुछ धीमा कर रहा था। इसके अलावा मैंने Excel में इसका परीक्षण किया लेकिन मुझे नहीं लगता कि मैंने जो कुछ भी इस्तेमाल किया वह शब्द में उपलब्ध नहीं होगा।

पहले कुछ कार्यों:

यह एक फ़ाइल पथ, अजगर में os.path.join के समान बनाने के लिए दो तार जुड़ जाता है। यदि आप अपने पथ के अंत में उस "\" पर काम करते हैं तो याद रखने की आवश्यकता नहीं है।

Const sep as String = "\" 

Function pjoin(root_path As String, file_path As String) As String 
    If right(root_path, 1) = sep Then 
     pjoin = root_path & file_path 
    Else 
     pjoin = root_path & sep & file_path 
    End If 
End Function 

इस रूट निर्देशिका root_path

Function subItems(root_path As String, Optional pat As String = "*", _ 
        Optional vbtype As Integer = vbNormal) As Collection 
    Set subItems = New Collection 
    Dim sub_item As String 
    sub_item= Dir(pjoin(root_path, pat), vbtype) 
    While sub_item <> "" 
     subItems.Add (pjoin(root_path, sub_item)) 
     sub_item = Dir() 
    Wend 
End Function 

के उप आइटम का संग्रह इस निर्देशिका root_path कि फ़ोल्डर शामिल हैं और फिर आइटम है कि संग्रह से फ़ोल्डरों नहीं हैं को हटा में उप मदों की एक संग्रह बनाता पैदा करते हैं। और यह वैकल्पिक रूप से उन बुरा . और .. फ़ोल्डरों

Function subFolders(root_path As String, Optional pat As String = "", _ 
        Optional skipDots As Boolean = True) As Collection 
    Set subFolders = subItems(root_path, pat, vbDirectory) 
    If skipDots Then 
     Dim dot As String 
     Dim dotdot As String 
     dot = pjoin(root_path, ".") 
     dotdot = dot & "." 
     Do While subFolders.Item(1) = dot _ 
     Or subFolders.Item(1) = dotdot 
      subFolders.remove (1) 
      If subFolders.Count = 0 Then Exit Do 
     Loop 
    End If 
    For i = subFolders.Count To 1 Step -1 
     ' This comparison could be replaced by and `fileExists` function 
     If Dir(subFolders.Item(i), vbNormal) <> "" Then 
      subFolders.remove (i) 
     End If 
    Next i 
End Function 

अंत में पुनरावर्ती खोज इस साइट कि Scripting.FileSystemObject इस्तेमाल किया मैं इसे और मूल के बीच कोई तुलना परीक्षण नहीं किया है से किसी और कार्य के आधार पर कार्य है हटा सकते हैं। अगर मुझे वह पोस्ट फिर मिल जाए तो मैं इसे लिंक कर दूंगा। नोट collec संदर्भ द्वारा पारित किया गया है, इसलिए एक नया संग्रह बनाएं और इसे उप-पॉप्युलेट करने के लिए इस उप को कॉल करें। सभी उप फ़ोल्डर के लिए vbType:=vbDirectory पास करें।

Sub walk(root_path As String, ByRef collec as Collection, Optional pat As String = "*" _ 
     Optional vbType as Integer = vbNormal) 
    Dim subF as Collection 
    Dim subD as Collection 
    Set subF = subItems(root_path, pat, vbType) 
    For Each sub_file In subF 
     collec.Add sub_file 
    Next sub_file 
    Set subD = subFolders(root_path) 
    For Each sub_folder In subD 
     walk sub_folder , collec, pat, vbType 
    Next sub_folder 
End Sub 

Answer 4

बाह्य वस्तुओं का उपयोग किये बिना यहां एक वीबीए समाधान है।

Dir() फ़ंक्शन की सीमाओं के कारण आपको एक बार में प्रत्येक फ़ोल्डर की पूरी सामग्री प्राप्त करने की आवश्यकता है, न कि रिकर्सिव एल्गोरिदम के साथ क्रॉल करते समय।

Function GetFilesIn(Folder As String) As Collection 
    Dim F As String 
    Set GetFilesIn = New Collection 
    F = Dir(Folder & "\*") 
    Do While F <> "" 
    GetFilesIn.Add F 
    F = Dir 
    Loop 
End Function 

Function GetFoldersIn(Folder As String) As Collection 
    Dim F As String 
    Set GetFoldersIn = New Collection 
    F = Dir(Folder & "\*", vbDirectory) 
    Do While F <> "" 
    If GetAttr(Folder & "\" & F) And vbDirectory Then GetFoldersIn.Add F 
    F = Dir 
    Loop 
End Function 

Sub Test() 
    Dim C As Collection, F 

    Debug.Print 
    Debug.Print "Files in C:\" 
    Set C = GetFilesIn("C:\") 
    For Each F In C 
    Debug.Print F 
    Next F 

    Debug.Print 
    Debug.Print "Folders in C:\" 
    Set C = GetFoldersIn("C:\") 
    For Each F In C 
    Debug.Print F 
    Next F 
End Sub 

संपादित

इस संस्करण सबफ़ोल्डर में खोदता है और बजाय सिर्फ फ़ाइल या फ़ोल्डर नाम लौटने का पूरा पथ नाम देता है।

पूरे सी ड्राइव पर परीक्षण न चलाएं !!

Function GetFilesIn(Folder As String, Optional Recursive As Boolean = False) As Collection 
    Dim F As String 
    Set GetFilesIn = New Collection 
    F = Dir(Folder & "\*") 
    Do While F <> "" 
    GetFilesIn.Add JoinPaths(Folder, F) 
    F = Dir 
    Loop 

    If Recursive Then 
    Dim SubFolder, SubFile 
    For Each SubFolder In GetFoldersIn(Folder) 
     If Right(SubFolder, 2) <> "\." And Right(SubFolder, 3) <> "\.." Then 
     For Each SubFile In GetFilesIn(CStr(SubFolder), True) 
      GetFilesIn.Add SubFile 
     Next SubFile 
     End If 
    Next SubFolder 
    End If 
End Function 

Function GetFoldersIn(Folder As String) As Collection 
    Dim F As String 
    Set GetFoldersIn = New Collection 
    F = Dir(Folder & "\*", vbDirectory) 
    Do While F <> "" 
    If GetAttr(Folder & "\" & F) And vbDirectory Then GetFoldersIn.Add JoinPaths(Folder, F) 
    F = Dir 
    Loop 
End Function 

Function JoinPaths(Path1 As String, Path2 As String) As String 
    JoinPaths = Replace(Path1 & "\" & Path2, "\\", "\") 
End Function 

Sub Test() 
    Dim C As Collection, F 

    Debug.Print 
    Debug.Print "Files in C:\" 
    Set C = GetFilesIn("C:\") 
    For Each F In C 
    Debug.Print F 
    Next F 

    Debug.Print 
    Debug.Print "Folders in C:\" 
    Set C = GetFoldersIn("C:\") 
    For Each F In C 
    Debug.Print F 
    Next F 

    Debug.Print 
    Debug.Print "All files in C:\" 
    Set C = GetFilesIn("C:\", True) 
    For Each F In C 
    Debug.Print F 
    Next F 
End Sub