Problem Ordner einlesen Win8/ Excel 2013

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Aha.
Hier ist der Text.
Gruß Volker
Option Explicit
Public Declare PtrSafe Function GetLogicalDrives _
Lib "kernel32" () As Long
Public Declare PtrSafe Function GetDriveType _
Lib "kernel32" Alias "GetDriveTypeA" _
(ByVal lpRootPathName As String) As Integer
Public Declare PtrSafe Function GetLogicalDriveStrings _
Lib "kernel32" Alias "GetLogicalDriveStringsA" _
(ByVal nBufferLength As Long, _
ByVal lpBuffer As String) As Long
Public Declare PtrSafe Function FindFirstFile Lib "kernel32" _
Alias "FindFirstFileA" (ByVal lpFileName As String, _
lpFindFileData As WIN32_FIND_DATA) As Long
Public Declare PtrSafe Function FindNextFile Lib "kernel32" _
Alias "FindNextFileA" (ByVal hFindFile As Long, _
lpFindFileData As WIN32_FIND_DATA) As Long
Public Declare PtrSafe Function FindClose Lib "kernel32" (ByVal _
hFindFile As Long) As Long
Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Const MAX_PATH = 259
Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nxFilesizeHigh As Long
nxFilesizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type
Const FILE_ATTRIBUTE_ARCHIVE = &H20
Const FILE_ATTRIBUTE_COMPRESSED = &H800
Const FILE_ATTRIBUTE_DIRECTORY = &H10
Const FILE_ATTRIBUTE_HIDDEN = &H2
Const FILE_ATTRIBUTE_NORMAL = &H80
Const FILE_ATTRIBUTE_READONLY = &H1
Const FILE_ATTRIBUTE_SYSTEM = &H4
Const FILE_ATTRIBUTE_TEMPORARY = &H100

Sub GetAllFiles(ByVal Root$, ByVal strPath$, ByRef Field$(), ByRef lngFileAttributes&(), ByVal _ strSearchFile$, ByVal strInstanz&) Dim File$, hFile&, FD As WIN32_FIND_DATA Dim SFile$, ShFile&, SFD As WIN32_FIND_DATA Dim xAttrib& Dim SRoot$ strInstanz = strInstanz + 1 If Right(Root, 1) "\" Then Root = Root & "\" If strInstanz = 1 Then SRoot = Root ShFile = FindFirstFile(SRoot & strSearchFile$, SFD) If ShFile > 0 Then Do SFile = Left(SFD.cFileName, InStr(SFD.cFileName, Chr(0)) - 1) If Not (SFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = FILE_ATTRIBUTE_DIRECTORY Then If (SFile ".") And (SFile "..") Then Field(UBound(Field)) = SRoot & SFile lngFileAttributes(UBound(Field)) = SFD.dwFileAttributes ReDim Preserve Field(0 To UBound(Field) + 1) ReDim Preserve lngFileAttributes&(0 To UBound(Field)) End If End If Loop While FindNextFile(ShFile, SFD) End If End If hFile = FindFirstFile(Root & strPath, FD) If hFile = 0 Then Exit Sub Do File = Left(FD.cFileName, InStr(FD.cFileName, Chr(0)) - 1) xAttrib& = FD.dwFileAttributes If (FD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = FILE_ATTRIBUTE_DIRECTORY Then If (File ".") And (File "..") Then SFile = File SRoot = Root GetAllFiles Root & File, strPath, Field, lngFileAttributes, strSearchFile$, (strInstanz) If Right(SFile, 1) "\" Then SFile = SFile & "\" SRoot = SRoot & SFile ShFile = FindFirstFile(SRoot & strSearchFile$, SFD) If ShFile > 0 Then Do SFile = Left(SFD.cFileName, InStr(SFD.cFileName, Chr(0)) - 1) If Not (SFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = FILE_ATTRIBUTE_DIRECTORY _ Then If (SFile ".") And (SFile "..") Then Field(UBound(Field)) = SRoot & SFile lngFileAttributes(UBound(Field)) = SFD.dwFileAttributes ReDim Preserve Field(0 To UBound(Field) + 1) ReDim Preserve lngFileAttributes&(0 To UBound(Field)) End If End If Loop While FindNextFile(ShFile, SFD) End If End If Call FindClose(ShFile) End If Stop Loop While FindNextFile(hFile, FD) Call FindClose(hFile) End Sub

Sub GetAllDirctory(ByVal Root$, ByVal strPath$, ByRef Field$(), ByRef lngFileAttributes&(), _ ByVal strSearchFile$, ByVal strInstanz&) Dim File$, hFile&, FD As WIN32_FIND_DATA Dim SFile$, ShFile&, SFD As WIN32_FIND_DATA Dim xAttrib& Dim SRoot$ strInstanz = strInstanz + 1 If Right(Root, 1) "\" Then Root = Root & "\" If strInstanz = 1 Then SRoot = Root ShFile = FindFirstFile(SRoot & strSearchFile$, SFD) If ShFile > 0 Then Do SFile = Left(SFD.cFileName, InStr(SFD.cFileName, Chr(0)) - 1) If (SFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = FILE_ATTRIBUTE_DIRECTORY Then If (SFile ".") And (SFile "..") Then Field(UBound(Field)) = SRoot & SFile lngFileAttributes(UBound(Field)) = SFD.dwFileAttributes ReDim Preserve Field(0 To UBound(Field) + 1) ReDim Preserve lngFileAttributes&(0 To UBound(Field)) End If End If Loop While FindNextFile(ShFile, SFD) End If End If hFile = FindFirstFile(Root & strPath, FD) If hFile = 0 Then Exit Sub Do File = Left(FD.cFileName, InStr(FD.cFileName, Chr(0)) - 1) xAttrib& = FD.dwFileAttributes If (FD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = FILE_ATTRIBUTE_DIRECTORY Then If (File ".") And (File "..") Then SFile = File SRoot = Root GetAllDirctory Root & File, strPath, Field, lngFileAttributes, strSearchFile$, (strInstanz) If Right(SFile, 1) "\" Then SFile = SFile & "\" SRoot = SRoot & SFile ShFile = FindFirstFile(SRoot & strSearchFile$, SFD) If ShFile > 0 Then Do SFile = Left(SFD.cFileName, InStr(SFD.cFileName, Chr(0)) - 1) If (SFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = FILE_ATTRIBUTE_DIRECTORY Then If (SFile ".") And (SFile "..") Then Field(UBound(Field)) = SRoot & SFile lngFileAttributes(UBound(Field)) = SFD.dwFileAttributes ReDim Preserve Field(0 To UBound(Field) + 1) ReDim Preserve lngFileAttributes&(0 To UBound(Field)) End If End If Loop While FindNextFile(ShFile, SFD) End If End If Call FindClose(ShFile) End If Loop While FindNextFile(hFile, FD) Call FindClose(hFile) End Sub

Hallo,
ich hab es mal so grob überarbeitet. Teste mal:

Option Explicit

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

Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type

Const MAX_PATH = 259

Type WIN32_FIND_DATA
    dwFileAttributes As Long
    ftCreationTime As FILETIME
    ftLastAccessTime As FILETIME
    ftLastWriteTime As FILETIME
    nxFilesizeHigh As Long
    nxFilesizeLow As Long
    dwReserved0 As Long
    dwReserved1 As Long
    cFileName As String * MAX_PATH
    cAlternate As String * 14
End Type

Const FILE_ATTRIBUTE_ARCHIVE = &H20
Const FILE_ATTRIBUTE_COMPRESSED = &H800
Const FILE_ATTRIBUTE_DIRECTORY = &H10
Const FILE_ATTRIBUTE_HIDDEN = &H2
Const FILE_ATTRIBUTE_NORMAL = &H80
Const FILE_ATTRIBUTE_READONLY = &H1
Const FILE_ATTRIBUTE_SYSTEM = &H4
Const FILE_ATTRIBUTE_TEMPORARY = &H100

Sub GetAllFiles(ByVal Root$, ByVal strPath$, ByRef Field$(), ByRef lngFileAttributes&(), ByVal _
        strSearchFile$, ByVal strInstanz&)

    Dim File$, hFile As LongPtr, FD As WIN32_FIND_DATA
    Dim SFile$, ShFile As LongPtr, SFD As WIN32_FIND_DATA
    Dim xAttrib&
    Dim SRoot$
    strInstanz = strInstanz + 1
    If Right$(Root, 1) <> "\" Then Root = Root & "\"

    If strInstanz = 1 Then
        SRoot = Root
        ShFile = FindFirstFile(SRoot & strSearchFile$, SFD)
        If ShFile > 0 Then
            Do
                SFile = Left$(SFD.cFileName, InStr(SFD.cFileName, Chr(0)) - 1)
                If Not (SFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = FILE_ATTRIBUTE_DIRECTORY Then
                    If (SFile <> ".") And (SFile <> "..") Then
                        Field(UBound(Field)) = SRoot & SFile
                        lngFileAttributes(UBound(Field)) = SFD.dwFileAttributes
                        Redim Preserve Field(0 To UBound(Field) + 1)
                        Redim Preserve lngFileAttributes&(0 To UBound(Field))
                    End If
                End If
            Loop While FindNextFile(ShFile, SFD)
            Call FindClose(ShFile)
        End If
    End If

    hFile = FindFirstFile(Root & strPath, FD)
    If hFile = 0 Then Exit Sub
    Do
        File = Left$(FD.cFileName, InStr(FD.cFileName, Chr(0)) - 1)
        xAttrib& = FD.dwFileAttributes
        If (FD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = FILE_ATTRIBUTE_DIRECTORY Then
            If (File <> ".") And (File <> "..") Then
                SFile = File
                SRoot = Root
                GetAllFiles Root & File, strPath, Field, lngFileAttributes, strSearchFile$, (strInstanz)
                If Right$(SFile, 1) <> "\" Then SFile = SFile & "\"
                SRoot = SRoot & SFile
                ShFile = FindFirstFile(SRoot & strSearchFile$, SFD)
                If ShFile > 0 Then
                    Do
                        SFile = Left$(SFD.cFileName, InStr(SFD.cFileName, Chr(0)) - 1)
                        If Not (SFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = FILE_ATTRIBUTE_DIRECTORY Then
                            If (SFile <> ".") And (SFile <> "..") Then
                                Field(UBound(Field)) = SRoot & SFile
                                lngFileAttributes(UBound(Field)) = SFD.dwFileAttributes
                                Redim Preserve Field(0 To UBound(Field) + 1)
                                Redim Preserve lngFileAttributes&(0 To UBound(Field))
                            End If
                        End If
                    Loop While FindNextFile(ShFile, SFD)
                End If
            End If
            Call FindClose(ShFile)
        End If
    Loop While FindNextFile(hFile, FD)
    Call FindClose(hFile)
End Sub

Sub GetAllDirctory(ByVal Root$, ByVal strPath$, ByRef Field$(), ByRef lngFileAttributes&(), _
        ByVal strSearchFile$, ByVal strInstanz&)

    Dim File$, hFile As LongPtr, FD As WIN32_FIND_DATA
    Dim SFile$, ShFile As LongPtr, SFD As WIN32_FIND_DATA
    Dim xAttrib&
    Dim SRoot$
    strInstanz = strInstanz + 1
    If Right$(Root, 1) <> "\" Then Root = Root & "\"

    If strInstanz = 1 Then
        SRoot = Root
        ShFile = FindFirstFile(SRoot & strSearchFile$, SFD)
        If ShFile > 0 Then
            Do
                SFile = Left$(SFD.cFileName, InStr(SFD.cFileName, Chr(0)) - 1)
                If (SFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = FILE_ATTRIBUTE_DIRECTORY Then
                    If (SFile <> ".") And (SFile <> "..") Then
                        Field(UBound(Field)) = SRoot & SFile
                        lngFileAttributes(UBound(Field)) = SFD.dwFileAttributes
                        Redim Preserve Field(0 To UBound(Field) + 1)
                        Redim Preserve lngFileAttributes&(0 To UBound(Field))
                    End If
                End If
            Loop While FindNextFile(ShFile, SFD)
            Call FindClose(ShFile)
        End If
    End If

    hFile = FindFirstFile(Root & strPath, FD)
    If hFile = 0 Then Exit Sub
    Do
        File = Left$(FD.cFileName, InStr(FD.cFileName, Chr(0)) - 1)
        xAttrib& = FD.dwFileAttributes
        If (FD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = FILE_ATTRIBUTE_DIRECTORY Then
            If (File <> ".") And (File <> "..") Then
                SFile = File
                SRoot = Root
                GetAllDirctory Root & File, strPath, Field, lngFileAttributes, strSearchFile$, (strInstanz)
                If Right$(SFile, 1) <> "\" Then SFile = SFile & "\"
                SRoot = SRoot & SFile
                ShFile = FindFirstFile(SRoot & strSearchFile$, SFD)
                If ShFile > 0 Then
                    Do
                        SFile = Left$(SFD.cFileName, InStr(SFD.cFileName, Chr(0)) - 1)
                        If (SFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = FILE_ATTRIBUTE_DIRECTORY Then
                            If (SFile <> ".") And (SFile <> "..") Then
                                Field(UBound(Field)) = SRoot & SFile
                                lngFileAttributes(UBound(Field)) = SFD.dwFileAttributes
                                Redim Preserve Field(0 To UBound(Field) + 1)
                                Redim Preserve lngFileAttributes&(0 To UBound(Field))
                            End If
                        End If
                    Loop While FindNextFile(ShFile, SFD)
                End If
            End If
            Call FindClose(ShFile)
        End If
    Loop While FindNextFile(hFile, FD)
    Call FindClose(hFile)
End Sub

Gruß
Nepumuk

Beliebteste Forumthreads (12 Monate)

Problem Ordner einlesen Win8/ Excel 2013

10 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread