Folderpath Edit VBA

[arnelgp]

here is the code.
run sub Test (it will only display the filename).
i included the function that test If the file is open (you need to call it on each collection.item)

Public Sub RecursiveDir(ByRef colFiles As Collection, _
                             ByVal strFolder As String, _
                             ByVal strFileSpec As String, _
                             Optional ByVal bIncludeSubfolders As Boolean = False)

    Dim strTemp As String
    Dim colFolders As New Collection
    Dim vFolderName As Variant

    On Error Resume Next
    'Add files in strFolder matching strFileSpec to colFiles
    strFolder = TrailingSlash(strFolder)
    strTemp = Dir(strFolder & strFileSpec)
    Do While strTemp <> vbNullString
        colFiles.Add strFolder & strTemp
        strTemp = Dir
    Loop

    If bIncludeSubfolders Then
        'Fill colFolders with list of subdirectories of strFolder
        strTemp = Dir(strFolder, vbDirectory)
        Do While strTemp <> vbNullString
            If (strTemp <> ".") And (strTemp <> "..") Then
                If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then
                    colFolders.Add strTemp
                End If
            End If
            strTemp = Dir
        Loop

        'Call RecursiveDir for each subfolder in colFolders
        For Each vFolderName In colFolders
            Call RecursiveDir(colFiles, strFolder & vFolderName, strFileSpec, True)
        Next vFolderName
    End If

End Sub


Private Function TrailingSlash(strFolder As String) As String
    If Len(strFolder) > 0 Then
        If right(strFolder, 1) = "\" Then
            TrailingSlash = strFolder
        Else
            TrailingSlash = strFolder & "\"
        End If
    End If
End Function

' https://exceloffthegrid.com/vba-find-file-already-open/
Function IsFileOpen(fileName As String)

Dim fileNum As Integer
Dim errNum As Integer

'Allow all errors to happen
On Error Resume Next
fileNum = FreeFile()

'Try to open and close the file for input.
'Errors mean the file is already open
Open fileName For Input Lock Read As #fileNum
Close fileNum

'Get the error number
errNum = Err

'Do not allow errors to happen
On Error GoTo 0

'Check the Error Number
Select Case errNum

    'errNum = 0 means no errors, therefore file closed
    Case 0
    IsFileOpen = False
 
    'errNum = 70 means the file is already open
    Case 70
    IsFileOpen = True

    'Something else went wrong
    Case Else
    IsFileOpen = errNum

End Select

End Function


Private Sub TEST()
Dim c As New Collection
Dim i As Long
Call RecursiveDir(c, "d:\", "*.*", True)
For i = 1 To c.count
    Debug.Print c(i)
Next
End Sub

 

[Oreynolds]

here is the code.
run sub Test (it will only display the filename).
i included the function that test If the file is open (you need to call it on each collection.item)

Public Sub RecursiveDir(ByRef colFiles As Collection, _
                             ByVal strFolder As String, _
                             ByVal strFileSpec As String, _
                             Optional ByVal bIncludeSubfolders As Boolean = False)

    Dim strTemp As String
    Dim colFolders As New Collection
    Dim vFolderName As Variant

    On Error Resume Next
    'Add files in strFolder matching strFileSpec to colFiles
    strFolder = TrailingSlash(strFolder)
    strTemp = Dir(strFolder & strFileSpec)
    Do While strTemp <> vbNullString
        colFiles.Add strFolder & strTemp
        strTemp = Dir
    Loop

    If bIncludeSubfolders Then
        'Fill colFolders with list of subdirectories of strFolder
        strTemp = Dir(strFolder, vbDirectory)
        Do While strTemp <> vbNullString
            If (strTemp <> ".") And (strTemp <> "..") Then
                If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then
                    colFolders.Add strTemp
                End If
            End If
            strTemp = Dir
        Loop

        'Call RecursiveDir for each subfolder in colFolders
        For Each vFolderName In colFolders
            Call RecursiveDir(colFiles, strFolder & vFolderName, strFileSpec, True)
        Next vFolderName
    End If

End Sub


Private Function TrailingSlash(strFolder As String) As String
    If Len(strFolder) > 0 Then
        If right(strFolder, 1) = "\" Then
            TrailingSlash = strFolder
        Else
            TrailingSlash = strFolder & "\"
        End If
    End If
End Function

' https://exceloffthegrid.com/vba-find-file-already-open/
Function IsFileOpen(fileName As String)

Dim fileNum As Integer
Dim errNum As Integer

'Allow all errors to happen
On Error Resume Next
fileNum = FreeFile()

'Try to open and close the file for input.
'Errors mean the file is already open
Open fileName For Input Lock Read As #fileNum
Close fileNum

'Get the error number
errNum = Err

'Do not allow errors to happen
On Error GoTo 0

'Check the Error Number
Select Case errNum

    'errNum = 0 means no errors, therefore file closed
    Case 0
    IsFileOpen = False

    'errNum = 70 means the file is already open
    Case 70
    IsFileOpen = True

    'Something else went wrong
    Case Else
    IsFileOpen = errNum

End Select

End Function


Private Sub TEST()
Dim c As New Collection
Dim i As Long
Call RecursiveDir(c, "d:\", "*.*", True)
For i = 1 To c.count
    Debug.Print c(i)
Next
End Sub

Wow, brilliant thanks, so I assume that I add in the IsFileOpen call where the debug.print is? Like this?

Private Sub TEST_Click()
Dim c As New Collection
Dim i As Long
Call RecursiveDir(c, "F:\SFA 2021\Running projects\SSE Contracting Ltd\J32944 Centenary House Crawley (WSCC)\", "*.*", True)
For i = 1 To c.Count
    Debug.Print c(i)
    Call IsFileOpen(c(i))
Next
End Sub

 

[Oreynolds]

OK, again thanks for your help so far. Unfortunately I have hit another problem which I think is a bit above me! I have got to the stage where I have been testing on some small limited chunks of live data.

What I have found is this scenario which occurs about 10% of the time when I call the the function below fncRenameFolder:

Information:
FolderA - Name never changes
FolderB - Name never changes
FolderC - Is a CustomerName and the user could change this
FolderD - Is a SiteName and the user could change this

So what I have found is that in 10% of the cases:

Original Folderpath (foldername) = F:\FolderA\FolderB\FolderC\FolderD\
Required new Folderpath (foldernamenew) = F:\FolderA\FolderB\FolderCBD\FolderDEF\

BUT!!! In 10% of cases the Folderpath "F:\FolderA\FolderB\FolderCBD\" already exists so in instances where this occurs understandably the system fails to change foldername to foldernamenew.

The only way around this I can think of would be that where this situation occurs that the code would need to either move the 'FolderD' to the new location "F:\FolderA\FolderB\FolderCBD\FolderD\" and then rename it it to "F:\FolderA\FolderB\FolderCBD\FolderDEF\" or create the new foldernamenew, then copy the contents of foldername to it and remove the old or similar?

Not sure if you have any thoughts on this or a function that could be combined to achieve it? Thanks

Call fncRenameFolder(foldername, foldernamenew)


Public Function fncRenameFolder(ByVal oldFolderName As String, ByVal newFolderName As String) As Boolean
    
    Dim var1, var2
    Dim I As Integer, J As Integer, K As Integer
    Dim pi As String
    Dim po As String
    var1 = Split(oldFolderName, "\")
    var2 = Split(newFolderName, "\")
    I = UBound(var1)
    J = UBound(var2)
    If I <> J Then
        MsgBox "Unable to Rename folder, size not the same."
        Exit Function
    End If
    On Error Resume Next
    For K = I To 0 Step -1
        pi = "": po = ""
        For J = 0 To K
            pi = pi & var1(J) & "\"
            If J = K Then
                po = po & var2(J) & "\"
            Else
                po = po & var1(J) & "\"
            End If
        Next
        If K > 0 Then
            pi = Left$(pi, Len(pi) - 1)
            po = Left$(po, Len(po) - 1)
            Name pi As po
        End If
    Next
    fncRenameFolder = True
End Function