VBA namen bestanden (en meer) van map op werkblad

[Mario62]

Hoi,
Ik ben al enkele dagen alle mogelijke sites aan het nazien – maar ik vond nog geen oplossing voor mijn probleem. Ik gebruik voor alle duidelijkheid ik gebruik Excel 2007 - vba.
Ik wil graag alle namen van powerpointspresentaties (met extensie pps en pptx (die van 2007)) die in een map staan, automatisch inbrengen op een werkblad. De map heb ik liefst te kiezen via een dialoog venster. Ook zou ik graag in de kolom ernaast de volledige naam hebben (inclusief pad dus), de kolom ernaast de grootte en dan de kolom daarnaast de datum.

Dus bv.
Mooi.pps D:\powerpoint\Mooi.pps 1,520 15/4/2009

Als een extraatje – het zou fijn dat de eerste naam een hyperlink was …

Ik vond al onderstaande code maar het nadeel is dat ik hier geen volledige naam (inclusief pad dus) verkrijg, ten tweede – zou ik leuker vinden dat om de folder te kiezen ik gewoon de foldernaam kan kiezen in plaats van op bestanden – wat ik ook probeer.

‘++++++++++++++++++++++++++++++++++++++++++++++++

Private Sub CommandButton1_Click()

Sheets("powerpoint").Select
wispowerpoint

firstfile = Application.GetOpenFilename("Powerpoint Files (*.pps), *.pps")
If firstfile = False Then Exit Sub

'navigates to target directory and selects a file
mynewstring = firstfile

'next strip off filename to get just the directory name
ConditionIsMet = False

Do Until ConditionIsMet
 y = X
 On Error GoTo Err
 X = Application.WorksheetFunction.Find("\", mynewstring)
 mynewstring = Right(mynewstring, Len(mynewstring) - X)
Loop

myFileLen = Len(mynewstring)
directory = Left(firstfile, Len(firstfile) - myFileLen)
myRow = 1
Cells(myRow, 1) = "powerpoint"
Cells(myRow, 5) = "Grootte"
Cells(myRow, 6) = "Dag"
myRow = myRow + 1

'get first file info
mynewfile = Dir(directory, 7)
Cells(myRow, 1) = mynewfile
Cells(myRow, 5) = FileLen(directory & mynewfile) / 1000000
Cells(myRow, 6) = FileDateTime(directory & mynewfile)

'get remaining files' info
Do While mynewfile <> ""
 mynewfile = Dir
 If mynewfile <> "" And Right(mynewfile, 3) = "pps" Then
   myRow = myRow + 1
   Cells(myRow, 1) = mynewfile
   Cells(myRow, 5) = FileLen(directory & mynewfile) / 1000000
   Cells(myRow, 6) = FileDateTime(directory & mynewfile)
 End If
Loop

MsgBox "alle namen zijn opgehaald"
Unload namenophalen

Exit Sub
Err:
ConditionIsMet = True
X = 0
Resume Next

End sub

‘+++++++++++++++++++++++++++++++++

Kan iemand zo vriendelijk zijn me te helpen?
Mario

 

[Mario62]

Iemand was zo vriendelijk om me het volgende antwoord door te sturen...

Private Sub CommandButton1_Click() 
    Dim fDir As FileDialog 
    Dim dName As String 
    Dim fName As String 
    Dim NextRow As Long 
    Dim FSO As Object 
     
    Set fDir = Application.FileDialog(msoFileDialogFolderPicker) 
    With fDir 
         
        .AllowMultiSelect = False 
         
        If .Show = -1 Then 
             
            Set FSO = CreateObject("Scripting.FileSystemobject") 
            dName = .SelectedItems(1) & Application.PathSeparator 
            fName = Dir(dName & "*.pp**") 
            Do Until fName = "" 
                 
                NextRow = NextRow + 1 
                Cells(NextRow, "A").Value = fName 
                Cells(NextRow, "B").Value = dName & fName 
                Cells(NextRow, "C").Value = Format(FSO.getfile(dName & fName).DateLastModified, "dd/mm/yyyy") 
                Cells(NextRow, "D").Value = FSO.getfile(dName & fName).Size 
                fName = Dir 
            Loop 
        End If 
    End With 
End Sub 
[\code]
Dank aan allen die zochten!!
Mario

 

[Wigi]

Bedankt!

PS: De afsluitende code tag is [/code] en geen backslash