Option Explicit
Private strList() As String
Dim varFolder As Variant
Private lngCount As Long
Dim strTMP As String
Public Sub Dateinamen()
Columns("A:C").EntireColumn.Hidden = True
lngCount = 0
strTMP = "D:\test"
If strTMP = "" Or Left(strTMP, 1) = ":" Then Exit Sub
SearchFiles strTMP, "*.pdf"
If Right(strTMP, 1) <> "\" Then strTMP = strTMP & "\"
If lngCount = 0 Then
MsgBox "No file found"
Exit Sub
End If
With ThisWorkbook.Worksheets(1)
.Columns(1).Clear
.Range(.Cells(3, 1), Cells(lngCount + 2, 1)) = _
WorksheetFunction.Transpose(strList)
.Columns("A").AutoFit
Columns("A:C").EntireColumn.Hidden = True
End With
Call Make_Link
Set varFolder = Nothing
End Sub
Private Function GetFolder() As String
Dim objShell As Object
Dim strPath As String
Set objShell = CreateObject("Shell.Application")
Set varFolder = objShell.BrowseForFolder(0, "Folder", &H4000, 17)
If varFolder Is Nothing Then
Set varFolder = Nothing
Set objShell = Nothing
Exit Function
End If
GetFolder = varFolder.Self.Path
Set objShell = Nothing
End Function
Private Sub SearchFiles(strFolder As String, strFileName As String, Optional blnSubFolder As Boolean = False)
Dim objFolder As Object
Dim objFile As Object
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
For Each objFile In objFSO.GetFolder(strFolder).Files
If objFile.Name Like strFileName Then
ReDim Preserve strList(lngCount)
strList(lngCount) = objFile.Name
lngCount = lngCount + 1
End If
Next
If blnSubFolder = True Then
For Each objFolder In objFSO.GetFolder(strFolder).Subfolders
SearchFiles strFolder & "\" & objFolder.Name, strFileName
Next objFolder
End If
End Sub
Public Sub Make_Link()
Dim lngRow As Long
With ThisWorkbook.Worksheets(1)
lngRow = .Range("A" & .Rows.Count).End(xlUp).Row
For lngRow = 2 To lngRow
.Hyperlinks.Add Anchor:=.Cells(lngRow, 1), _
Address:=strTMP & .Cells(lngRow, 1)
Next lngRow
End With
End Sub