zoeken naar filmbestand op harde schijf

1107972 · 29 sep 2008

Hallo,

Mijn doel is om een excel bestand te maken waarin ik een overzicht krijgt van film-bestanden die ik op verschillende locaties op mijn schijf heb staan. Omdat deze bestanden steeds meer wordt wil ik hiervoor iets maken dat die lijst genereert in excel. Uiteindelijk is mijn doel om er een xml bestand van de maken. Mijn idee was om het met VBA te gaan doen. Alleen aangezien mijn kennis van VBA niet veel verder gaat dan het opnemen van macro's en die te ontleden hoop ik dat jullie mij verder kunnen helpen.

Om iets duidelijker te zijn probeer ik hier in stappen uit te legen wat ik precies zoek.

In cel A1:A10 staan verschillende paden naar mappen waarin ik wil zoeken (bijv. A1: C:\Films Vakantie, A2: D:\Muziek Video's, enz.)

Als ik dan de macro start gaat hij eerst zoeken naar mpeg en avi bestanden in de map "Films Vakantie", daarna zoekt hij in de map "Muziek Video's".

Het Resultaat post hij bijvoorbeeld in kolom B. De informatie die ik moet hebben zijn het bestandspad, de bestandsnaam en de extentsie.

Ik hoop dat dit mogelijk is om te maken en zou degene erg dankbaar zijn die me hierin een beetje op weg mee wilt helpen of me in de juiste richting wilt wijzen. Want ik weet even niet welke kant ik op moet kijken of welke zoekwoorden ik moet gebruiken.

Groeten Eric

Wigi · 29 sep 2008

Als je niet met Excel 2007 werkt, dan werkt FileSearch.

Voor een zeer recent voorbeeld, zie hier:

http://www.worksheet.nl/forumexcel/showthread.php?t=57013

Wigi

1107972 · 29 sep 2008

Thanks,

ik ga het even een deze dagen proberen. Werkt met een vroege versie dan 2007 dus dat zal wel goed komen.

1107972 · 29 sep 2008

Halo Wigi,

nogmaals bedankt voor de link. heb er even naar gekeken maar kwam er niet direct uit. zat denk nog iets te ver uit de buurt van wat ik wilde. maar ben gaan zoeken in dit forum naar "filesearch" en kwam toen wel een paar leuke dingen tegen. Met wat knippen, plakken en proberen heb ik deze code werkend gekregen.

Code:

Sub Bestandslijst_maken()
 
    Sheets("Algemeen").Select
    
    Dim sPath As String
    Dim sFile As String
    Dim i As Integer
    
    sPath = ActiveCell.Worksheet.Range("B1").Value
    sFile = ActiveCell.Worksheet.Range("B2").Value
    
    If sPath = "" Then
    sPath = ThisWorkbook.Path
    End If
    
    With Application.FileSearch
        .NewSearch
        .LookIn = sPath
        .SearchSubFolders = True
        .Filename = sFile
        .MatchTextExactly = False
        .FileType = msoFileTypeAllFiles
    End With

    Sheets("Film").Select
    ActiveCell.Worksheet.Range("A:A").ClearContents
    ActiveCell.Worksheet.Range("A:A").ClearFormats
    Range("A1").Value = "Bestandspad"
    Range("A1").Font.Bold = True
        
    With Application.FileSearch
        If .Execute() > 0 Then
            For i = 1 To .FoundFiles.Count
                ActiveCell.Worksheet.Cells(i + 1, 1).Value = qdGetLeftPartRightToLeft(.FoundFiles(i), "\") & "\" & qdGetRightPartRightToLeft(.FoundFiles(i), "\")
            Next
                Columns("A:A").EntireColumn.AutoFit
                Sheets("Algemeen").Select
                MsgBox .FoundFiles.Count & " filmbestanden gevonden die voldoen aan de criteria."
        Else
            Sheets("Algemeen").Select
            MsgBox "Geen filmbestanden gevonden. Controleer de zoek locaties."
        End If
    End With
       
End Sub

Nu wil ik alleen nog de mogelijkheid hebben om in meerdere locaties naar verschillende film extenties te zoeken. bijvoorbeeld in verschillende schijven naar avi en mpeg bestanden en dat deze gezamelijk in 1 lijst worden weergegeven.

Wigi · 29 sep 2008

Hoi

Eerst en vooral, puik werk alvast :thumb:

Zoiets gaat niet in 1 keer

Maar wat je wel kan doen, is een lus maken doorheen de mappen. Om te vermijden dat je x aantal keer dezelfde code kopieert (enkel de map verschilt, de rest is gelijk): zet de FileSearch in een aparte procedure, en spreek die procedure x aantal keer aan.

1107972 · 30 sep 2008

We zijn weer een stap verder, zit nog even met 2 vraagjes. Hoe je precies een apparte procedure moet maken in excel snap ik niet. Heb wat geprobeerd met het maken van een nieuwe function en het oproepen van een nieuwe macro. Maar dat ging niet goed. Heb het nu gedaan met de functie GoTo, een nieuwe variabele die voorkomt dat je niet in GoTo blijft hangen en de functie If. Ik weet dat het niet de meest gestroomlijnde versie is maar het doet wat ik wil. Zie hieronder het resultaat.

Code:

Sub Bestandslijst_maken()
    
    'variabelen instellen
    Dim sVoortgang As Integer
    Dim sType1 As String
    Dim sType2 As String
    Dim sLocatie As String
    Dim i As Integer
        
    'werkblad Film leegmken voor nieuwe bestandslijst
    Sheets("Film").Select
    ActiveCell.Worksheet.Range("A:A").ClearContents
    ActiveCell.Worksheet.Range("A:A").ClearFormats
    Range("A1").Value = "Bestandspad"
    Range("A1").Font.Bold = True
    
          
    'zoekwaarden en voortgang instellen (0)
    sVoortgang = "0"
    sType1 = Sheets("Algemeen").Range("B1").Value
    sType2 = Sheets("Algemeen").Range("B2").Value

Kies_locatie: 'terugkeerpunt na het zoeken

    If sVoortgang = "0" Then
        'zoek locatie en voortgang instellen (A1)
        sVoortgang = "1"
        sLocatie = Sheets("Algemeen").Range("A1").Value
        GoTo Start_zoeken
    ElseIf sVoortgang = "1" Then
        'zoek locatie en voortgang instellen (A2)
        sVoortgang = "2"
        sLocatie = Sheets("Algemeen").Range("A2").Value
        GoTo Start_zoeken
    End If

GoTo Afsluiten_Macro

Start_zoeken: 'start de zoekroutine
    
    'controleer de zoeklocatie
    If sLocatie = "" Then
        GoTo Einde_zoeken
    End If
    
    'zoekroutine met zoekwaarde sType1
    With Application.FileSearch
        .NewSearch
        .LookIn = sLocatie
        .SearchSubFolders = True
        .Filename = sType1
        .MatchTextExactly = False
        .FileType = msoFileTypeAllFiles
    End With

    With Application.FileSearch
        If .Execute() > 0 Then
            For i = 1 To .FoundFiles.Count
                ActiveCell.Worksheet.Cells(i + 1, 1).Value = qdGetLeftPartRightToLeft(.FoundFiles(i), "\") & "\" & qdGetRightPartRightToLeft(.FoundFiles(i), "\")
            Next
                Columns("A:A").EntireColumn.AutoFit
        End If
    End With
    
    'zoekroutine met zoekwaarde sType2
    With Application.FileSearch
        .NewSearch
        .LookIn = sLocatie
        .SearchSubFolders = True
        .Filename = sType2
        .MatchTextExactly = False
        .FileType = msoFileTypeAllFiles
    End With

    With Application.FileSearch
        If .Execute() > 0 Then
            For i = 1 To .FoundFiles.Count
                ActiveCell.Worksheet.Cells(i + 1, 1).Value = qdGetLeftPartRightToLeft(.FoundFiles(i), "\") & "\" & qdGetRightPartRightToLeft(.FoundFiles(i), "\")
            Next
                Columns("A:A").EntireColumn.AutoFit
        End If
    End With
       
Einde_zoeken:     'einde van de zoekroutine

    GoTo Kies_locatie
    
Afsluiten_Macro:    'afsluiten van de macro

    Sheets("Algemeen").Select
    MsgBox "einde macro"
    
End Sub

Zoals je ziet, niet de meest gestroomlijnde code. Maar ik blijf met 2 puntjes zitten.

1: de plaats waar ik de zoekwaarde controleer wil ik nog een controle toepassen, namelijk het bestaand van de map. Indien de map niet bestaat wil ik een MsgBox weergeven. Zie hieronder de code waarin de wijziging moet komen.

Code:

    'controleer de zoeklocatie
    If sLocatie = "" Then
        GoTo Einde_zoeken
    End If

2: de resultaten van tweede zoekopdracht overschrijven de eerste, en de derde weer de tweede enzovoort. Wat ik zou willen is dat het resultaat van de zoekopdracht in de eerste lege cell in kolom A:A gedumpt worden. Zie hieronder de code waarin de wijziging moet komen.

Code:

            For i = 1 To .FoundFiles.Count
                ActiveCell.Worksheet.Cells(i + 1, 1).Value = qdGetLeftPartRightToLeft(.FoundFiles(i), "\") & "\" & qdGetRightPartRightToLeft(.FoundFiles(i), "\")

Voor de rest werkt alles naar behoren en zonder fouten. Al wil ik als dit is opgelost is nog een scherm maken waarin de resulaten.

Grt Eric

Wigi · 30 sep 2008

1107972 zei:
Hoe je precies een apparte procedure moet maken in excel snap ik niet.

Code:

Sub ToonBericht(sBericht As String)

    MsgBox sBericht

End Sub

Sub UitTeVoerenProcedure()

    Call ToonBericht("Hello world")

End Sub

Wigi

1107972 · 30 sep 2008

Ik ga er morgen nog eens even naar kijken want nu is het al weer een beetje laat aan het worden. Maar zoals ik al zei, de macro werkt goed. Ik zou juist het meest geholpen zijn als mijn andere 2 vragen beantwoord kunnen worden. Vooral de 2e is voor mij belangrijk (of is dat opgelost als ik het op jou voorgestelde manier gaat doen).

Alvast bedankt, Eric

Wigi · 1 okt 2008

Vraag 1: maak gebruik van Dir

Vraag 2:

Code:

ActiveSheet.Cells(i + 1, 1).Value = ...

Als er niets in die cellen staat zal er ook nooit overschreven worden. Uiteraard, als je de code 2 keer achter elkaar uitvoert, zal je wel eerst wat met die cellen moeten doen of ze worden overschreven.

1107972 · 1 okt 2008

@ Vraag 1: Daar kom ik denk ik wel uit. Heb al een leuk macrotje gevonden op internet waarop gestest wordt of in bepaald bestand bestaat.

Code:

If Len(Dir("c:\Instructions.doc")) = 0 Then
    Msgbox "This file does NOT exist."
Else
    Msgbox "This file does exist."
End If

@ Vraag 2: Ik zou natuurlijk gebruik kunnen maken van de variabele sVoortgang die ik dan bij elk nieuwe zoekopdracht verhoogt met 1. Met behlup van de volgende code zou dus het resultaat van elk zoekopdracht in een nieuwe kolom gedumpt worden. Moet ik alleen nog een macro verzinnen die alles weer onder elkaar zet.

Code:

ActiveSheet.Cells(i + 1, sVoortgang).Value = ...

Ik weet weer wat ik vanavond kan gaan doen, Thanks

Wigi · 1 okt 2008

Als je nu eens gewoon onderaan kolom A bijvoegt:

Code:

Range("A" & Rows.Count).End(xlUp).Offset(1,0).Value = "bla bla bla"

1107972 · 1 okt 2008

@Wigi: Dat was het laatste stukje code die ik zocht. Ik denk dat ik hem nu helemaal compleet heb zonder dat er veel overbodige regels instaan. Voor mij is het in ieder geval goed. Al wil ik nog wel aan het einde iets maken waarin de resultaten weergegeven worden van het aantal gevonden bestanden in elke map in een formulier. Maar dat is een heel ander onderdeel.

Hierbij de code:

De hoofdmacro die alles aanstruurt:

Code:

Option Explicit

Sub Start()
    
'variabelen instellen
    Dim sType As String
    Dim sLocatie As String

'werkblad Film klaar maken voor nieuwe bestandslijst
    Sheets("Film").Select
    ActiveCell.Worksheet.Range("A:A").ClearContents
    ActiveCell.Worksheet.Range("A:A").ClearFormats
    Range("A1").Value = "# OUTPUT ZOEKROUTINE"
    Range("A2").Value = "# betandspad"
    Range("A1:A2").Font.Bold = True
    
'1.1 zoekwaarde en locatie instellen
    sType = Sheets("Algemeen").Range("B1").Value
    sLocatie = Sheets("Algemeen").Range("A1").Value
    If sLocatie = "" Then
        GoTo EINDE_A1
    ElseIf FileOrDirExists(sLocatie) Then
        Call Zoekroutine(sLocatie, sType)
    Else
        MsgBox sLocatie & " is geen bestaande directory."
        GoTo EINDE_A1
    End If
'1.2 zoekwaarde en locatie instellen
    sType = Sheets("Algemeen").Range("B2").Value
    Call Zoekroutine(sLocatie, sType)
EINDE_A1:
'2.1 zoekwaarde en locatie instellen
    sType = Sheets("Algemeen").Range("B1").Value
    sLocatie = Sheets("Algemeen").Range("A2").Value
    If sLocatie = "" Then
        GoTo EINDE_A2
    ElseIf FileOrDirExists(sLocatie) Then
        Call Zoekroutine(sLocatie, sType)
    Else
        MsgBox sLocatie & " is geen bestaande directory."
        GoTo EINDE_A2
    End If
'2.2 zoekwaarde en locatie instellen
    sType = Sheets("Algemeen").Range("B2").Value
    Call Zoekroutine(sLocatie, sType)
EINDE_A2:
    
'werkblad film opmaken en afsluiten
    Columns("A:A").EntireColumn.AutoFit
    
    Columns("A:A").Select
    Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    Range("A1").Select
    
    Sheets("Algemeen").Select
    MsgBox "einde macro"
End Sub

De Zoekmacro:

Code:

Sub Zoekroutine(sLocatie As String, sType As String)

    Dim iResultaat As Integer
    
    With Application.FileSearch
        .NewSearch
        .LookIn = sLocatie
        .SearchSubFolders = True
        .Filename = sType
        .MatchTextExactly = False
        .FileType = msoFileTypeAllFiles
    End With

    With Application.FileSearch
        If .Execute() > 0 Then
            For iResultaat = 1 To .FoundFiles.Count
               Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Value = qdGetLeftPartRightToLeft(.FoundFiles(iResultaat), "\") & "\" & qdGetRightPartRightToLeft(.FoundFiles(iResultaat), "\")
            Next
        End If
    End With
End Sub

De Functie's die gebruikt worden (waar ik eigenlijk weinig van begrijp):

Code:

Function qdGetLeftPartRightToLeft(sSearch As String, sFind As String) As String
    
    Dim iThisPos As Integer
    Dim sResult As String
    
    iThisPos = 1
    
    Do While Not InStr(Right(sSearch, Len(sSearch) - iThisPos + 1), sFind) = 0
        iThisPos = iThisPos + InStr(Right(sSearch, Len(sSearch) - iThisPos + 1), sFind) + Len(sFind) - 1
    Loop
    
    If iThisPos = 1 Then
        Exit Function
    Else
        sResult = Left(sSearch, iThisPos - Len(sFind) - 1)
        qdGetLeftPartRightToLeft = sResult
    End If
End Function
 
Function qdGetRightPartRightToLeft(sSearch As String, sFind As String) As String
    
    Dim iThisPos As Integer
    Dim sResult As String
    
    iThisPos = 1
    
    Do While Not InStr(Right(sSearch, Len(sSearch) - iThisPos + 1), sFind) = 0
        iThisPos = iThisPos + InStr(Right(sSearch, Len(sSearch) - iThisPos + 1), sFind) + Len(sFind) - 1
    Loop
    
    If iThisPos = 1 Then
        Exit Function
    Else
        sResult = Right(sSearch, Len(sSearch) - iThisPos + 1)
        qdGetRightPartRightToLeft = sResult
    End If
End Function
 
Function FileOrDirExists(PathName As String) As Boolean

    Dim iTemp As Integer

    On Error Resume Next
    iTemp = GetAttr(PathName)

    Select Case Err.Number
    Case Is = 0
        FileOrDirExists = True
    Case Else
        FileOrDirExists = False
    End Select
     
    On Error GoTo 0
End Function

Thanks en bij deze zet ik de vraag op opgelost.

zoeken naar filmbestand op harde schijf

1107972

Gebruiker

Wigi

Inventaris

1107972

Gebruiker

1107972

Gebruiker

Wigi

Inventaris

1107972

Gebruiker

Wigi

Inventaris

1107972

Gebruiker

Wigi

Inventaris

1107972

Gebruiker

Wigi

Inventaris

1107972

Gebruiker

Nieuwste berichten

Wij waarderen jouw privacy