[Tasos]

Καλησπέρα!
Για να επιτραπεί η προγραμματιστική πρόσβαση στο μοντέλο αντικειμένου του έργου VBA

της Excel (εκεί ανήκουν οι φόρμες) πρέπει να ενεργοποιηθεί η αντίστοιχη επιλογή στις ρυθμίσεις

του κέντρου αξιοπιστίας (βλ.εικόνα).





Ο παρακάτω κώδικας αντικαθιστά φόρμα με συγκεκριμένο όνομα σε όλα τα αρχεία που περιέχουν επίσης φόρμα με το ίδιο όνομα τα οποία βρίσκονται σε φάκελο που θα ορίσει ο προγραμματιστής:

Sub TestCopyAndReplaceUserform()
    CopyAndReplaceUserform "UserForm1", ThisWorkbook.Path & "\MyFolder"
End Sub

όπου "UserForm1" = Το όνομα της φόρμας


και ThisWorkbook.Path & "\MyFolder ο φάκελος που περιέχει τα αρχεία με τις φόρμες προς αντικατάσταση.


Ο παραπάνω κώδικας καλεί την παρακάτω διαδικασία:

Sub CopyAndReplaceUserform(FormName As String, WorkbooksFolderPath As String)
    Dim vb_Component As VBComponent
    Dim FormFilename As String
    Dim msg As VbMsgBoxResult
    Dim wb As Workbook
    Dim fso As New Scripting.FileSystemObject
    Dim oFolder As Scripting.Folder
    Dim ofile As Scripting.File

    If Not fso.FolderExists(WorkbooksFolderPath) Then
        MsgBox "Ο φάκελος στη διαδρομή: '" & WorkbooksFolderPath & "' δεν βρέθηκε στο σύστημα!" _
               & vbLf & "Η διαδικασία θα διακοπεί.", vbExclamation
        Exit Sub
    End If

    msg = vbYes

    For Each vb_Component In ThisWorkbook.VBProject.VBComponents
        If vb_Component.Type = vbext_ct_MSForm Then
            If UCase(vb_Component.Name) = UCase(FormName) Then
                If Right(WorkbooksFolderPath, 1) <> "\" Then
                    WorkbooksFolderPath = WorkbooksFolderPath & "\"
                End If
                FormFilename = WorkbooksFolderPath & vb_Component.Name & ".frm"
                If Dir(FormFilename, vbDirectory) <> "" Then
                    msg = MsgBox("Tο αντικείμενο '" & FormName & "' υπάρχει ήδη." & vbLf _
                                 & "Θέλετε να αντικατασταθεί;", vbQuestion + vbYesNo)
                    If msg = vbYes Then
                        Kill FormFilename
                        Application.Wait Now + TimeSerial(0, 0, 1)
                    End If
                End If
                If msg = vbYes Then
                    vb_Component.Export FormFilename
                End If
                Exit For
            End If
        End If
    Next
    Set oFolder = fso.GetFolder(WorkbooksFolderPath)
    On Error GoTo ExitHere
    With Application
        .EnableEvents = False
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        For Each ofile In oFolder.Files
            If UCase(fso.GetExtensionName(ofile.Path)) = "XLSM" Then
                Set wb = Workbooks.Open(ofile.Path)
                For Each vb_Component In wb.VBProject.VBComponents
                    If vb_Component.Type = vbext_ct_MSForm Then
                        If UCase(vb_Component.Name) = UCase(FormName) Then
                            wb.VBProject.VBComponents.Remove vb_Component
                            .Wait Now + TimeSerial(0, 0, 1)
                            wb.VBProject.VBComponents.Import (FormFilename)
                            wb.Save
                            Exit For
                        End If
                    End If
                Next
                wb.Close False
            End If
        Next
ExitHere:
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
    If Err <> 0 Then
        MsgBox "Σφάλμα: " & Err.Number & vbLf & Err.Description, vbExclamation
    End If

End Sub

Για να λειτουργήσουν οι παραπάνω κώδικες θα πρέπει στον VBE από το μενού Tools > References να επιλεχθούν οι εξής αναφορές:


Microsoft Scripting Runtime

και

Microsoft Visual Basic for Applications Extensibility 5.0 (βλ. εικόνα)


Εάν η τελευταία δεν βρίσκεται στη λίστα, πάτησε [Browse...] και επίλεξε το αρχείο VBE6EXT.OLB

στο φάκελο Program Files (ενδεχομένως x86)\Common Files\Microsoft Shared\VBA\VBA6\




Υπάρχει σχετική βοήθεια για προγραμματιστές στη σελίδα της Microsoft: Manipulating Projects with Add-Ins


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

Τάσος