Pfad Automatisch Einlesen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Heinz,
mit folgenden Makros hast du das ganze im Griff:

' **********************************************************************
' Modul: DieseArbeitsmappe Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Private Sub Workbook_Open()
    Call prcGetFolder
End Sub

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

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

Private Const INVALID_HANDLE_VALUE = -1
Private Const FILE_ATTRIBUTE_DIRECTORY = &H10
Private Const MAX_PATH = 260
Private Const S_FOLDER = "PACKANWEISUNGEN"

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

Private blnFound As Boolean

Public strPath As String

Public Sub prcGetFolder()
    Dim objFSO As Object, objDrive As Object
    blnFound = False
    strPath = GetSetting("Testmappe", "Daten", "Pfad", "")
    If strPath = "" Or (strPath <> "" And Dir$(strPath, vbDirectory) = "") Then
        Set objFSO = CreateObject("Scripting.FileSystemObject")
        For Each objDrive In objFSO.Drives
            If objDrive.IsReady Then
                Call prcFindFolder(objDrive.DriveLetter & ":\")
                If blnFound Then Exit For
            End If
        Next
        If blnFound Then
            SaveSetting "Testmappe", "Daten", "Pfad", strPath
        Else
            MsgBox "Ordner nicht gefunden!", vbExclamation, "Hinweis"
            End
        End If
    End If
    MsgBox strPath 'nur zum Testen !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
End Sub

Private Sub prcFindFolder(ByVal strFolderPath As String)
    Dim udtWFD As WIN32_FIND_DATA, lngSearch As Long, strDirName As String
    If Not blnFound Then
        If Right$(strFolderPath, 1) <> "\" Then strFolderPath = strFolderPath & "\"
        lngSearch = FindFirstFile(strFolderPath & "*.*", udtWFD)
        If lngSearch <> INVALID_HANDLE_VALUE Then
            Do
                If (udtWFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) Then
                    strDirName = Left$(udtWFD.cFileName, _
                        InStr(udtWFD.cFileName, Chr(0)) - 1)
                    If (strDirName <> ".") And (strDirName <> "..") Then
                        If LCase$(strDirName) = LCase$(S_FOLDER) Then
                            strPath = strFolderPath & strDirName
                            blnFound = True
                            Exit Sub
                        Else
                            Call prcFindFolder(strFolderPath & strDirName)
                        End If
                    End If
                End If
            Loop While FindNextFile(lngSearch, udtWFD) And Not blnFound
            FindClose lngSearch
        End If
    End If
End Sub

Der Pfad befindet sich in der Variable strPath.
Gruß
Nepumuk

Beliebteste Forumthreads (12 Monate)

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread