Hallo,
ik wil het volgende voor elkaar krijgen wat me tot nu toe niet lukt.
ik wil in een excel sheet zeg in kolom A beginnend in Rij 2 de namen importeren van bestanden, in dit geval foto's met .jpg extensie, met een multiselect.
De bestandsnaam lukt wel, echter ik wil voor de bestandsnaam ook de directory hebben staan zodat hier een een hyperlink van kan worden gemaakt.
Dus in de cell zou dus compleet moeten komen staan bijv: D:\Foto\Abe\001.jpg
Ik laat nu via onderstaand macro mijn bestandsnamen ophalen en deze vervolgens in de sheet weg te schrijven (met dank aan Rudy in een eerder bericht op dit forum")
Sub ToonBestanden()
Const ROW_START = 1
Const COL_START = 1
Dim fdFilePicker As FileDialog
Dim oFSO As Object
Dim oSheet As Worksheet
Dim vntSelectedItem As Variant
Dim iRow As Integer
On Error GoTo ErrH
Set fdFilePicker = Application.FileDialog(msoFileDialogFilePicker)
With fdFilePicker
.Filters.Clear
.Title = "Selecteer bestanden"
.Filters.Add "Alle bestanden (*.*)", "*.*"
.AllowMultiSelect = True
'Toon de filepicker
If .Show Then
'Creëer FileSystemObject
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oSheet = ThisWorkbook.Sheets(1)
'Loop door de geselecteerde bestanden
For Each vntSelectedItem In .SelectedItems
If oSheet.Cells(ROW_START, COL_START) = vbNullString Then
oSheet.Cells(ROW_START, COL_START) = "Bestandsnaam"
oSheet.Cells(ROW_START + 1, COL_START) = oFSO.GetBasename(vntSelectedItem)
Else
iRow = oSheet.Cells(ROW_START, COL_START).End(xlDown).Row + 1
oSheet.Cells(iRow, COL_START) = oFSO.GetBasename(vntSelectedItem)
End If
Next vntSelectedItem
oSheet.Columns(COL_START).AutoFit
End If
End With
CleanUp:
'Opruim-acties
Set oFSO = Nothing
Exit Sub
ErrH:
MsgBox Err.Description & vbCr & "(Err.Number: " & Err.Number & ")", vbExclamation
Resume CleanUp
End Sub
Voor deze bestandsnaam moet dus ook alleen nog de gehele directory komen te staan.
Wie o wie kan mij helpen.
ik wil het volgende voor elkaar krijgen wat me tot nu toe niet lukt.
ik wil in een excel sheet zeg in kolom A beginnend in Rij 2 de namen importeren van bestanden, in dit geval foto's met .jpg extensie, met een multiselect.
De bestandsnaam lukt wel, echter ik wil voor de bestandsnaam ook de directory hebben staan zodat hier een een hyperlink van kan worden gemaakt.
Dus in de cell zou dus compleet moeten komen staan bijv: D:\Foto\Abe\001.jpg
Ik laat nu via onderstaand macro mijn bestandsnamen ophalen en deze vervolgens in de sheet weg te schrijven (met dank aan Rudy in een eerder bericht op dit forum")
Sub ToonBestanden()
Const ROW_START = 1
Const COL_START = 1
Dim fdFilePicker As FileDialog
Dim oFSO As Object
Dim oSheet As Worksheet
Dim vntSelectedItem As Variant
Dim iRow As Integer
On Error GoTo ErrH
Set fdFilePicker = Application.FileDialog(msoFileDialogFilePicker)
With fdFilePicker
.Filters.Clear
.Title = "Selecteer bestanden"
.Filters.Add "Alle bestanden (*.*)", "*.*"
.AllowMultiSelect = True
'Toon de filepicker
If .Show Then
'Creëer FileSystemObject
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oSheet = ThisWorkbook.Sheets(1)
'Loop door de geselecteerde bestanden
For Each vntSelectedItem In .SelectedItems
If oSheet.Cells(ROW_START, COL_START) = vbNullString Then
oSheet.Cells(ROW_START, COL_START) = "Bestandsnaam"
oSheet.Cells(ROW_START + 1, COL_START) = oFSO.GetBasename(vntSelectedItem)
Else
iRow = oSheet.Cells(ROW_START, COL_START).End(xlDown).Row + 1
oSheet.Cells(iRow, COL_START) = oFSO.GetBasename(vntSelectedItem)
End If
Next vntSelectedItem
oSheet.Columns(COL_START).AutoFit
End If
End With
CleanUp:
'Opruim-acties
Set oFSO = Nothing
Exit Sub
ErrH:
MsgBox Err.Description & vbCr & "(Err.Number: " & Err.Number & ")", vbExclamation
Resume CleanUp
End Sub
Voor deze bestandsnaam moet dus ook alleen nog de gehele directory komen te staan.
Wie o wie kan mij helpen.
