Filesearch vervangen voor Dir()

[AvC]

Wie heeft voor mij de oplossing.
Onderstaande macro krijg ik niet meer aan de gang. FileSearch is vervallen en ik moet nu met het DIR commando werken. Echter ik ben nu al een paar dagen aan het zoeken en tips proberen van het forum. Maar zonder succes . Voor mij is het duidelijk. Mijn kennis kan wel een boost gebruiken.

Het mooiste zou zijn dat als ik een keuze gemaakt heb via een Slicer genaamd (Naam) Er een pdf bestand geopend wordt met de naam gekozen in deze Slicer. Als dit niet kan dan hoop ik dat iemand onderstaande macro weer aan de praat krijg voor me.

Alvast bedankt.

Sub OpenReference()

On Error Resume Next
Dim Filename As String, I As Integer, RetVal
Filename = ActiveCell.Value
 

With Application.FileSearch
    .NewSearch
    .LookIn = "C:\Documents"
    .SearchSubFolders = True
    .Filename = "*" & Filename & "*.pdf"
    .MatchTextExactly = False
    .FileType = msoFileTypeAllFiles
End With
With Application.FileSearch
    If .Execute(msoSortByLastModified, msoSortOrderDescending) > 0 Then
       For I = 1 To .FoundFiles.Count
            Debug.Print .FoundFiles(I)
       Next I
      ActiveWorkbook.FollowHyperlink Address:=.FoundFiles(1)
    Else
        MsgBox "There were no files found."
    End If
End With
 

End Sub

 

[huijb]

Macro's zijn VBA. Verplaatst naar VBA sectie

 

[Elsendoorn2134]

Oplossing met recursieve functie

AvC,

Op dit moment is er geen makkelijke manier om subdirectories te doorzoeken.
Met Dir() heb je niet de mogelijkheid om een directorie met subdirectories op te roepen, Dir() werkt alleen
in een directorie die je hebt aangegeven.
Wel is er een mogelijkheid om een lijst te laten maken van alle subdirectories van een bepaalde directorie
en die met Dir() een voor een laten doorzoeken op PDF bestanden.
Ik heb even moeten zoeken maar hierbij zo'n recursief (zichzelf aanroepende functie) die de lijst maakt met
een programma om hier de pdf in terug te vinden.
Het programma maakt een lijst aan met twee kolommen, de eerste gevuld met het Pad, de tweede met de
bestandsnaam.

Option Explicit

Public Arr() As String
Public Counter As Long

Sub LoopThroughFilePaths()
Dim myArr               'Array met verschillende subdirectories.
Dim i As Long           'Teller van de regels
Dim j As Long           'Teller van de lijst met subdirectories.
Dim MyFile As String    'Huidig bestand

Const strPath As String = "C:\Users\Frans\Documents"

On Error Resume Next

myArr = GetSubFolders(strPath)              'Vul een array met alle subdirectories
Range("A1:B1") = Array("Pad", "Bestand")    'Vul de koprecord
    For j = LBound(Arr) To UBound(Arr)      'Loop door de array
        MyFile = Dir(myArr(j) & "\*.pdf")   'Lees een bestand met dir die eindigd op *.pdf
        Do While Len(MyFile) <> 0           'Doe zolang binnen de subdir. een pdf gevonden wordt
        i = i + 1                           'Verhoog i voor een volgende regel
            Cells(i + 1, 1) = myArr(j)      'Print de subdirectory
            Cells(i + 1, 2) = MyFile        'Print bestandsnaam
            MyFile = Dir                    'Zoek volgend bestand
        Loop
    Next j

End Sub

Function GetSubFolders(RootPath As String)
'Functie maakt een overzicht van alle subdirectories door iedere
'subdirectorie te doorzoeken op subdirectories en daarna zichzelf aan te roepen.

Dim fso As Object       'FileSystemObject
Dim fld As Object       'FileFolderObject
Dim sf As Object        'SubFolderObject
Dim myArr As String     'Voor het opnieuw aanroepen van deze functie

On Error Resume Next

Set fso = CreateObject("Scripting.FileSystemObject")    'Creeer FileSystemObject
Set fld = fso.GetFolder(RootPath)           'Creeer FileFolderObject
For Each sf In fld.subfolders               'Creeer SubFolderObject
    Counter = Counter + 1                   'Verhoog teller
    ReDim Preserve Arr(Counter)             'Aanpassen grote van de array
    Arr(Counter) = sf.Path                  'Toevoegen van de subdirectory aan de array
    myArr = GetSubFolders(sf.Path)          'aanroep om te zoeken naar sudirectories in de huidige.
Next

GetSubFolders = Arr                         'Teruggeven array aan hoofdprocedure

Set sf = Nothing        'Opruimen SubFolderObject
Set fld = Nothing       'Opruimen FileFolderObject
Set fso = Nothing       'Opruimen SubFolderObject

End Function

Veel Succes.

 

[AvC]

Elsendoorn2134 super, bedankt.

Als ik mijn pfd bestanden nu eens niet in subdirectory's zet. Maar gewoon verplaatst naar 1 map. Is het dan wel mogelijk via een slicer gekozen pfd bestand te openen.

 

[HSV]

Lukt het hiermee AvC ?

Sub hsv()
 With Application.FileDialog(msoFileDialogOpen)
  .InitialFileName = "C:\Users\HSV\Documents\Excel tips"
  .FilterIndex = 2
  .Show
  .Execute
 End With
If ActiveWorkbook.Name <> ThisWorkbook.Name Then
   Application.Goto ActiveWorkbook.Sheets(1).Range("A1")
 End If
End Sub

 

[HSV]

Extra Pdf filter op de tweede plaats toegevoegd in de file-open onder "Alle bestanden", maar wordt automatisch geopend door de "filterindex = 2".

Sub hsvtwee()
 With Application.FileDialog(msoFileDialogOpen)
  .InitialFileName = "C:\Users\HSV\Documents"
[COLOR=#FF0000]  .Filters.Add "Pdf-Bestanden", "*.pdf", 2[/COLOR]
  .FilterIndex = 2
  .Show
  .Execute
 End With
If ActiveWorkbook.Name <> ThisWorkbook.Name Then
   Application.Goto ActiveWorkbook.Sheets(1).Range("A1")
 End If
End Sub

 

[AvC]

Harry,

dit werkt bijna. Hij wil hem nu alleen nog openen als een excel bestand in een werkblad, maar het zijn pdf bestanden. Ziet er een beetje raar uit met al die vreemde tekens.
Het is de bedoeling dat het geopend wordt in een pdf viewer.


de code is nu:

Sub LoopThroughFiles()

   On Error Resume Next
    Dim StrFile As String
    Dim Filename As String
        
 Filename = ActiveCell.Value & ".pdf"
      
   StrFile = ("D:\Mijn Documenten\ PDF-files\") & Filename
    Do While Len(StrFile) < 0
       Debug.Print StrFile
       Loop
 
If StrFile <> False Then

 With Application.FileDialog(msoFileDialogOpen)
  .InitialFileName = StrFile
  .FilterIndex = 2
  .Show
  .Execute
 End With

If ActiveWorkbook.Name <> ThisWorkbook.Name Then
  Application.Goto ActiveWorkbook.Sheets(1).Range("E1")
 
 
Else

    MsgBox "PID nr niet gevonden!!"
 End If
End Sub

 

[HSV]

Ja, logisch.

Sub hsvtwee()
Dim Acropad As String, bestand As String, strItem
 With Application.FileDialog(msoFileDialogOpen)
  .InitialFileName = "C:\Users\HSV\Documents"
  .Filters.Add "Adobe PDF-Bestanden (.pdf)", "*.pdf", 3
  .FilterIndex = 3
 If .SelectedItems.Count = 1 And .Show = -1 Then
    For Each strItem In .SelectedItems
        bestand = " " & strItem
    Next strItem
 Acropad = "C:\Program Files (x86)\Adobe\Reader 10.0\Reader\AcroRd32.exe"
    Shell Acropad & bestand, vbMaximizedFocus
   End If
  End With
End Sub

Om er zeker van te zijn dat je een PDF bestand selecteerd.

Sub hsvdrie()
Dim Acropad As String, bestand As String, strItem
 With Application.FileDialog(msoFileDialogOpen)
  .InitialFileName = "C:\Users\HSV\Documents"
  .Filters.Add "Adobe PDF-Bestanden (.pdf)", "*.pdf", 3
  .FilterIndex = 3
 If .SelectedItems.Count = 1 And .Show = -1 Then
    For Each strItem In .SelectedItems
    If Right(strItem, 4) = ".pdf" Then
        bestand = " " & strItem
     Else
       MsgBox "Kies een PDF bestand"
      Exit Sub
     End If
    Next strItem
 Acropad = "C:\Program Files (x86)\Adobe\Reader 10.0\Reader\AcroRd32.exe"
    Shell Acropad & bestand, vbMaximizedFocus
   End If
  End With
End Sub

 

[AvC]

weer een stukje verder
Ik kan nu een bestand kiezen. De naam wordt ingevuld aan de hand van de naam in een activecell. Maar na deze keuze zie ik een flits, maar wordt niet Adobe reader 11.0 met gekozen bestand geopend.

 

[HSV]

Zit Adobe in?

Acropad = "C:\Program Files [COLOR=#FF0000](x86)[/COLOR]\Adobe\Reader 11.0\Reader\AcroRd32.exe"

Of zonder de rode tekst.

Acropad = "C:\Program Files\Adobe\Reader 11.0\Reader\AcroRd32.exe"

 

[AvC]

Nee helaas nog steeds na de bestandskeuze een flits en geen opstartende Adobe

Sub LoopThroughFiles()

   
    
 On Error Resume Next
   ' Dim StrFile As String
    Dim Filename As String
    Dim Acropad As String, bestand As String, StrFile
        
 Filename = ActiveCell.Value & ".pdf"
      
 StrFile = ("D:\Mijn Documenten\PDF-files\") & Filename
    Do While Len(StrFile) < 0
       Debug.Print StrFile
       Loop
 
If StrFile <> False Then

With Application.FileDialog(msoFileDialogOpen)
  .InitialFileName = StrFile
  .Filters.Add "Adobe PDF-Bestanden (.pdf)", "*.pdf", 3
  .FilterIndex = 3
 If .SelectedItems.Count = 1 And .Show = -1 Then
    For Each StrFile In .SelectedItems
        bestand = " " & StrFile
    Next StrFile
 Acropad = "C:\Program Files (x86)\Adobe\Reader 11.0\Reader\AcroRd32.exe"
    Shell Acropad & bestand, vbMaximizedFocus
   End If
  End With


Else

    MsgBox "PID nr niet gevonden!!"

End If

 

[huijb]

@AvC Onnodige quotes verwijderd. Wanneer je direct reageert op een reactie is het niet nodig om dat bericht te quoten. Onnodig quoten heet dat, hetgeen niet gewenst is. Maar ook. Code dient tussen de codetags geplaatst te worden. Hiermee is het beter leesbaar voor de helpers. Zie ook hier http://www.helpmij.nl/forum/showthr...-de-helpers-in-deze-sectie-van-dienst-te-zijn

 

[HSV]

Graag gebruik maken van codetags (selecteer je code en druk knopje #).

Je code loopt goed bij mij.
Even vertaald naar mijn Pc ziet het er zo uit.

Sub LoopThroughFiles()
 

On Error Resume Next
 ' Dim StrFile As String
 Dim Filename As String
 Dim Acropad As String, bestand As String, StrFile
 Filename = ActiveCell.Value & ".pdf"
 StrFile = "C:\users\hsv\Documents\PDF-files\" & Filename
 Do While Len(StrFile) < 0
 Debug.Print StrFile
 Loop
 If StrFile <> False Then
 
With Application.FileDialog(msoFileDialogOpen)
 .InitialFileName = StrFile
 .Filters.Add "Adobe PDF-Bestanden (.pdf)", "*.pdf", 3
 .FilterIndex = 3
 If .SelectedItems.Count = 1 And .Show = -1 Then
 For Each StrFile In .SelectedItems
 bestand = " " & StrFile
 Next StrFile
 Acropad = "C:\Program Files (x86)\Adobe\Reader 10.0\Reader\AcroRd32.exe"
 Shell Acropad & bestand, vbMaximizedFocus
 End If
 End With
 
Else
 
MsgBox "PID nr niet gevonden!!"
 
End If
End Sub

 

[AvC]

Adobe wordt nu gestart maar komt met foutmelding. Bestand niet gevonden.

 

[huijb]

@AvC Voor de tweede keer: Zou je willen stoppen met het onnodig quoten van berichten. Heb nu al diversen reacties van je aangepast.

 

[HSV]

De code loopt wel gewoon door als je "On Error Resume Next" weghaalt?
Wat staat er in de actieve cel?

 

[AvC]

oeps sorry huijb ik zit dus steeds op de verkeerde knop te drukken.

 

[AvC]

Harry,

in de activecell staat de naam van een pdf bestand zonder ".pdf"
Als ik de marco start zie ik de naam goed in het "Bestand openen venster" staan. Maar Adobe komt met de foutmelding "Er is een fout opgetreden. Kan bestand niet vinden.
Als ik dit zelfde bestand via de verkenner opzoek en start opent hij wel goed via Adobe.

 

[HSV]

Ik heb er geen idee van.

 

[HSV]

Heb je #16 uitgevoerd?