[Tasos]

Καλημέρα σε όλους!

Ναι, όπως ανέφερε ο Χρήστος η διαδρομή πρέπει να είναι έγκυρη αλλιώς εμφανίζεται σφάλμα.

Νομίζω στα πλαίσια αυτού του θέματος μπορούμε να δώσουμε παραδειγματικούς κώδικες που επιτρέπουν την δημιουργία φακέλου αν αυτός δεν υπάρχει.


Παράδειγμα με VBA.MkDir()

Η έκφραση MkDir "C:\Temp\TestFolder" θα δημιουργήσει τον φάκελο TestFolder μόνο αν υπάρχει ο φάκελος "C:\Temp\".
Διαφορετικά θα προκληθεί σφάλμα εκτέλεσης.
Αν δεν είναι σίγουρο ότι το "C:\Temp\" υπάρχει στο σύστημα, τότε θα πρέπει να τροποποιηθεί ο κώδικας έτσι που να ελέγξει την ύπαρξη κάθε φακέλου που αναφέρεται στη διαδρομή C:\Temp\TestFolder και αν δεν υπάρχει να τον δημιουργήσει.

Sub test()
    If Dir("C:\Temp", vbDirectory) = vbNullString Then MkDir "C:\Temp"
    If Dir("C:\Temp\TestFolder", vbDirectory) = vbNullString Then MkDir "C:\Temp\TestFolder"
End Sub

Παράδειγμα με Scripting.FileSystemObject (Προσθήκη αναφοράς: Tools>References > Microsoft Scripting Runtime)

Όπως και η προηγούμενη, η έκφραση FSO.CreateFolder "C:\Temp\TestFolder" θα δημιουργήσει τον φάκελο TestFolder μόνο αν υπάρχει ο φάκελος "C:\Temp\".

Sub test()
    Dim FSO    As New Scripting.FileSystemObject
    If Not FSO.FolderExists("C:\Temp\TestFolder") Then
        FSO.CreateFolder "C:\Temp\TestFolder"
    End If
End Sub

Παράδειγμα με Windows API: MakeSureDirectoryPathExists ()

Σε διαδρομές με περισσότερα επίπεδα μπορεί να γίνει με τη χρήση της συνάρτησης MakeSureDirectoryPathExists () η οποία όμως δεν λειτουργεί αν η διαδρομή περιέχει χαρακτήρες Unicode όπως τα ελληνικά.

Επιστρέφει True αν επιτύχει και False αν προκληθεί κάποιο σφάλμα κατά την εκτέλεση της.

#If VBA7 Then
    Private Declare PtrSafe Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) _
             As LongPtr
#Else
    Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As Long
#End If

Sub test()
    Dim success      As Boolean
    success = MakeSureDirectoryPathExists("C:\Temp\TestFolder")
    MsgBox success
End Sub

Παράδειγμα με Windows API: SHCreateDirectoryEx()

Η συνάρτηση αυτή δημιουργεί όλους τους φακέλους σε διαδρομές με περισσότερα επίπεδα, λειτουργεί με χαρακτήρες Unicode και προσφέρει αρκετές πληροφορίες σε περιπτώσεις που προκληθεί σφάλμα..

Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Function SHCreateDirectoryEx _
             Lib "shell32" Alias "SHCreateDirectoryExW" _
             (ByVal hwnd As LongPtr, ByVal pszPath As LongPtr, ByVal psa As Any) As Long
#Else
    Private Declare Function SHCreateDirectoryEx Lib "shell32" Alias "SHCreateDirectoryExA" _
             (ByVal hwnd As Long, ByVal pszPath As String, ByVal psa As Any) As Long
#End If

Function MakeSureFolderPathExists(Folderpath As String) As Boolean
    Const ERROR_SUCCESS As Long = &H0             'Η δημιουργία καταλόγου ήταν επιτυχής.
    Const ERROR_ACCESS_DENIED As Long = &H5       'Δεν ήταν δυνατή η δημιουργία καταλόγου, η πρόσβαση απορρίφθηκε.
    Const ERROR_BAD_PATHNAME As Long = &HA1       'Η παράμετρος pszPath ορίστηκε ως σχετική διαδρομή.
    Const ERROR_FILENAME_EXCED_RANGE As Long = &HCE 'Η διαδρομή που υποδεικνύεται από το pszPath είναι πολύ μεγάλη.
    Const ERROR_FILE_EXISTS As Long = &H50        'Ο κατάλογος υπάρχει.
    Const ERROR_ALREADY_EXISTS As Long = &HB7     'Ο κατάλογος υπάρχει.
    Const ERROR_INVALID_NAME As Long = &H7B       'Μη έγκυρο όνομα διαδρομής.

    Dim Result As Long

    Result = SHCreateDirectoryEx(ByVal 0&, StrPtr(Folderpath), ByVal 0&)
    
    Select Case Result
        Case ERROR_SUCCESS, ERROR_FILE_EXISTS, ERROR_ALREADY_EXISTS
            MakeSureFolderPathExists = True
            
        Case ERROR_ACCESS_DENIED: ShowMessageBox "Δεν ήταν δυνατή η δημιουργία {0}. Η πρόσβαση απορρίφθηκε.", Folderpath
        Case ERROR_BAD_PATHNAME: ShowMessageBox "Δεν είναι δυνατή η χρήση σχετικής διαδρομής: {0}", Folderpath
        Case ERROR_FILENAME_EXCED_RANGE: ShowMessageBox "Η διαδρομή είναι πολύ μεγάλη: {0}", Folderpath
        Case ERROR_INVALID_NAME: ShowMessageBox "Μη έγκυρο όνομα διαδρομής: {0}", Folderpath
        Case Else: ShowMessageBox "Απρόσμενο σφάλμα {0} κατά την επαλήθευση της διαδρομής", Result
    End Select
End Function

Private Sub ShowMessageBox(strMessage As String, Var As Variant)
    MsgBox Replace(Msg, "{0}", "'" & Var & "'"), vbExclamation, "Σφάλμα"
End Sub


Sub test()
    Dim FSO    As New Scripting.FileSystemObject
    Dim success As Boolean
    Dim MainFolderpath As String
    Dim SubFolderpath As String
    Dim FilePath As String
    
    MainFolderpath = CreateObject("WScript.Shell").SpecialFolders("Desktop")
    SubFolderpath = FSO.BuildPath(MainFolderpath, "Αρχείο")
    
    success = MakeSureFolderPathExists(SubFolderpath)
    
    If success Then
        
        FilePath = FSO.BuildPath(SubFolderpath, "Το βιβλίο μου 2025.xlsm")
        
        If FSO.FileExists(FilePath) Then
            
            MsgBox "Δέν έγινε αποθήκευση. Υπάρχει ήδη ένα αρχείο με το ίδιο όνομα.......", vbExclamation, "Σφάλμα"
            
        End If
        
    Else
        'Αν δεν είναι δυνατή η δημιουργία φακέλων σε κάποιο άλλο σημείο του συστήματος.
        MsgBox "Δεν μπόρεσε να δημιουργηθεί ο φάκελος. Απαιτούνται δικαιώματα διαχειριστή......", vbExclamation, "Σφάλμα"
    End If
End Sub

Σε κάθε μια από τις παραπάνω μεθόδους θα πρέπει να ληφθεί υπόψη η εγκυρότητα της διαδρομής αλλά και η πρόσβαση στο γονικό φάκελο όπου θα δημιουργηθούν οι υποφάκελοι.

Καλή συνέχεια!

Τάσος