Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
704to708
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
704to708
704to708
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Makro anpassen

Makro anpassen
10.12.2005 14:26:26
Hans-Georg
Hallo,
kanm mir einer mal helfen mein Makro anzupassen ?
Ich habe mir von K.Rola ein Makro schreiben lassen, welches den inhalt eines Laufwerks auslesen kann, es werden aber nur die Dateien angezeigt, nicht die Ordner die ich aber auch dringend brauche! Wer kann helfen ?
Hier der Code :
Option Explicit
Sub VerzeichnisseAuslesen()
Dim strLookIn As String, objFs As Object, lngi As Long, strFileName As String
Dim strPur As String
'Hier muss der Buchstabe des Laufwerks angepasst werden
'------------------------------------------------------
strLookIn = "J:\"
'------------------------------------------------------
strFileName = "*.*"
Set objFs = Application.FileSearch
With objFs
.LookIn = strLookIn
.FileName = strFileName
.SearchSubFolders = False
If .Execute > 0 Then
For lngi = 1 To .FoundFiles.Count
strPur = .FoundFiles(lngi)
DAT.Cells(lngi, 1) = Name_pur(strPur)
Next
End If
End With
Columns(1).AutoFit
Set objFs = Nothing
End Sub

Private Function Name_pur(strDatei As String) As String
Dim objFso As Object
Set objFso = CreateObject("Scripting.FileSystemObject")
Name_pur = objFso.GetBaseName(strDatei)
End Function

Vielen Dank für die Hilfe !
MfG Hans - Georg

7
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Makro anpassen
10.12.2005 15:00:25
Josef
Hallo Hans-Georg!
Meinst du so?
Sub VerzeichnisseAuslesen()
Dim strLookIn As String, objFs As Object, lngi As Long, strFileName As String
Dim strPur As String

'Hier muss der Buchstabe des Laufwerks angepasst werden
'------------------------------------------------------
strLookIn = "F:\"
'------------------------------------------------------
strFileName = "*.*"
Set objFs = Application.FileSearch

With objFs
  .LookIn = strLookIn
  .Filename = strFileName
  .SearchSubFolders = False
  If .Execute > 0 Then
    For lngi = 1 To .FoundFiles.Count
      strPur = .FoundFiles(lngi)
      DAT.Cells(lngi, 1) = Name_pur(strPur)
      DAT.Cells(lngi, 2) = In_Folder(strPur)
    Next
  End If
End With
Columns(1).AutoFit
Set objFs = Nothing
End Sub


Private Function Name_pur(strDatei As String) As String
Dim objFso As Object
Set objFso = CreateObject("Scripting.FileSystemObject")
Name_pur = objFso.GetBaseName(strDatei)
Set objFso = Nothing
End Function


Private Function In_Folder(strDatei As String) As String
Dim objFso As Object
Set objFso = CreateObject("Scripting.FileSystemObject")
In_Folder = objFso.GetParentFolderName(strDatei)
Set objFso = Nothing
End Function


'******************************
'* Gruß Sepp
'*
'* Rückmeldung wäre nett!
'******************************

Anzeige
AW: Makro anpassen
10.12.2005 15:12:04
Hans-Georg
Hallo Sepp,
nein nicht ganz.
In dem Ordner liegen offene Dateien (z.B. ein Musikstück) aber auch Ordner (z.B. ein Ordner wo eine ganze Musikgruppe enthalten ist)
Beispiel :
AbbA - Thank you for the Musik.mp3
Nazaret - Best of Nazareth
Mir würde schon langen, wenn mir der Ordnername angezeigt würde, ich brauche nicht unbedingt noch den Ordnerinhalt.
MfG
Hans - Georg
AW: Makro anpassen
10.12.2005 16:05:53
Josef
Hallo Hans-Georg!
Dann zB. so!
Sub VerzeichnisseAuslesen()
Dim strLookIn As String, lngi As Long, strFileName As String, strTemp As String
Dim objFso As Object, objFolder As Object, objSubFolder As Object, objFile As Object

'Hier muss der Buchstabe des Laufwerks angepasst werden
'------------------------------------------------------
strLookIn = "F:\"
'------------------------------------------------------
strFileName = "*.*"

Set objFso = CreateObject("Scripting.FileSystemObject")

Set objFolder = objFso.getFolder(strLookIn)

DAT.Columns(1).ClearContents

'Ordner auflisten
For Each objSubFolder In objFolder.SubFolders
  lngi = lngi + 1
  DAT.Cells(lngi, 1) = objFso.GetBaseName(objSubFolder)
Next

'Dateien auflisten
For Each objFile In objFolder.Files
  strTemp = objFso.GetFileName(objFile)
  If strTemp Like strFileName Then
    lngi = lngi + 1
    DAT.Cells(lngi, 1) = strTemp
  End If
  strTemp = vbNullString
Next

Set objFso = Nothing
Set objFolder = Nothing

End Sub


'******************************
'* Gruß Sepp
'*
'* Rückmeldung wäre nett!
'******************************

Anzeige
AW: Makro anpassen
10.12.2005 16:17:06
Hans-Georg
Jaaa, genau, super, klappt prima !
Vielen Dank !
AW: Makro anpassen
10.12.2005 16:21:43
Nepumuk
Hallo Sepp,
nur Ordner, keine Dateien.
' **********************************************************************
' Modul: Modul7 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Private Declare Function FindFirstFile Lib "kernel32.dll" Alias "FindFirstFileA" ( _
    ByVal lpFileName As String, _
    ByRef lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32.dll" Alias "FindNextFileA" ( _
    ByVal hFindFile As Long, _
    ByRef lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32.dll" ( _
    ByVal hFindFile As Long) As Long

Private Enum FILE_ATTRIBUTE
    FILE_ATTRIBUTE_READONLY = &H1
    FILE_ATTRIBUTE_HIDDEN = &H2
    FILE_ATTRIBUTE_SYSTEM = &H4
    FILE_ATTRIBUTE_DIRECTORY = &H10
    FILE_ATTRIBUTE_ARCHIVE = &H20
    FILE_ATTRIBUTE_NORMAL = &H80
    FILE_ATTRIBUTE_TEMPORARY = &H100
End Enum

Private Const MAX_PATH = 260
Private Const INVALID_HANDLE_VALUE = -1

Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type

Private Type WIN32_FIND_DATA
    dwFileAttributes As Long
    ftCreationTime As FILETIME
    ftLastAccessTime As FILETIME
    ftLastWriteTime As FILETIME
    nFileSizeHigh As Long
    nFileSizeLow As Long
    dwReserved0 As Long
    dwReserved1 As Long
    cFileName As String * MAX_PATH
    cAlternate As String * 14
End Type

Public Sub prcStart()
    Call prcFolderlist("D:\", 0)
End Sub

Private Sub prcFolderlist(ByVal strFolderPath As String, ByRef lngRow As Long)
    Dim WFD As WIN32_FIND_DATA
    Dim lngSearch As Long
    Dim strDirName As String
    If Right$(strFolderPath, 1) <> "\" Then strFolderPath = strFolderPath & "\"
    lngSearch = FindFirstFile(strFolderPath & "*.*", WFD)
    If lngSearch <> INVALID_HANDLE_VALUE Then
        lngRow = lngRow + 1
        Cells(lngRow, 1).Value = strFolderPath & strDirName
        Do
            If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) Then
                strDirName = Left$(WFD.cFileName, InStr(WFD.cFileName, Chr(0)) - 1)
                If (strDirName <> ".") And (strDirName <> "..") Then _
                    Call prcFolderlist(strFolderPath & strDirName, lngRow)
            End If
        Loop While FindNextFile(lngSearch, WFD)
        FindClose lngSearch
    End If
End Sub

Gruß
Nepumuk

Anzeige
AW: Makro anpassen
10.12.2005 16:51:35
Josef
Hi Max!
Die API-Version zur Datei/Ordnersuche ist mir schon bekannt, aber für
die Bedürfnisse von Hans-Georg, schien mir die FSO-Version ausreichend.
Bis denne
Sepp
schnell und kurz:
10.12.2005 22:10:13
Reinhard
Hi hans,
Option Explicit
Sub Verzeichnisse()
Dim zei As Long, satz As String
Close
Open "c:\verz.bat" For Output As #1
' /s=nterverzeichnisse /b=ohne Vorspann /ad=Verzeichnisse
Print #1, "dir c:\*.* /s /b /ad > c:\test\verz.txt"
Close
Shell ("c:\verz.bat")
Open "c:\test\verz.txt" For Input As #1
While Not EOF(1)
zei = zei + 1
Line Input #1, satz
Cells(zei, 1) = satz
Wend
End Sub
Gruß
Reinhard
ps:Das Forum lebt auch von Rückmeldungen
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige