How to define path to a folder? - excel

Question

I have code for listing folders, sub folders and filenames. I have to choose a folder by clicking the code.
How it is possible to define path? I have tried to uncomment MyPath but it didn't work.
My path: "\infra\Services\turb"
Sub ListAllFilesInAllFolders()
Dim MyPath As String, MyFolderName As String, MyFileName As String
Dim i As Integer, F As Boolean
Dim objShell As Object, objFolder As Object, AllFolders As Object, AllFiles As Object
Dim MySheet As Worksheet
On Error Resume Next
'************************
'Select folder
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, "", 0, 0)
If Not objFolder Is Nothing Then
'MyPath = "\\infra\Services\turb"
MyPath = objFolder.self.Path & "\"
Else
Exit Sub
'MyPath = "\\infra\Services\turb"
End If
Set objFolder = Nothing
Set objShell = Nothing
'************************
'List all folders
Set AllFolders = CreateObject("Scripting.Dictionary")
Set AllFiles = CreateObject("Scripting.Dictionary")
AllFolders.Add (MyPath), ""
i = 0
Do While i < AllFolders.Count
Key = AllFolders.keys
MyFolderName = Dir(Key(i), vbDirectory)
Do While MyFolderName <> ""
If MyFolderName <> "." And MyFolderName <> ".." Then
If (GetAttr(Key(i) & MyFolderName) And vbDirectory) = vbDirectory Then
AllFolders.Add (Key(i) & MyFolderName & "\"), ""
End If
End If
MyFolderName = Dir
Loop
i = i + 1
Loop
'List all files
For Each Key In AllFolders.keys
MyFileName = Dir(Key & "*.*")
'MyFileName = Dir(Key & "*.PDF") 'only PDF files
Do While MyFileName <> ""
AllFiles.Add (Key & MyFileName), ""
MyFileName = Dir
Loop
Next
'************************
'List all files in Files sheet
For Each MySheet In ThisWorkbook.Worksheets
If MySheet.Name = "Files" Then
Sheets("Files").Cells.Delete
F = True
Exit For
Else
F = False
End If
Next
If Not F Then Sheets.Add.Name = "Files"
'Sheets("Files").[A1].Resize(AllFolders.Count, 1) = WorksheetFunction.Transpose(AllFolders.keys)
Sheets("Files").[A1].Resize(AllFiles.Count, 1) = WorksheetFunction.Transpose(AllFiles.keys)
Set AllFolders = Nothing
Set AllFiles = Nothing
End Sub
---------------- EDIT ---------------------
Same path in another code that is working. This code is doing quite the same but I don't like the output of listing folders.
Option Explicit
Private iColumn As Integer
Sub TestListFolders(strPath As String, Optional bFolders As Boolean = True)
Application.ScreenUpdating = False
Cells.Delete
Range("A1").Select
iColumn = 1
' add headers
With Range("A1")
.Formula = "Folder contents: " & strPath
.Font.Bold = True
.Font.Size = 12
End With
If Right(strPath, 1) <> "\" Then
strPath = strPath & "\"
End If
ListFolders strPath, bFolders
Application.ScreenUpdating = True
End Sub
ListFolders:
Sub ListFolders(SourceFolderName As String, IncludeSubfolders As Boolean)
' lists information about the folders in SourceFolder
' example: ListFolders "C:\", True
Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder
Dim r As Long
Dim strfile As String
Set FSO = New Scripting.FileSystemObject
Set SourceFolder = FSO.GetFolder(SourceFolderName)
'line added by dr for repeated "Permission Denied" errors
On Error Resume Next
iColumn = iColumn + 1
' display folder properties
ActiveCell.Offset(1).Select
With Cells(ActiveCell.Row, iColumn)
.Formula = SourceFolder.Name
.Font.ColorIndex = 11
.Font.Bold = True
.Select
End With
strfile = Dir(SourceFolder.Path & "\*.*")
If strfile <> vbNullString Then
ActiveCell.Offset(0, 1).Select
Do While strfile <> vbNullString
ActiveCell.Offset(1).Select
ActiveCell.Value = strfile
strfile = Dir
Loop
ActiveCell.Offset(0, -1).Select
End If
Cells(r, 0).Formula = SourceFolder.Name
Cells(r, 3).Formula = SourceFolder.Size
Cells(r, 4).Formula = SourceFolder.SubFolders.Count
Cells(r, 5).Formula = SourceFolder.Files.Count
Cells(r, 6).Formula = SourceFolder.ShortName
Cells(r, 7).Formula = SourceFolder.ShortPath
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
ListFolders SubFolder.Path, True
iColumn = iColumn - 1
Next SubFolder
Set SubFolder = Nothing
End If
Set SourceFolder = Nothing
Set FSO = Nothing
End Sub
Create new worksheet and list sub folders there:
Sub ListAllFilesTurb()
Dim WS As Worksheet
Set WS = Sheets.Add
Sheets.Add.Name = "Turb"
TestListFolders "\\infra\Services\turb"
End Sub

Answer 1

Get rid of the objFolder and objShell (and any dependent conditional code, etc.). Then you should be able to hardcode MyPath. As presently written, this code is using the objShell to browse.
Get rid of this:
'Select folder
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, "", 0, 0)
If Not objFolder Is Nothing Then
'MyPath = "\\infra\Services\turb"
MyPath = objFolder.self.Path & "\"
Else
Exit Sub
'MyPath = "\\infra\Services\turb"
End If
Set objFolder = Nothing
Set objShell = Nothing
Replace with this:
' Define hard-coded folder:
MyPath = "\\infra\Services\turb" '# Modify as needed
NOTE: It is important that the MyPath end with a backslash character, while you can hardcode that on the same line, e.g.:
MyPath = "\\infra\Services\turb\"
It may be best to add a check for it (similar to the original code) just in case you forget, so:
MyPath = "\\infra\Services\turb"
'### Ensure the path ends with a separator:
MyPath = MyPath & IIf(Right(MyPath, 1) = Application.PathSeparator, "", Application.PathSeparator)