Macro zoeken bestand windows map+submappen

[bennieboef]

Hallo Allemaal,

Mijn macro zoekt in een windows map op de volgende manier : "prd." + <cell value> + ".dld"
Het probleem is dat er niet wordt gezocht in inderliggende bmappen

Hier de macro :

Option Explicit

Sub Find_DLD()
Dim AckTime As Integer, InfoBox As Object
Dim iRow As Integer ' ROW COUNTER.
Dim sSourcePath As String, currentpath As String
Dim sDestinationPath As String
Dim sFileType As String
Dim sFileType1 As String

Dim bContinue As Boolean

bContinue = True
iRow = 2

' THE SOURCE AND DESTINATION FOLDER WITH PATH.
sSourcePath = "S:"
sFileType = ".dld" ' TRY WITH OTHER FILE TYPES LIKE ".pdf".
sFileType1 = "prd."


' LOOP THROUGH COLUMN "B" TO PICK THE FILES.
While bContinue

If Len(Range("E" & CStr(iRow)).Value) = 0 Then ' DO NOTHING IF THE COLUMN IS BLANK.
Set InfoBox = CreateObject("WScript.Shell")
AckTime = 1
Select Case InfoBox.Popup("Klaar.", _
AckTime, "Hieperdepiep", 0)
Case 1, -1
Exit Sub
End Select
Else
' CHECK IF FILES EXISTS.

If Len(Dir(sSourcePath & sFileType1 & Range("E" & CStr(iRow)).Value & sFileType)) = 0 Then
Range("F" & CStr(iRow)).Value = "Geen kantprogramma"
Range("F" & CStr(iRow)).Font.Bold = True
Else
Range("F" & CStr(iRow)).Value = "Kantprogramma bestaat!"
Range("F" & CStr(iRow)).Font.Bold = False

End If
End If
iRow = iRow + 1 ' INCREMENT ROW COUNTER.
Wend
End Sub

Het zou fantastisch zijn al iemand deze code zo kan aanpassen dat de macro ook in de onderliggende mappen van s:\ gaat zoeken.

Alvast bedankt voor jullie hulp.

 

Bijlage :  bestand met macro.

Controle dxf + kantprogramma.xlsm

[josc1965]

Met zoveel modules in dat bestand mag je wel even vermelden in welke module we deze  code vinden. Tevens is het voor de leesbaarheid wenselijk dat je jouw code tussen <code > tags plaatst.

[bakerman]

Laten we hiermee beginnen.

 

Sub Find_DLD()
Dim AckTime As Integer, InfoBox As Object
Dim iRow As Integer ' ROW COUNTER.
Dim sSourcePath As String
Dim sFileType As String
Dim sFileType1 As String
Dim bContinue As Boolean
Dim found As Boolean, fl As Object, fld As Object

bContinue = True
iRow = 2

' THE SOURCE AND DESTINATION FOLDER WITH PATH.
sSourcePath = "S:"
sFileType = ".dld" ' TRY WITH OTHER FILE TYPES LIKE ".pdf".
sFileType1 = "prd."


' LOOP THROUGH COLUMN "B" TO PICK THE FILES.
While bContinue

    If Len(Range("E" & CStr(iRow)).Value) = 0 Then ' DO NOTHING IF THE COLUMN IS BLANK.
        Set InfoBox = CreateObject("WScript.Shell")
        AckTime = 1
        Select Case InfoBox.Popup("Klaar.", AckTime, "Hieperdepiep", 0)
            Case 1, -1
            Exit Sub
        End Select
    Else
        On Error Resume Next
        With CreateObject("scripting.filesystemobject")
            For Each fl In .getfolder(sSourcePath).Files
                If fl.Name Like sFileType1 & Range("E" & CStr(iRow)).Value & sFileType Then found = True: GoTo gevonden
            Next
            For Each fld In .getfolder(sSourcePath).subfolders
                For Each fl In fld.Files
                    If fl.Name Like sFileType1 & Range("E" & CStr(iRow)).Value & sFileType Then found = True: GoTo gevonden
                Next
            Next
        End With
gevonden:
        If Not found Then
            Range("F" & CStr(iRow)).Value = "Geen kantprogramma"
            Range("F" & CStr(iRow)).Font.Bold = True
        Else
            Range("F" & CStr(iRow)).Value = "Kantprogramma bestaat!"
            Range("F" & CStr(iRow)).Font.Bold = False
        End If
    End If
    iRow = iRow + 1 ' INCREMENT ROW COUNTER.
Wend
End Sub