[VBA] Αποθήκευση αρχείου

[Immortal]

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

ActiveWorkbook.SaveCopyAs (“C:\Users\Immortal\Desktop\Αρχείο\Το βιβλίο μου 2024 (Για αρχείο).xlsm”)

Και να δημιουργήσω ένα νέο αντίγραφο στην επιφάνεια εργασίας αλλά όχι σε φάκελο.

 ActiveWorkbook.SaveAs (“C:\Users\Immortal\Desktop\Το βιβλίο μου 2025.xlsm”)

Μπορεί μετά από αυτά να κλείνει το ανοιχτό βιβλίο;
Μπορεί αντί για την αποθήκευση απλά στο αρχείο, να αποθηκεύεται και να μεταφέρεται εκεί;
Μπορεί μετά από όλα αυτά να ανοίγει το νέο βιβλίο 2025;

Επίσης, εάν το βιβλίο χρησιμοποιηθεί σε άλλον υπολογιστή και χρειαστεί να γίνει αυτή η διαδικασία, θα πρέπει να αλλαχθούν τα paths εξ αρχής από εμενα ή υπάρχει κάτι γενικό που καθορίζει την επιφάνεια εργασίας για τους υπολογιστές;

Αρκετές οι ερωτήσεις μου κ σας ευχαριστώ προκαταβολικά!

[Tasos]

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

Νικο, ας υποθέσουμε ότι το τρέχον βιβλίο εργασίας (ActiveWorkbook) έχει το όνομα "Βιβλίο_1"
και το καινούργιο όνομα είναι "Βιβλίο_2".


Η συνάρτηση "ActiveWorkbook.SaveAs" αποθηκεύει το Βιβλίο_1 ως βιβλίο_2 λαμβάνοντας υπ όψη τις αλλαγές που έχουν γίνει στο Βιβλίο_1.

Έτσι, το βιβλίο_2 είναι ήδη ανοιχτό ενώ το βιβλίο Βιβλίο_1 άποδεσμεύεται (εικονικά κλείνει) από την εφαρμογή χωρίς να αποθηκευτούν οι όποιες αλλαγές έχουν γίνει.

Η συνάρτηση "ActiveWorkbook.SaveCopyAs" απλά αντιγράφει το "Βιβλίο_1" με τις αλλαγές που τυχόν υπάρχουν αλλά δεν έχουν αποθηκευτεί με το όνομα "Βιβλίο_2" ενώ το "Βιβλίο_1" παραμένει ανοιχτό.

Ελπίζω να βοήθησα.

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

Τάσος

[ChrisGT7]

Καλησπέρα σας και καλή εβδομάδα,

Νίκο, σε συνέχεια του μηνύματος του Τάσου, παραθέτω και ένα παράδειγμα κώδικα:

Sub APO8HKEYSH()
    Dim MyPath As String
    MyPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & Application.PathSeparator
    
    ActiveWorkbook.SaveCopyAs MyPath & _
        "Αρχείο\Το βιβλίο μου 2024 (Για αρχείο).xlsm"
    
    ActiveWorkbook.SaveAs MyPath & _
        "Το βιβλίο μου 2025.xlsm"
End Sub

Η μεταβλητή MyPath νομίζω πως απαντάει και στο ερώτημά σου για την εύρεση του φακέλου της επιφάνειας εργασίας σε άλλους υπολογιστές.

[Immortal]

Καλησπέρα σας και καλή εβδομάδα!

Τάσο σε ευχαριστώ πολύ για τος αναλυτικές και κατανοητές πληροφορίες!

Χρήστο σε ευχαριστώ κι εσένα για την πρόταση που δίνεις, θα την δοκιμάσω και θα επανέλθω!
Μια λεπτομέρεια μόνο γιατί δεν το έχω δοκιμάσει ακόμη, στο παράδειγμα που δίνεις, κατά την λειτουργία του SaveCopyAs θα πρέπει ο φάκελος Αρχείο να υπάρχει ήδη στην επιφάνεια σωστά;

[ChrisGT7]

Ναι, πρέπει να υπάρχει αλλιώς εμφανίζεται σφάλμα.

[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

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

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

Τάσος

[Immortal]

Καλή σας ημέρα!
Τάσο με σιγουριά μπορώ να σου πω πως χάθηκα με τόσα παραδείγματα και τόσες γραμμές
Δοκίμασα το τελευταίο παράδειγμα (βασιζόμενος στο ότι εάν δεν υπάρχει ο φάκελος, να δημιουργηθεί), σε module (εκεί πρέπει να μπει; Ή μέσα στο φύλλο;) και κοκκινίζει αυτό

Private Declare Function SHCreateDirectoryEx Lib "shell32" Alias "SHCreateDirectoryExA" _
             (ByVal hwnd As Long, ByVal pszPath As String, ByVal psa As Any) As Long

Να με συγχωρείτε για την ασχετοσύνη μου! Κάποια πράγματα δεν τα καταλαβαίνω καθόλου
Όπως και να έχει σας ευχαριστώ για τις προτάσεις και τον χρόνο σας!

[Tasos]

Καλημέρα Νίκο.

Οι οδηγίες #If και #End If είναι προεπεξεργαστικές οδηγίες (preprocessor directives) στη VBA.

Χρησιμοποιούνται για να ελέγξουν ποια τμήματα του κώδικα θα συμπεριληφθούν κατά τη μεταγλώττιση σε κώδικα μηχανής, ανάλογα με τις καθορισμένες συνθήκες. Αυτές οι οδηγίες δεν εκτελούνται κατά τη διάρκεια της εκτέλεσης του κώδικα, αλλά κατά τη φάση της μεταγλώττισης.

Χρήση των #If και #End If


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

Η οδηγία #Else χρησιμοποιείται για να καθορίσει εναλλακτικό μπλοκ κώδικα, αν η συνθήκη του #If είναι ψευδής.

Η οδηγία #End If χρησιμοποιείται για να δηλώσει το τέλος του μπλοκ κώδικα που ελέγχεται από το #If.

Παράδειγμα

Ας δούμε ένα παράδειγμα για να κατανοήσουμε καλύτερα τη χρήση αυτών των οδηγιών:

#If VBA7 Then  
   ' Αν  η έκδοση Office είναι 64 bit (VBA7) τότε
   
    Private Declare PtrSafe Function SHCreateDirectoryEx _
             Lib "shell32" Alias "SHCreateDirectoryExW" _
             (ByVal hwnd As LongPtr, ByVal pszPath As LongPtr, ByVal psa As Any) As Long

#Else 
    'Αν  η έκδοση Office είναι 32 bit (VBA6) τότε

    Private Declare Function SHCreateDirectoryEx Lib "shell32" Alias "SHCreateDirectoryExA" _
             (ByVal hwnd As Long, ByVal pszPath As String, ByVal psa As Any) As Long
              ' Η σουίτα Office που χρησιμοποιείς είναι 64 Bit.


#End If 

Η μια από τις δύο συναρτήσεις ανάλογα την έκδοση Microsoft Office Θεωρείται από τον VBE άκυρη και γι αυτό την "κοκκινίζει".

Αυτό δε σημαίνει ότι είναι σφάλμα αφού θα αγνοηθεί κατά τη φάση της μεταγλώττισης.

Προτείνω να βάλεις όλο τον κώδικα εκτός το Sub Test() σε μια λειτουργική μονάδα (Module) και το Sub Test() όπου χρειαστεί.

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

Τάσος

[Immortal]

Καλησπέρα!
Τάσο έχω τοποθετήσει τον κώδικα σύμφωνα με τις οδηγίες σου!
Όταν τον τρέχω δημιουργεί τον φάκελο Αρχείο, αλλά δεν αποθηκεύει το αρχείο κάπου, ούτε με το παλιό όνομα ούτε με το νέο

[Immortal]

Αρχική Δημοσίευση από ChrisGT7

Sub APO8HKEYSH()
    Dim MyPath As String
    MyPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & Application.PathSeparator
    
    ActiveWorkbook.SaveCopyAs MyPath & _
        "Αρχείο\Το βιβλίο μου 2024 (Για αρχείο).xlsm"
    
    ActiveWorkbook.SaveAs MyPath & _
        "Το βιβλίο μου 2025.xlsm"
End Sub

Χρήστο καλησπέρα! Υπάρχει περίπτωση στα Save που έχω κοκκινίσει το 2024 και το 2025, να έρχonται από ένα κελί το οποίο έχω ονομάσει LastYear για το 2024 και NextYear για το 2025;