VBA Tools

Często spotykam się z tym pytaniem- to tez postanowiłem opublikować na stronie kod, dzięki którym można pobrać nazwy plików określonego w zmiennej katalogu.

Każda z komórek (począwszy od zaznaczonego miejsca, będzie posiadała nazwę pliku z hiperlinkiem:

Sub Wstawianie_plikow_z_hiperlinkami()
'MVP OShon from VBATools.pl
Dim Buf$, sciezka$, pli$, x&: x = 0
 sciezka = "c:\Temp"
 If Right$(sciezka, 1) <> "\" Then sciezka = sciezka & "\"
 Buf = Dir(sciezka)
 With Application
 .ScreenUpdating = False
 Do While Len(Buf)
 With .ActiveCell
 Cells(.Row + x, .Column).Value = Buf
 ActiveSheet.Hyperlinks.Add Anchor:=Cells(.Row + x, .Column), _
 Address:=sciezka & Buf, TextToDisplay:=Cells(.Row + x, .Column).Value
 End With
 x = x + 1
 Buf = Dir
 Loop
 .ScreenUpdating = True
 End With
 MsgBox "Pobrano " & x & " pików.", vbInformation, " VBATools.pl"
End Sub

A jak by wyglądał kod, dzieki któremu zapiszemy pliki z katalogami?

Należało by odróżnić katalog od pliku – zapiszemy to w pierwszej kolumnie począwszy od zaznaczonej komórki:

Sub czytaj_Pliki_z_katalogami_FSO()
 Dim objFSO As Object 'Scripting.FileSystemObject
 Dim objFolder As Object 'Scripting.Folder
 Dim objFile As Object 'Scripting.File
 Dim oSf As Object 'Scripting.Subfolders
 Dim objDir As Object 'Scripting.File

 Const strFolderPAth As String = "C:\Temp\"

 Dim x&
 Set objFSO = VBA.CreateObject("Scripting.FileSystemObject")
 Set objFolder = objFSO.GetFolder(strFolderPAth)
 Set oSf = objFolder.SubFolders

 With ActiveCell
 For Each objDir In oSf
 With Cells(.Row + x, .Column)
 .value = "DIR"
 .Offset(, 1) = objDir.name
 ActiveSheet.Hyperlinks.Add Anchor:=.Offset(, 1), _
 Address:=objDir.path, TextToDisplay:=objDir.name
 x = x + 1
 End With
 Next
 For Each objFile In objFolder.Files
 With Cells(.Row + x, .Column)
 .value = "File"
 .Offset(, 1) = objFile.name
 ActiveSheet.Hyperlinks.Add Anchor:=.Offset(, 1), _
 Address:=objFile.path, TextToDisplay:=objFile.name
 x = x + 1
 End With
 Next
 End With

 Set objFSO = Nothing
 Set objFolder = Nothing
 Set oSf = Nothing
End Sub

I dalej idąc jak katalogi z plikami i podkatalogami?

Sub czytaj_Wszystkie_Pliki_z_katalogami_FSO()
 Dim objFSO As Object 'Scripting.FileSystemObject
 Dim objFolder As Object 'Scripting.Folder
 Dim objFile As Object 'Scripting.File
 Dim objDir As Object 'Scripting.File

 Const strFolderPAth As String = "C:\Temp\"

 Dim x&
 Set objFSO = VBA.CreateObject("Scripting.FileSystemObject")
 Set objFolder = objFSO.GetFolder(strFolderPAth).SubFolders

 With ActiveCell
 For Each objDir In objFolder
 With Cells(.Row + x, .Column)
 .Value = "Dir"
 .Offset(, 1) = objDir.Name
 ActiveSheet.Hyperlinks.Add Anchor:=.Offset(, 1), _
 Address:=objDir.Path, TextToDisplay:=objDir.Name
 End With
 x = x + 1
 For Each objFile In objDir.Files
 With Cells(.Row + x, .Column)
 .Value = "File"
 .Offset(, 1) = objFile.Name
 ActiveSheet.Hyperlinks.Add Anchor:=.Offset(, 1), _
 Address:=objFile.Path, TextToDisplay:=objFile.Name
 x = x + 1
 End With
 Next
 Next
 End With

 Set objFSO = Nothing
 Set objFolder = Nothing
End Sub

Tak wygląda efekt ostatniej procedury:

(c) Shon Oskar – www.VBATools.pl

Wszelkie prawa zastrzeżone. Żadna część ani całość tego artykułu nie może być powielana ani publikowana bez zgody autora.