Foto's zoeken

BART1988 · 11 mrt 2020

Beste Forum leden

Eerst even schetsen wat de bedoeling is.
Ik heb een map IMG (\\di\re\ct\ory\IMG). In deze map staan een paar duizend andere mappen.
De naam van elke map is een nummer (gaat van 5 tot x nummers).
In sommige van deze mappen zitten bestanden zoals .docs/.pdf/.xls/.jpg/…., of een mix van deze.
Ik ben op zoek naar een macro die gaat kijken in welke van deze mappen een foto zit met dezelfde naam (in dit geval nummer) als de map waar deze inzit, de rest maakt niets uit.
In de mappen waar deze een foto vindt moet hij de nummers van de mappen kopiëren naar het tabblad “FOTO”, de mappen waar hij geen .jpg vindt moet hij kopiëren naar tabblad “GEEN FOTO”
Als laatste een msgbox met “Er zijn “x” aantal mappen gevonden met foto en “x” aantal zonder foto”
Kan iemand helpen?

BART1988 · 12 mrt 2020

Heeft iemand misschien enig idee aub?

snb · 12 mrt 2020

Ik zou de knop eerst een kleur geven.

BART1988 · 16 mrt 2020

Dag Snb

Kan je misschien een voorbeeld geven of op weg helpen?
Ik wil hier toch iets in elkaar proberen te knutselen.

OctaFish · 16 mrt 2020

@TS: Volgens mij snap je de diepere betekenis van de opmerking van snb niet, anders zou je dat zo zo niet vragen

.

WoutMag · 16 mrt 2020

Ik wat geknutseld:

Code:

Option Explicit

Private FSOLibrary As Object
Dim lngFoto As Long
Dim lngGeenFoto As Long
Dim strFotoBestanden As String

Public Sub FindFotoFiles()
    Dim fldr As FileDialog
    Dim strFolder As String
    Dim strNaam As String
    Dim intPos As Integer
    Dim FSOFolder As Object
    Dim SubFolder As Object
    
    
    
    Set FSOLibrary = CreateObject("Scripting.FileSystemObject")
    
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Selecteer een folder"
        .AllowMultiSelect = False
        If .Show = -1 Then
            strFolder = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With
    
    ' oude resultaat wissen
    Sheets("FOTO").Cells.ClearContents
    Sheets("GEEN FOTO").Cells.ClearContents
    
    ' initialiseren
    lngFoto = 0
    lngGeenFoto = 0
    ' Alle bestandsextensies voor foto bestanden
    strFotoBestanden = ".png.jpg.jpeg.gif"
    
    Set FSOFolder = FSOLibrary.GetFolder(strFolder)
    
    For Each SubFolder In FSOFolder.subFolders
        If KijkInFolder(SubFolder, SubFolder.Name) Then
            lngFoto = lngFoto + 1
            Sheets("FOTO").Cells(lngFoto, 1) = SubFolder.Path
        Else
            lngGeenFoto = lngGeenFoto + 1
            Sheets("GEEN FOTO").Cells(lngGeenFoto, 1) = SubFolder.Path
        End If
    Next
        
    
End Sub

Private Function KijkInFolder(FSOFolder As Object, strNaam As String) As Boolean
    Dim SubFolder As Object
    Dim FSOFile As Object
    Dim blnFoto As Boolean
    Dim intPos As Integer
    Dim strFileName As String
    Dim strExtensie As String
    
    
    blnFoto = False
    For Each FSOFile In FSOFolder.Files
        intPos = InStr(1, FSOFile.Name, ".")
        strFileName = Left(FSOFile.Name, intPos - 1)
        strExtensie = Mid(FSOFile.Name, intPos + 1)
        If strFileName = strNaam Then
            If InStr(1, strFotoBestanden, strExtensie) > 0 Then
                blnFoto = True
                Exit For
            End If
        End If
    Next
    
    ' optioneel in subfolders zoeken
    If Not blnFoto Then
        For Each SubFolder In FSOFolder.subFolders
            blnFoto = KijkInFolder(SubFolder, strNaam)
            If blnFoto Then Exit For
        Next
    End If
    KijkInFolder = blnFoto
End Function

Ik hoop dat het werkt.

BART1988 · 17 mrt 2020

Alvast bedankt om dit te proberen, ik hoop dat het werkt!
Ik wist niet dat dit zo ingewikkeld zou zijn, had ik nooit in elkaar geknutseld gekregen!

BART1988 · 17 mrt 2020

Ben deze wat aan het testen geweest. Verschillende mappen met verschillen bestanden in/geen in.
Conclusie:
1) Alle mappen (inclusief met foto) worden naar het tabblad “GEEN FOTO” geschreven.
2) Het hele pad wordt gekopieerd, kan enkel de naam (in dit geval nummer) van de map?

WoutMag · 18 mrt 2020

Aangepast versie

Code:

Option Explicit

Private FSOLibrary As Object
Dim lngFoto As Long
Dim lngGeenFoto As Long
Dim strFotoBestanden As String

Public Sub FindFotoFiles()
    Dim fldr As FileDialog
    Dim strFolder As String
    Dim strNaam As String
    Dim intPos As Integer
    Dim FSOFolder As Object
    Dim SubFolder As Object
    
    
    
    Set FSOLibrary = CreateObject("Scripting.FileSystemObject")
    
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Selecteer een folder"
        .AllowMultiSelect = False
        If .Show = -1 Then
            strFolder = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With
    
    ' oude resultaat wissen
    Sheets("FOTO").Cells.ClearContents
    Sheets("GEEN FOTO").Cells.ClearContents
    
    ' initialiseren
    lngFoto = 0
    lngGeenFoto = 0
    ' Alle bestandsextensies voor foto bestanden
    strFotoBestanden = ".png.jpg.jpeg.gif"
    
    Set FSOFolder = FSOLibrary.GetFolder(strFolder)
    
    For Each SubFolder In FSOFolder.subFolders
        If KijkInFolder(SubFolder, SubFolder.Name) Then
            lngFoto = lngFoto + 1
            Sheets("FOTO").Cells(lngFoto, 1) = SubFolder.Name
        Else
            lngGeenFoto = lngGeenFoto + 1
            Sheets("GEEN FOTO").Cells(lngGeenFoto, 1) = SubFolder.Name
        End If
    Next
        
    
End Sub

Private Function KijkInFolder(FSOFolder As Object, strNaam As String) As Boolean
    Dim SubFolder As Object
    Dim FSOFile As Object
    Dim blnFoto As Boolean
    Dim intPos As Integer
    Dim strFileName As String
    Dim strExtensie As String
    
    
    blnFoto = False
    For Each FSOFile In FSOFolder.Files
        intPos = InStr(1, FSOFile.Name, ".")
        strFileName = Left(FSOFile.Name, intPos - 1)
        strExtensie = Mid(FSOFile.Name, intPos + 1)
        If strFileName = strNaam Then
            If InStr(1, strFotoBestanden, strExtensie, vbTextCompare) > 0 Then
                blnFoto = True
                Exit For
            End If
        End If
    Next
    
    ' optioneel in subfolders zoeken
    If Not blnFoto Then
        For Each SubFolder In FSOFolder.subFolders
            blnFoto = KijkInFolder(SubFolder, strNaam)
            If blnFoto Then Exit For
        Next
    End If
    KijkInFolder = blnFoto
End Function

Veel succes

snb · 18 mrt 2020

Eenvoudig toch ?

Inventariseer alle mappen en submappen: 1 regel VBA

Zoek in een lus per map of daarin een .jpg bestand zit met dezelfde naam: 3 regels VBA

schrijf de resultaten weg: 2 regels VBA

BART1988 · 18 mrt 2020

De aangepaste versie schrijft alleen de namen van de map weg, oké dus...
Maar alles blijft in het tabblad "GEEN FOTO" komen...

VenA · 18 mrt 2020

Al eens met <F8> door de code gelopen om te zien welke variabele welke waarde krijgt?

BART1988 · 18 mrt 2020

Ik had de indruk dat ik altijd over onderstaande stuk overspring en daarom altijd in "GEEN FOTO" beland...

Code:

 If KijkInFolder(SubFolder, SubFolder.Name) Then
            lngFoto = lngFoto + 1
            Sheets("FOTO").Cells(lngFoto, 1) = SubFolder.Name

WoutMag · 19 mrt 2020

Ik heb geen idee wat het probleem bij jou is Bart. Bij mijn werkt deze macro zoals ik bedoeld heb.

Enigmasmurf · 19 mrt 2020

Even van ver naar gekeken, en dan is meteen duidelijk dat de macro van WoutMag wel degelijk moet kloppen, met dien verstande dat enkel de mappen die direct onder "...\IMG" staan worden behandeld, maar niet deze van onderliggende niveau(s), dus best mogelijk dat alles wat in die 'bovenste' map staat voldoet aan het criterium "geen foto".

WoutMag · 19 mrt 2020

Ik heb getest

Opzet in mijn afbeeldingen folder:
..\5\5.png
..\6\X.txt
..\6A\6.png
..\7\aap.doc
..\8\noot.xls

Dit heeft als resultaat dat 5 en 6 op tab FOTO komen en de overige op tab GEEN FOTO

BART1988 · 19 mrt 2020

Dag Wout

Dit werkt hier nu ook, wat ik verkeerd deed, geen idee!
Super hard bedankt voor de moeite.

Wat Enigmasmurf en de onderliggende mappen betreft, dit moet ik nog een testen...

BART1988 · 19 mrt 2020

@ Enigmasmurf

Juist getest...
Als de foto in de submap (submap heeft een gans andere naam) staat en hij heeft dezelfde naam als de hoofdmap wordt deze ook weergegeven...

VenA · 19 mrt 2020

Ook al iets met de suggestie in #11 gedaan?

BART1988 · 24 mrt 2020

De macro werkt perfect, waarvoor dank!
Alleen nog een kleine kanttekening vanwege mijn kant.
De namen van de foto's hebben inderdaad dezelfde naam als de hoofdmap, maar ik ben er vergeten bij te vertellen dat er dan achter de naam (nummer) steeds nog _A, _B,... staat. De bedoeling is dat foto _A de belangrijkste is, foto _B de tweede belangrijkste,...
Dus zou deze macro moeten gaan kijken naar de foto waar _A achterstaat, deze _A dan "wegdenken" en dan de naam (nummer) vergelijken met de map.
Mijn excuses!

Foto's zoeken

Gebruiker

Bijlagen

Gebruiker

Verenigingslid

Gebruiker

Verenigingslid

Gebruiker

Gebruiker

Gebruiker

Gebruiker

Verenigingslid

Gebruiker

Inventaris

Gebruiker

Gebruiker

Gebruiker

Gebruiker

Gebruiker

Gebruiker

Inventaris

Gebruiker

Wij waarderen jouw privacy