excelvbanetwork-programmingdirectoryuserform

Create folders and sub folders on a network drive vs a mapped drive


I am trying to set up a VBA that checks for existing and then creates standardised project folders based on inputs into a user form. I have it working fully but only on the mapped drive address rather than the network address. When i Have the network address set up I get an error:

Run-time error '52':

Bad file name or number

Here is my code:

'-------- CREATE FOLDERS --------'
Dim strPath  As String
Dim lCtr     As Long
Dim FilePath As String
Dim FileName As String

FilePath = \\Net.work\file\path\Parent\
FileName = Child

'Create INPUTs'
strPath = FilePath & FileName & "\INPUTS"

arrpath = Split(strPath, "\")
strPath = arrpath(LBound(arrpath)) & "\"

    For lCtr = LBound(arrpath) + 1 To UBound(arrpath)
        strPath = strPath & arrpath(lCtr) & "\"
        If Dir(strPath, vbDirectory) = "" Then
            MkDir strPath
        End If
    Next

Whereas if FilePath is R:\Parent\ then it runs fine, only issue is I have a few users and no guarantee it will be mapped to R for everyone.


Solution

  • This works for me: it steps backwards over the path until it hits an existing folder, then goes forward and creates the path from that point.

    Sub Tester()
        EnsureFolderPath "\\yourServer\folderA\folderB\ABC\DEF\GHI\KLM"
    End Sub
    
    
    Sub EnsureFolderPath(ByVal folderPath As String)
        
        Dim pth As String, parts As New Collection, pos As Long, f As String
        Dim i As Long
        
        pth = folderPath
        If Right(pth, 1) <> "\" Then pth = pth & "\" 'ensure ending "\"
        
        Do While Not FolderExists(pth)
            pos = InStrRev(pth, "\", Len(pth) - 1) 'find 2nd to last "\" in path
            If pos = 0 Then 'something is wrong with the supplied path...
                MsgBox "Path? " & vbLf & folderPath
                Exit Sub
            End If
            parts.Add Right(pth, Len(pth) - pos) 'save component to create later
            pth = Left(pth, pos) 'remove the saved part
        Loop
        If parts.Count > 0 Then 'any folders to create?
            For i = parts.Count To 1 Step -1 'looping from last to first
                pth = pth & parts(i)
                Debug.Print "Creating: " & pth
                MkDir pth
            Next i
        End If
    End Sub
    
    'does `p` refer to an existing folder?
    Function FolderExists(p As String) As Boolean
        On Error Resume Next
        FolderExists = ((GetAttr(p) And vbDirectory) = vbDirectory)
    End Function