Ordner über Explorer suchen

[DF6GL]

Hallo,

der ganze Code gehört in ein Standard-Modul. Nur der Funktionsaufruf ( Test ) passiert aus einer Ereignisprozdur (oder von woanders her)




" jeder schreibt, es ist doch ganz einfach, aber bei mir klappt es nicht. "
Du mußt Dich halt auch erst mit den Grudlagen der VBA-Programmierung auseinandersetzen...

[kater066]

habe das jetzt in ein Modul eingefügt und beim Aufruf kommt Fehlermeldung: Mehrdeutiger Name Sort by, also funktioniert das auch nicht, ich hör auf, da muss jemand anderes ran

[database]

Hallo,

Der Code in #14 weist einen groben Fehler auf!

Option Explicit KANN NICHT nach der Deklaration einer Ereignisprozedut stehen!
Also KEINESFFALLS steht    Option Explicit     NACH    Private Sub Befehl276_Click()  sondern in der 2. Zeile des Modulkopfes - d.h. NACH    Option Compare Database

Nach Anleitung von DF6GL solltest du den Code in eine Standardmodul verfrachten - das scheinst du ja gemacht zu haben - nur WAS hast du dorthin verfrachtet?

Öffne den VBA-Editor,
Öffne ein Modul oder ein Formularmodul
gehe zu Extras Optionen und setzte dort bei 'Variablendeklaration erforderlich' den Haken.

Damit wird Option Explicit in JEDES Neue Modul automatisch eingetragen.
Option Explicit legt fest dass Variablen deklariert werden müssen BEVOR sie verwendet werden - was dann wiederum ausshließt, dass du in deinem Code UNBEKANNTE Variablen einsetzen könntest.

Danach lege ein NEUES Modul an.

N A C H Option Explicit - (das steht ja nun schon an der richtigen Stelle) - kopierst du das da hin:

Code [Auswählen] Erweitern


Public Enum SORT_BY
    Sort_by_None
    Sort_by_Name
    Sort_by_Path
    Sort_by_Size
    Sort_by_Last_Access
    Sort_by_Last_Modyfy
    Sort_by_Date_Create
End Enum

Public Enum SORT_ORDER
    Sort_Order_Ascending
    Sort_Order_Descending
End Enum

Public Type FILEINFO
    strFilename As String
    strPath As String
    lngSize As Long
    dmtLastAccess As Date
    dmtLastModify As Date
    dmtDateCreate As Date
End Type

Public Sub Test()

    Dim objFileSearch As clsFileSearch
    Dim lngIndex As Long
   
    Set objFileSearch = New clsFileSearch
   
    With objFileSearch
        .CaseSenstiv = True
        .Extension = "*.xls"
        .FolderPath = "D:\"
        .SearchLike = "Test*"
        .SubFolders = True
        If .Execute(Sort_by_Size, Sort_Order_Descending) > 0 Then
            For lngIndex = 1 To .FileCount
                With .Files(lngIndex)
                    Debug.Print .strFilename, .lngSize
                End With
            Next
        End If
    End With
   
    Set objFileSearch = Nothing

End Sub


In deinem Formular, hast du einen Button namens 'Befehl276' und in dessen Ereignis 'Beim Klicken' schreibst du:

Code [Auswählen] Erweitern


Private Sub Befehl276_Click()
    Call Test
End Sub


...und dann schau mal was passiert

HTH

[kater066]

Hallo,
wenn ich das so ausführe kommt der Fehler unter "Public Enum SORT_BY" dass ein Fehler beim Kompilieren vorliegt, Mehrdeutiger Name Sort_by

Was muss ich hier weiter tun?

[kater066]

Habe etwas anderes versucht, es gab bereits ein Modul mit Namen Test deshalb gab es Probleme. Habe das jetzt umbenannt und er läuft bis zur Zeile unter Test "Dim objFileSearch As clsFileSearch" meldet dann "Benutzerdefinierter Typ nicht definiert"

[kater066]

Wieder 2 Stunden gebastelt, jetzt habe ich das Klassenmodul clsfilesearch erstellt (Inhalt aus dem Netz)

Option Compare Database
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 Declare Function FileTimeToLocalFileTime Lib "kernel32.dll" ( _
    ByRef lpFileTime As FILETIME, _
    ByRef lpLocalFileTime As FILETIME) As Long
Private Declare Function FileTimeToSystemTime Lib "kernel32.dll" ( _
    ByRef lpFileTime As FILETIME, _
    ByRef lpSystemTime As SYSTEMTIME) 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 SYSTEMTIME
    wYear As Integer
    wMonth As Integer
    wDayOfWeek As Integer
    wDay As Integer
    wHour As Integer
    wMinute As Integer
    wSecond As Integer
    wMilliseconds As Integer
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 mlngFileCount As Long
Private mudtFiles() As FILEINFO
Private mstrFolderPath As String
Private mstrExtension As String
Private mstrSearchLike As String
Private mblnSubFolders As Boolean
Private mblnCaseSenstiv As Boolean

Friend Property Get Files(lngIndex As Long) As FILEINFO
    Files = mudtFiles(lngIndex)
End Property

Friend Property Get FileCount() As Long
    FileCount = mlngFileCount
End Property

Friend Property Let FolderPath(strFolderPath As String)
    mstrFolderPath = strFolderPath
End Property

Friend Property Let Extension(strExtension As String)
    mstrExtension = strExtension
End Property

Friend Property Let SearchLike(strSearchLike As String)
    mstrSearchLike = strSearchLike
End Property

Friend Property Let SubFolders(blnSubFolders As Boolean)
    mblnSubFolders = blnSubFolders
End Property

Friend Property Let CaseSenstiv(blnCaseSenstiv As Boolean)
    mblnCaseSenstiv = blnCaseSenstiv
End Property

Friend Function Execute(Optional enmSortBy As SORT_BY = Sort_by_None, _
    Optional enmSortOrder As SORT_ORDER = Sort_Order_Ascending) As Long
    Call FindFiles(mstrFolderPath)
    If mlngFileCount > 1 And enmSortBy <> Sort_by_None Then _
        Call prcSort(1, mlngFileCount, enmSortBy, enmSortOrder)
    Execute = mlngFileCount
End Function

Private Sub FindFiles(ByVal strFolderPath As String)
    Dim WFD As WIN32_FIND_DATA, lngSearch As Long, strDirName As String
    On Error GoTo ErrorHandling
    If Right$(strFolderPath, 1) <> "\" Then strFolderPath = strFolderPath & "\"
    lngSearch = FindFirstFile(strFolderPath & "*.*", WFD)
    If lngSearch <> INVALID_HANDLE_VALUE Then
        Call GetFilesInFolder(strFolderPath)
        If mblnSubFolders Then
            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 FindFiles(strFolderPath & strDirName)
                End If
            Loop While FindNextFile(lngSearch, WFD)
        End If
        FindClose lngSearch
    End If
    Exit Sub
ErrorHandling:
    MsgBox "Fehler " & CStr(Err.Number) & vbLf & vbLf & _
        Err.Description, vbCritical, "Fehler"
End Sub

Private Sub GetFilesInFolder(ByVal strFolderPath As String)
    Dim WFD As WIN32_FIND_DATA, lngSearch As Long, strFilename As String
    Dim udtFiletime As FILETIME, udtSystemtime As SYSTEMTIME
    On Error GoTo ErrorHandling
    If Right$(strFolderPath, 1) <> "\" Then strFolderPath = strFolderPath & "\"
    lngSearch = FindFirstFile(strFolderPath & mstrExtension, WFD)
    If lngSearch <> INVALID_HANDLE_VALUE Then
        Do
            If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) <> FILE_ATTRIBUTE_DIRECTORY Then
                strFilename = Left$(WFD.cFileName, InStr(WFD.cFileName, Chr$(0)) - 1)
                If IIf(mblnCaseSenstiv, strFilename, LCase$(strFilename)) Like _
                    IIf(mblnCaseSenstiv, mstrSearchLike, LCase$(mstrSearchLike)) Then
                    mlngFileCount = mlngFileCount + 1
                    ReDim Preserve mudtFiles(1 To mlngFileCount)
                    With mudtFiles(mlngFileCount)
                        .strPath = strFolderPath & strFilename
                        .strFilename = strFilename
                        .lngSize = WFD.nFileSizeLow
                        FileTimeToLocalFileTime WFD.ftCreationTime, udtFiletime
                        FileTimeToSystemTime udtFiletime, udtSystemtime
                        .dmtDateCreate = CDate(DateSerial(udtSystemtime.wYear, udtSystemtime.wMonth, udtSystemtime.wDay) + _
                            TimeSerial(udtSystemtime.wHour, udtSystemtime.wMinute, udtSystemtime.wSecond))
                        FileTimeToLocalFileTime WFD.ftLastAccessTime, udtFiletime
                        FileTimeToSystemTime udtFiletime, udtSystemtime
                        .dmtLastAccess = CDate(DateSerial(udtSystemtime.wYear, udtSystemtime.wMonth, udtSystemtime.wDay) + _
                            TimeSerial(udtSystemtime.wHour, udtSystemtime.wMinute, udtSystemtime.wSecond))
                        FileTimeToLocalFileTime WFD.ftLastWriteTime, udtFiletime
                        FileTimeToSystemTime udtFiletime, udtSystemtime
                        .dmtLastModify = CDate(DateSerial(udtSystemtime.wYear, udtSystemtime.wMonth, udtSystemtime.wDay) + _
                            TimeSerial(udtSystemtime.wHour, udtSystemtime.wMinute, udtSystemtime.wSecond))
                    End With
                End If
            End If
        Loop While FindNextFile(lngSearch, WFD)
        FindClose lngSearch
    End If
    Exit Sub
ErrorHandling:
    MsgBox "Fehler " & CStr(Err.Number) & vbLf & vbLf & _
        Err.Description, vbCritical, "Fehler"
End Sub

Private Sub prcSort(lngLBorder As Long, lngUBorder As Long, enmSortBy As SORT_BY, enmSortOrder As SORT_ORDER)
    Dim lngIndex1 As Long, lngIndex2 As Long
    Dim udtBuffer As FILEINFO, vntTemp As Variant
    lngIndex1 = lngLBorder
    lngIndex2 = lngUBorder
    Select Case enmSortBy
        Case Sort_by_Name: vntTemp = mudtFiles((lngLBorder + lngUBorder) \ 2).strFilename
        Case Sort_by_Path: vntTemp = mudtFiles((lngLBorder + lngUBorder) \ 2).strPath
        Case Sort_by_Size: vntTemp = mudtFiles((lngLBorder + lngUBorder) \ 2).lngSize
        Case Sort_by_Last_Access: vntTemp = mudtFiles((lngLBorder + lngUBorder) \ 2).dmtLastAccess
        Case Sort_by_Last_Modyfy: vntTemp = mudtFiles((lngLBorder + lngUBorder) \ 2).dmtLastModify
        Case Sort_by_Date_Create: vntTemp = mudtFiles((lngLBorder + lngUBorder) \ 2).dmtDateCreate
    End Select
    Do
        Select Case enmSortBy
            Case Sort_by_Name
                If enmSortOrder = Sort_Order_Ascending Then
                    Do While mudtFiles(lngIndex1).strFilename < vntTemp
                        lngIndex1 = lngIndex1 + 1
                    Loop
                    Do While vntTemp < mudtFiles(lngIndex2).strFilename
                        lngIndex2 = lngIndex2 - 1
                    Loop
                Else
                    Do While mudtFiles(lngIndex1).strFilename > vntTemp
                        lngIndex1 = lngIndex1 + 1
                    Loop
                    Do While vntTemp > mudtFiles(lngIndex2).strFilename
                        lngIndex2 = lngIndex2 - 1
                    Loop
                End If
            Case Sort_by_Path
                If enmSortOrder = Sort_Order_Ascending Then
                    Do While mudtFiles(lngIndex1).strPath < vntTemp
                        lngIndex1 = lngIndex1 + 1
                    Loop
                    Do While vntTemp < mudtFiles(lngIndex2).strPath
                        lngIndex2 = lngIndex2 - 1
                    Loop
                Else
                    Do While mudtFiles(lngIndex1).strPath > vntTemp
                        lngIndex1 = lngIndex1 + 1
                    Loop
                    Do While vntTemp > mudtFiles(lngIndex2).strPath
                        lngIndex2 = lngIndex2 - 1
                    Loop
                End If
            Case Sort_by_Size
                If enmSortOrder = Sort_Order_Ascending Then
                    Do While mudtFiles(lngIndex1).lngSize < vntTemp
                        lngIndex1 = lngIndex1 + 1
                    Loop
                    Do While vntTemp < mudtFiles(lngIndex2).lngSize
                        lngIndex2 = lngIndex2 - 1
                    Loop
                Else
                    Do While mudtFiles(lngIndex1).lngSize > vntTemp
                        lngIndex1 = lngIndex1 + 1
                    Loop
                    Do While vntTemp > mudtFiles(lngIndex2).lngSize
                        lngIndex2 = lngIndex2 - 1
                    Loop
                End If
            Case Sort_by_Last_Access
                If enmSortOrder = Sort_Order_Ascending Then
                    Do While mudtFiles(lngIndex1).dmtLastAccess < vntTemp
                        lngIndex1 = lngIndex1 + 1
                    Loop
                    Do While vntTemp < mudtFiles(lngIndex2).dmtLastAccess
                        lngIndex2 = lngIndex2 - 1
                    Loop
                Else
                    Do While mudtFiles(lngIndex1).dmtLastAccess > vntTemp
                        lngIndex1 = lngIndex1 + 1
                    Loop
                    Do While vntTemp > mudtFiles(lngIndex2).dmtLastAccess
                        lngIndex2 = lngIndex2 - 1
                    Loop
                End If
            Case Sort_by_Last_Modyfy
                If enmSortOrder = Sort_Order_Ascending Then
                    Do While mudtFiles(lngIndex1).dmtLastModify < vntTemp
                        lngIndex1 = lngIndex1 + 1
                    Loop
                    Do While vntTemp < mudtFiles(lngIndex2).dmtLastModify
                        lngIndex2 = lngIndex2 - 1
                    Loop
                Else
                    Do While mudtFiles(lngIndex1).dmtLastModify > vntTemp
                        lngIndex1 = lngIndex1 + 1
                    Loop
                    Do While vntTemp > mudtFiles(lngIndex2).dmtLastModify
                        lngIndex2 = lngIndex2 - 1
                    Loop
                End If
            Case Sort_by_Date_Create
                If enmSortOrder = Sort_Order_Ascending Then
                    Do While mudtFiles(lngIndex1).dmtDateCreate < vntTemp
                        lngIndex1 = lngIndex1 + 1
                    Loop
                    Do While vntTemp < mudtFiles(lngIndex2).dmtDateCreate
                        lngIndex2 = lngIndex2 - 1
                    Loop
                Else
                    Do While mudtFiles(lngIndex1).dmtDateCreate > vntTemp
                        lngIndex1 = lngIndex1 + 1
                    Loop
                    Do While vntTemp > mudtFiles(lngIndex2).dmtDateCreate
                        lngIndex2 = lngIndex2 - 1
                    Loop
                End If
        End Select
        If lngIndex1 <= lngIndex2 Then
            udtBuffer = mudtFiles(lngIndex1)
            mudtFiles(lngIndex1) = mudtFiles(lngIndex2)
            mudtFiles(lngIndex2) = udtBuffer
            lngIndex1 = lngIndex1 + 1
            lngIndex2 = lngIndex2 - 1
        End If
    Loop Until lngIndex1 > lngIndex2
    If lngLBorder < lngIndex2 Then Call prcSort(lngLBorder, lngIndex2, enmSortBy, enmSortOrder)
    If lngIndex1 < lngUBorder Then Call prcSort(lngIndex1, lngUBorder, enmSortBy, enmSortOrder)
End Sub

Modul Ordnersuche:
Option Compare Database
Option Explicit
Public Enum SORT_BY
    Sort_by_None
    Sort_by_Name
    Sort_by_Path
    Sort_by_Size
    Sort_by_Last_Access
    Sort_by_Last_Modyfy
    Sort_by_Date_Create
End Enum

Public Enum SORT_ORDER
    Sort_Order_Ascending
    Sort_Order_Descending
End Enum

Public Type FILEINFO
    strFilename As String
    strPath As String
    lngSize As Long
    dmtLastAccess As Date
    dmtLastModify As Date
    dmtDateCreate As Date
End Type

Public Sub Test1()

   Dim objFileSearch As clsfilesearch
    Dim lngIndex As Long
   
    Set objFileSearch = New clsfilesearch
   
    With objFileSearch
        .CaseSenstiv = True
        .Extension = "*.jpg"
        .FolderPath = "f:\"
        .SearchLike = "*04891*"
        .SubFolders = True
        If .Execute(Sort_by_Size, Sort_Order_Descending) > 0 Then
            For lngIndex = 1 To .FileCount
                With .Files(lngIndex)
                    Debug.Print .strFilename, .lngSize
                End With
            Next
        End If
    End With
   
    Set objFileSearch = Nothing
     
       

End Sub

und den Befehl auf test1 geändert.

Es kommt keine Fehlermeldung mehr aber er zeigt mir auch keine Ergebnisse, jetzt komme ich wieder nicht weiter

[lumbumba]

...
With objFileSearch
        .CaseSenstiv = True
        .Extension = "*.jpg"
        .FolderPath = "f:\"
        .SearchLike = "*04891*"
        .SubFolders = True
        If .Execute(Sort_by_Size,
...

Evtl. gibt es ja keine Datei ( nicht Path ) die *04891*.jpg im Namen (nicht Path) beinhaltet,  denn .SearchLike = "*04891*" berücksichtigt nicht die Verzeichnisnamen. Ich erwähne das nur deshalb weil ich mal annehme das "*04891*" deine Prüfnummer ist, welche ja wiederum zum Teil oder ganz den Verzeichnisnamen darstellt.

Du könntest jetzt diesen Code mit dem von Database in Antwort #5 verlinkten Code kombinieren, bei dem du zuerst den Path suchst, und diesen gefundenen Path in .FolderPath = ... einsetzt. Dieses setzt aber voraus das das Prüfnummernverzeichnis nur ein einzigesmal auf der Partition F: vorkommt.

Andere Möglichkeit du schreibst den Filesearch-Code ein wenig um so das auch der Path berücksichtigt wird.
Ansonsten könnstest du es ja noch mal mit dem schon erwähnten Logparse probieren, eine Beispiel-DB hatte ich ja in meinem ersten Post mit angehängt.

[kater066]

Hallo,
es gibt nur eine Datei davon, aber er zeigt nichts an, auch nicht im Überwachungsfenster. Wenn ich deine angehängte DB starte und auf die Path suche mit den ... Punkten klicke kommt Fehlermeldung im Modul unter msoFileDialogFolderPicker.

[lumbumba]

Klick nicht auf den Button mit den "...". Der Code dahinter müsste in einer Zeile angepasst werden. Ist nicht weiter tragisch, tippe in dem Feld links daneben halt selber F:\ ein. Bedenke aber die Suche auf der kompletten Partition kann je nach Anzahl der Files auf dieser dauern.

[kater066]

ok, damit bekomme ich Inhalte angezeigt. Wie kann ich jetzt meine DB weiter anpassen damit der Ordner mit der passenden Prüfauftragnummer angezeigt und direkt in den Ordner im Explorer springt?

PS: ICH BIN KEIN PROFI, MAX. mittelmäßiger User, bitte so, dass ich es auch verstehen kann, danke euch

[lumbumba]

Evtl. so:

Code [Auswählen] Erweitern

Private Sub Befehl2_Click()

   On Error GoTo Sub_Handle_Error

   '// ** Wenn Textfelder leer verlasse Sub **
   If Len(Nz(Me.TB_Pruefauftragnummer, "")) = 0 Or Len(Nz(Me.TB_Root, "")) = 0 Then
       MsgBox "Fehlende Prüfnummer oder Rootangabe"
       Exit Sub
   End If
   
   Dim lpif As New MSUtil.COMFileSystemInputContextClass
   Dim LP As New MSUtil.LogQueryClass
   Dim rs As MSUtil.ILogRecordset
   Dim rec As MSUtil.ILogRecord
   Dim SQL As String, ss As String
   Dim sRoot As String
   Dim sPath As String
   Dim sOut As String
   
   '// ----------------------------------------------------------------------------------------------------------------
   '// ** Hole Daten aus den Textboxen **
   '// ----------------------------------------------------------------------------------------------------------------
   '// ** Prüfnummer **
   '// ** Ergebnis: z.B. %\558877 **
   sPath = "%\" & Me.TB_Pruefauftragnummer
   
   '// ** Root-Path **
   '// ** Ergebnis: z.B. F:\* **
   sRoot = Me.TB_Root & IIf(Right(Me.TB_Root, 1) = "\", "", "\") & "*"
   
   '// ** Baue SQL-String **
   SQL = "SELECT Path " & _
         "FROM '" & sRoot & "' " & _
         " Where Name <> '.' And Name <> '..' And Attributes LIKE '%D%' And Path Like '" & sPath & "'"
         
   
   '// ** nicht die letzte Zugriffszeit verändern **
   lpif.preserveLastAccTime = True
   
   '// ** durchsuche auch die Unterverzeichnisse **
   '// ** Werte sind: True(-1), False(0), 1, 2, etc. Angabe wie tief gescannt werden soll **
   lpif.recurse = True
   lpif.useLocalTime = True
   
   '// ** Run SQL **
   Set rs = LP.Execute(SQL, lpif)
   
   Do While Not rs.atEnd
       Set rec = rs.GetRecord
       sOut = rec.getValue("Path") & vbCrLf
       If Len(sOut) > 0 Then
           '// ** ein Path wurde gefunden, starte den zuerst gefundenen im Explorer **
           Shell "explorer.exe " & sOut, vbNormalFocus
           Set rec = Nothing
           Exit Do
       End If
       rs.MoveNext
       Set rec = Nothing
   Loop
   rs.Close
   
Sub_ExitClean:
   Set rs = Nothing
   Set lpif = Nothing
   Set LP = Nothing
   
   '// ** Exit here **
   Exit Sub
   
Sub_Handle_Error:
   MsgBox Err.Number & vbCrLf & Err.Description
   GoTo Sub_ExitClean
   
End Sub

Ich hänge mal eine DB mit dem entsprechen Formular an

[kater066]

Hallo,
es wird ein Treiber benötigt den ich nicht habe und nicht im Netz finde "pb_filesearch.dll". Kannst du mir den uploaden?

[lumbumba]

Das Teil benötigst du nicht, ist nur eine Verweisleiche. Solche Fehlermeldungen kannst du einfach selbst abstellen, du startest den VBA-Editor, klickst in der Menuleiste auf Extras --> Verweise und nimmst alle Haken bei "nicht Vorhanden" raus. Ich häng mal eine hoffentlich bereinigte Bsp mit an.

[Anhang gelöscht durch Administrator]

[kater066]

  mein erster Schritt nach vorne, das funktioniert und ist fast exakt was ich benötige, danke.
Perfekt wäre es wenn ich das nun in mein Formular einbinden könnte und die Prüfnummer automatisch gesetzt wird. Kann man das machen?

Die Prüfauftragnummer ist im Formular: [prüfaufträge_neu_zuweisen]![Prüfauftragnummer] hinterlegt, das LW F:\kann statisch bleiben, es liegen alle auf F:\ nur die Unterordner müssen variable gefunden werden, wie in deinem Beispiel.

Wie müsste ich das integrieren?

[lumbumba]

Die Sub wie im Beispiel in deinem Buttonklick übernehmen mit folgender Änderung:

Code (Wie immer ohne Gewähr) [Auswählen] Erweitern


Private Sub Befehl276_Click()
    On Error GoTo Sub_Handle_Error

    '// ** Wenn Textfelder leer verlasse Sub **
    If Len(Nz(Me![prüfaufträge_neu_zuweisen]![Prüfauftragnummer], "")) = 0  Then
        MsgBox "Fehlende Prüfnummer"
        Exit Sub
    End If
   
    Dim lpif As New MSUtil.COMFileSystemInputContextClass
    Dim LP As New MSUtil.LogQueryClass
    Dim rs As MSUtil.ILogRecordset
    Dim rec As MSUtil.ILogRecord
    Dim SQL As String, ss As String
    Dim sPath As String
    Dim sOut As String
   
    '// ----------------------------------------------------------------------------------------------------------------
    '// ** Hole Prüfnummer **
    '// ----------------------------------------------------------------------------------------------------------------
    sPath = "%\" & Me![prüfaufträge_neu_zuweisen]![Prüfauftragnummer]

    '// ** Baue SQL-String **
    SQL = "SELECT Path " & _
          "FROM 'F:\*' " & _
          " Where Name <> '.' And Name <> '..' And Attributes LIKE '%D%' And Path Like '" & sPath & "'"
         
    '// ** nicht die letzte Zugriffszeit verändern **
    lpif.preserveLastAccTime = True
   
    '// ** durchsuche auch die Unterverzeichnisse **
    '// ** Werte sind: True(-1), False(0), 1, 2, etc. Angabe wie tief gescannt werden soll **
    lpif.recurse = True
    lpif.useLocalTime = True
   
    '// ** Run SQL **
    Set rs = LP.Execute(SQL, lpif)
   
    Do While Not rs.atEnd
        Set rec = rs.GetRecord
        sOut = rec.getValue("Path") & vbCrLf
        If Len(sOut) > 0 Then
            '// ** ein Path wurde gefunden, starte den zuerst gefundenen im Explorer **
            Shell "explorer.exe " & sOut, vbNormalFocus
            Set rec = Nothing
            Exit Do
        End If
        rs.MoveNext
        Set rec = Nothing
    Loop
    rs.Close
   
Sub_ExitClean:
    Set rs = Nothing
    Set lpif = Nothing
    Set LP = Nothing
   
    '// ** Exit here **
    Exit Sub
   
Sub_Handle_Error:
    MsgBox Err.Number & vbCrLf & Err.Description
    GoTo Sub_ExitClean
end Sub