Ordnernamen auslesen und in Exceldatei schreiben

  • VBScript

Es gibt 6 Antworten in diesem Thema. Der letzte Beitrag () ist von silence.

    Ordnernamen auslesen und in Exceldatei schreiben

    Ich habe folgendes Problem, ich habe einen Ordner mit mehreren Unterordnern, die Namen dieser Unterordner (nur die Namen kein Pfad)
    sollen in eine Exceltabelle importiert werden und zwar immer mit 2 Zeilen Abstand, also so:

    Aus:

    C:\Ordner 1\Unterordner 1
    C:\Ordner 1\Unterordner 2
    C:\Ordner 1\Unterordner 3
    C:\Ordner 1\Unterordner 4

    Solle eine Excelliste werden, die so aussieht:

    Zeile1: Unterordner1
    Zeile2:
    Zeile3:
    Zeile4: Unterordner2
    Zeile5:
    Zeile6:
    Zeile7: Unterordner3

    Kann mir da jemand weiterhelfen ?

    VBS, es soll eine Datei werden, die ich einfach in einen beliebigen Ordner kopiere und wenn ich sie ausführe dann eben die Unterordner in diesem Ordner gelistet werden,
    das bekomm ich auch selbst hin, nur das Grundgerüst fehlt mir.

    Momentan bekomm ich eine .txt Datei, diese ist aber nicht korrekt sortiert, sondern schmeisst die Ordner durcheinander.

    Mein Script sieht derzeit so aus:

    Option Explicit

    Dim WSHShell, fso, oArgs
    Dim oFolders, oSubFolder, oFiles, Folder
    Dim i, Text, Pfad, DateiX, VerzX, Verz(), Datei()

    Set WSHShell = WScript.CreateObject("WScript.Shell")
    Set fso = WScript.CreateObject("Scripting.FileSystemObject")
    set oArgs = Wscript.Arguments

    If oArgs.Count > 0 Then ' gibt es Argumente?
    Pfad = oArgs.item(0) ' erstes Argument

    if fso.FileExists( Pfad ) then Pfad = fso.GetParentFolderName( Pfad )

    ' obige Zeile wird nur ausgeführt, wenn "Pfad" eine Datei ist

    Else ' es gibt keine Argumente!
    Pfad = fso.GetFolder( "." ) ' Verzeichnis, in dem sich das Skript befindet
    End If

    if not fso.FolderExists( Pfad ) then

    MsgBox UCase(Pfad) & " existiert nicht!" & vbCRLF & vbCRLF & " . . . das ist das Ende.", , WScript.ScriptName
    WScript.Quit

    End If

    ' Verzeichnisliste an Array übergeben

    i = 0

    Set oFolders = fso.GetFolder( Pfad )
    Set oSubFolder = oFolders.SubFolders

    For Each VerzX In oSubFolder
    ReDim Preserve Verz(i)
    Verz(i) = VerzX.Name
    i = i + 1
    Next
    Set oFiles = nothing
    Set oFolders = nothing

    ' Array an Text übergeben

    Text = ""

    If i > 0 then ' wenn es Verzeichnis(se) gibt
    For i = 0 to UBound( Verz )
    Text = Text & Verz(i) & vbCRLF & vbCRLF & vbCRLF
    Next
    Else
    Text = "keine Unterverzeichnisse vorhanden."
    End If

    Dim objFSO, objFile
    Const ForWriting = 2
    Const Create = true

    Set objFSO = Wscript.CreateObject("Scripting.FileSystemObject")
    Set objFile = objFSO.OpenTextFile("C:\Windows\test.txt", ForWriting, Create)

    objFile.WriteLine Text
    objFile.close

    Set objFile = nothing
    Set objFSO = nothing

    Hallo,

    spätestens, wenn die Unterordner weitere Unterordner haben, wird es unübersichtlich. Dann musst Du noch abfangen, wenn jemand ein Laufwerk drauf zieht. Das gibt erstmal viele Unterordner und zweitens Probleme bei SystemOrdnern wie Mülltonne und Wiederherstellungsdateien.

    Edit:
    um soweit alles abzufangen, musste ich doch etwas mehr Zeit verbraten, als ich Anfangs dachte.

    Damit das nicht umsonst war, hier mein Lösungsvorschlag. Ich hoffe, das sind keine Hausaufgaben. Dann besser selber probieren. Vorsichtshalber habe ich keine Bemerkungen angefügt ;)

    Visual Basic-Quellcode

    1. Option Explicit
    2. dim ws, objExplorer, WSHShell, fSO, objFile, Arg, Pfad, Dateiname, Abbruch, Ordner()
    4. Const ForReading = 1, ForWriting = 2, ForAppending = 8
    5. const Sortieren=0
    6. Abbruch=0
    8. if WScript.Arguments.Count > 0 then
    9. dim result, l
    10. redim Ordner(0)
    11. Set fSO = CreateObject("Scripting.FileSystemObject")
    12. Dateiname=Pfadname(Wscript.Arguments(0)) & "Ordnerliste.csv"
    13. on error resume next
    14. if fSO.FileExists(Dateiname) = true then
    15. fSO.DeleteFile Dateiname
    16. end if
    17. if err.number=0 then
    18. on error goto 0
    19. For Each Arg in Wscript.Arguments
    20. if isDrive(Arg) then
    21. if msgbox("Achtung, Wurzelverzeichnis eines Laufwerks ausgewählt." & vblf & "Soll wirklich eine Ordnerliste erstellt werden?",vbcritical+vbyesno,Pfadname(Arg))=vbno then
    22. Abbruch=1
    23. exit for
    24. end if
    25. end if
    26. if fSO.FolderExists(Arg) then
    27. Ordnerlesen Arg
    28. elseif fSO.FileExists(Arg) then
    29. Ordnerlesen Pfadname(Arg)
    30. end if
    31. next
    32. if Abbruch=0 then
    33. if ubound(Ordner)>1 and Sortieren =1 then
    34. QuickSort Ordner, 1, ubound(Ordner)
    35. end if
    36. Set objFile = fSO.CreateTextFile(Dateiname, True)
    37. for l = 1 to ubound(Ordner)
    38. objFile.WriteLine Ordner(l)
    39. objFile.WriteLine
    40. objFile.WriteLine
    41. next
    42. objFile.close
    43. Set objFile = Nothing
    44. msgbox "Fertig" , vbinformation+vbokonly,"Ordnerkontrolle"
    45. end if
    46. else
    47. msgbox "Konnte 'Ordnerliste.csv' nicht löschen" , vbcritical+vbokonly,"Abbruch - Ordnerkontrolle"
    48. err.clear
    49. end if
    50. Set fSO = Nothing
    51. end if
    53. private function isDrive(byval S)
    54. dim ff
    55. isDrive=False
    56. if fSO.FileExists(S) then
    57. set ff=fSO.GetFile(S)
    58. S=ff.parentfolder
    59. end if
    60. if len(S)<4 then
    61. isDrive=True
    62. end if
    63. end function
    65. private function Pfadname(byval S)
    66. dim ff
    67. if fSO.FileExists(S) then
    68. set ff=fSO.GetFile(S)
    69. Pfadname=ff.parentfolder
    70. else
    71. if right(S,1)<>"\" then
    72. S=S & "\"
    73. end if
    74. if fSO.FolderExists(S) then
    75. if fSO.DriveExists(S) then
    76. Pfadname=S
    77. else
    78. set ff=fSO.GetFolder(S)
    79. Pfadname=ff.parentfolder
    80. end if
    81. else
    82. Pfadname=S
    83. end if
    84. end if
    85. Pfadname=trim(Pfadname)
    86. if right(Pfadname,1)<>"\" then
    87. Pfadname=Pfadname & "\"
    88. end if
    89. set ff=nothing
    90. end function
    92. private function Ordnername(byval S)
    93. dim ff
    94. if fSO.FileExists(S) then
    95. set ff=fSO.GetFile(S)
    96. Ordnername = ff.parentfolder
    97. else
    98. if right(S,1)<>"\" then
    99. S=S & "\"
    100. end if
    101. if fSO.FolderExists(S) then
    102. set ff=fSO.GetFolder(S)
    103. Ordnername = ff.name
    104. else
    105. Ordnername = S
    106. end if
    107. end if
    108. set ff=nothing
    109. end function
    111. Private Sub QuickSort(ByRef ArrayToSort, ByVal Low, ByVal High)
    112. Dim vPartition, vTemp
    113. Dim i, j
    114. If Low > High Then Exit Sub
    115. vPartition = ArrayToSort((Low + High) \ 2)
    116. i = Low: j = High
    117. Do
    118. Do While ArrayToSort(i) < vPartition
    119. i = i + 1
    120. Loop
    121. Do While ArrayToSort(j) > vPartition
    122. j = j - 1
    123. Loop
    124. If i <= j Then
    125. vTemp = ArrayToSort(j)
    126. ArrayToSort(j) = ArrayToSort(i)
    127. ArrayToSort(i) = vTemp
    128. i = i + 1
    129. j = j - 1
    130. End If
    131. Loop Until i > j
    132. If (j - Low) < (High - i) Then
    133. QuickSort ArrayToSort, Low, j
    134. QuickSort ArrayToSort, i, High
    135. Else
    136. QuickSort ArrayToSort, i, High
    137. QuickSort ArrayToSort, Low, j
    138. End If
    139. End Sub
    141. Private Sub Ordnerlesen(ByVal sPfad)
    142. Dim fld, f
    143. Set fld = fSO.GetFolder(sPfad)
    144. err.clear
    145. on error resume next
    146. For Each f In fld.SubFolders
    147. if err.number=0 then
    148. redim preserve Ordner(ubound(Ordner)+1)
    149. Ordner(ubound(Ordner))=f.name
    150. else
    151. err.clear
    152. end if
    153. Next
    154. For Each f In fld.SubFolders
    155. if err.number=0 then
    156. Ordnerlesen (f.Path)
    157. else
    158. err.clear
    159. end if
    160. Next
    162. End Sub

    Gruß
    Peterfido

    Keine Unterstützung per PN!

    Dieser Beitrag wurde bereits 2 mal editiert, zuletzt von „peterfido“ ()

Facebook
Telefonspende