Application.Run error 1004, problem trying to run a macro from another workbook

72 Views Asked by At

I have a database that looks at .bas and .frm files in a folder. It compares them to a reference workbook to check if the export date has changed, and allows to import newer version of the code. This allows me to have an add-in with only the database code and have a shared folder that everyone can contribute to and update existing macros. So there is the current active workbook which can change, there's the add-in named "BDD_SOCITEC.xlam" that is running the sub, and there's wb which is the reference workbook that contains every macros and to which the sub export/import macros and that is stored in a shared network.

The module has a prefixe to define it's function so M_ = macro, UF_ = UserForm, F_ = Function but the macro it self doesnt have that prefix that's why you'll see weird manipulation of the variable selectedmacro being tried.

My problem is with Application.Run, i'm trying to run the code chosen by the user on the userform but i tried every syntax possible and it always gives me the same excecution error saying the macro isnt available or macros are deactivated.

Here's the complete code :

   
Option Explicit

Public objFSO As Object
Public objFiles As Object
Public selectedmacro As String
Public cancel As Boolean
    
'// Constantes //
Const macroDir As String = "C:\Users\cdenis\Desktop\Mettre sur réseau\Base de données\Export Macro\"
Const dirBDD As String = "N:\Bureau d'études\OrganisationTechnique\Base de données macros\Base de données macros.xlsm"
Const NameCol As String = "B"
Const DateCol As String = "F"
Const FunctionCol As String = "C"


Public Sub BDD()
    
    '// Initialisation //
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objFiles = objFSO.GetFolder(macroDir).Files
    Dim objFile As Object
    Dim foundCell As Range
    Dim fileLastModified As Date
    
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim currentwb As Workbook
    Dim currentws As Worksheet
    
    Set wb = Workbooks.Open(dirBDD)
    Set ws = wb.Sheets(1)
    
    ws.Activate
    
    cancel = False
    selectedmacro = ""
    UF_BDD.basList.Clear
    
    ' Boucle pour rechercher les fichiers .bas dans le dossier
    For Each objFile In objFiles
        If objFile.Name Like "*.bas" Then
            Dim basFileName As String
            basFileName = Left(objFile.Name, Len(objFile.Name) - 4) 'Retirer ".bas"
            
            ' Vérifier si le fichier .bas correspond à un module existant
            If Not ModuleExists(basFileName, wb) Then
                ' Inviter l'utilisateur à importer le nouveau module
                Dim response As VbMsgBoxResult
                response = MsgBox("Le module '" & basFileName & "' n'existe pas. Voulez-vous l'importer au fichier base de données macros ?", vbQuestion + vbOKCancel, "Importer le module")
                
                If response = vbOK Then
                    ' Importer le nouveau module
                    wb.VBProject.VBComponents.Import objFile.Path
                    UF_BDD.basList.AddItem basFileName
                End If
            Else
                ' Le module existe, l'ajouter à la liste
                UF_BDD.basList.AddItem basFileName
                
                ' Vérifier si une mise à jour est nécessaire
                If ModuleNeedsUpdate(basFileName, objFile, foundCell, ws, fileLastModified) Then
                    ' Prompt l'utilisateur pour mettre à jour le fichier
                    Dim updateResponse As VbMsgBoxResult
                    updateResponse = MsgBox("Il existe une version du fichier '" & basFileName & "' plus récente. Voulez-vous la mettre à jour ?", vbQuestion + vbYesNo, "Mettre à jour le module")
                    
                    If updateResponse = vbYes Then
                    
                        If ws.Cells(foundCell.Row, FunctionCol).Value = "Macro + UserForm" Then 'Vérifier si la macro à besoin d'une userform
                            Dim userFormDir As String
                            userFormDir = macroDir & "\UserForm\"
                            
                            Dim fileName As String
                            fileName = dir(userFormDir & "*.frm*") ' Récupère tout les fichiers avec une extensions "."
                            
                            Do While fileName <> "" ' Boucle pour trouver l'userform associé
                                ' Vérifier si le nom du module s'associe avec le nom des fichiers
                                If UCase(fileName) = UCase("UF_" & Right(basFileName, Len(basFileName) - 2) & ".frm") Then
                                    ' Supprimer l'ancienne version
                                    On Error Resume Next
                                    wb.VBProject.VBComponents.Remove wb.VBProject.VBComponents(Left(fileName, Len(fileName) - 2))
                                    On Error GoTo 0
                                                
                                    ' Importer la nouvelle version
                                    wb.VBProject.VBComponents.Import userFormDir & fileName
                                End If
                                'Passer au fichier suivant
                                fileName = dir
                            Loop
                        End If
                        
                        'Changer la date dans le fichier base de données macros
                        ws.Cells(foundCell.Row, DateCol).Value = fileLastModified
                         
                        ' Supprimer l'ancienne version
                        On Error Resume Next
                        wb.VBProject.VBComponents.Remove wb.VBProject.VBComponents(basFileName)
                        On Error GoTo 0
                        
                        ' Importer la nouvelle version
                        wb.VBProject.VBComponents.Import objFile.Path
                    End If
                End If
            End If
        End If
    Next objFile
    
    ' Centrer l'UserForm
    UF_BDD.StartUpPosition = 0 ' Centrer la fenêtre
    UF_BDD.Width = 245 ' Définir la taille de la fenètre
    UF_BDD.Height = 250
    UF_BDD.Left = Application.Left + (0.5 * Application.Width) - (0.5 * UF_BDD.Width)
    UF_BDD.Top = Application.Top + (0.5 * Application.Height) - (0.5 * UF_BDD.Height)
    UF_BDD.Show ' Ouvrir la fenêtre
    
    ' Sortir de la macro quand on appuie sur "cancel"
    If cancel = True Then
        Exit Sub
    End If
    
    ' Exécuter la macro
    If UF_BDD.ouvrir = True Then
        On Error Resume Next
        Application.Run "'" & wb.FullName & "'!" & selectedmacro & "." & Right(selectedmacro, Len(selectedmacro) - 2)
        If Err.Number <> 0 Then
            MsgBox "Error: " & Err.Description
        End If
        On Error GoTo 0
    End If
End Sub
Function ModuleNeedsUpdate(basFileName As String, objFile As Object, ByRef foundCell As Range, ws As Worksheet, ByRef fileLastModified As Date) As Boolean
    ' Vérifier si la version du module est plus récente que celle dans la feuille
    Dim moduleExportDate As Date
    ' Rechercher le nom du module dans la colonne H
    Set foundCell = ws.Columns(NameCol).Find(What:=basFileName, LookIn:=xlValues, LookAt:=xlWhole)
    ModuleNeedsUpdate = False
 
    If Not foundCell Is Nothing Then
        ' Si le nom du module est trouvé, vérifier la date d'exportation dans la colonne L
        moduleExportDate = ws.Cells(foundCell.Row, DateCol).Value
        
        ' Obtenir la date de la dernière modification du fichier .bas
        fileLastModified = Left(objFile.DateLastModified, 10)
        If fileLastModified > moduleExportDate Then
            ModuleNeedsUpdate = True
        End If
    Else
        MsgBox "Nom ou date d'explortation du module " & basFileName & " introuvable."
    End If
End Function


Function ModuleExists(moduleName As String, wb As Workbook) As Boolean
    ' Vérifier si un module avec le nom spécifié existe
    Dim vbComp As Object
    For Each vbComp In wb.VBProject.VBComponents
        If vbComp.Type = 1 And vbComp.Name = moduleName Then
            ModuleExists = True
            Exit Function
        End If
    Next vbComp
    ModuleExists = False
End Function


I tried the following syntaxes :

Application.Run selectedmacro

Application.Run selectedmacro "." right(selectedmacro,len(selectedmacro-2))

wb.Application.Run selectedmacro

wb.Application.Run selectedmacro "." right(selectedmacro,len(selectedmacro-2))

Application.Run wb.Name & "'!" & selectedmacro

Application.Run wb.Name & "'!" & selectedmacro & "." & Right(selectedmacro, Len(selectedmacro) - 2)

Application.Run "'" & wb.FullName & "'!" & selectedmacro

Application.Run "'" & wb.FullName & "'!" & selectedmacro & "." & Right(selectedmacro, Len(selectedmacro) - 2)

Don't really know why it doesnt seem to work, the last syntax worked a couple times but it stopped working and i don't know why.

Here's the new version of the code, i now import and run the macros in the addin file and it seems to work now.



    Option Explicit

Public objFSO As Object
Public objFiles As Object
Public UFFSO As Object
Public UFFiles As Object
Public selectedmacro As String
Public Cancel As Boolean
    
'// Constantes //
Const macroDir As String = "N:\Bureau d'études\OrganisationTechnique\Base de données macros\Export Macro\"
Const userFormDir As String = macroDir & "UserForm\"
Const DirBDD As String = "N:\Bureau d'études\OrganisationTechnique\Base de données macros\Base de données macro.xlsm"
Const NameCol As String = "B"
Const FunctionCol As String = "C"
Const DateCol As String = "F"

Public Sub BDD()
    
    '// Initialisation //
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objFiles = objFSO.GetFolder(macroDir).Files
    Dim objFile As Object
    Set UFFSO = CreateObject("Scripting.FileSystemObject")
    Set UFFiles = objFSO.GetFolder(userFormDir).Files
    Dim UFFile As Object
    Dim foundCell As Range
    Dim fileLastModified As Date
    
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim currentwb As Workbook
    Dim currentws As Worksheet
    
    Set wb = Workbooks.Open(DirBDD)
    Set ws = wb.Sheets(1)
    
    Set currentwb = ThisWorkbook
    
    Cancel = False
    selectedmacro = ""
    UF_BDD.basList.Clear
    
    ' Boucle pour rechercher les fichiers .bas dans le dossier
    For Each objFile In objFiles
        If objFile.Name Like "*.bas" Then
            Dim basFileName As String
            basFileName = Left(objFile.Name, Len(objFile.Name) - 4) 'Retirer ".bas"
            
            ' Vérifier si le fichier .bas correspond à un module existant
            If Not ModuleExists(basFileName, wb) Then
                ' Inviter l'utilisateur à importer le nouveau module
                Dim response As VbMsgBoxResult
                response = MsgBox("Le module '" & basFileName & "' n'existe pas. Voulez-vous l'importer au fichier base de données macros ?", vbQuestion + vbOKCancel, "Importer le module")
                
                If response = vbOK Then
                    ' Importer le nouveau module
                    wb.VBProject.VBComponents.Import objFile.Path
                    UF_BDD.basList.AddItem basFileName
                End If
            Else
                ' Le module existe, l'ajouter à la liste
                UF_BDD.basList.AddItem basFileName
                
                ' Vérifier si une mise à jour est nécessaire
                If ModuleNeedsUpdate(basFileName, objFile, foundCell, ws, fileLastModified) Then
                    ' Prompt l'utilisateur pour mettre à jour le fichier
                    Dim updateResponse As VbMsgBoxResult
                    updateResponse = MsgBox("Il existe une version du fichier '" & basFileName & "' plus récente. Voulez-vous la mettre à jour ?", vbQuestion + vbYesNo, "Mettre à jour le module")
                    
                    If updateResponse = vbYes Then
                        If ws.Cells(foundCell.Row, FunctionCol).Value = "Macro + UserForm" Then 'Vérifier si la macro à besoin d'une userform
                            For Each UFFile In UFFiles
                                If UFFile.Name Like "*.frm" Then ' Boucle pour trouver l'userform associé
                                    Dim UFName As String
                                    UFName = Left(UFFile.Name, Len(UFFile.Name) - 4) 'Retirer ".frm"
                                    
                                    ' Vérifier si le nom du module s'associe avec le nom des fichiers
                                    If UCase(UFName) = UCase("UF_" & Right(UFName, Len(UFName) - 2)) Then
                                
                                        On Error Resume Next 'Enlever l'erreur si le fichier n'existe pas
                                        wb.VBProject.VBComponents.Remove wb.VBProject.VBComponents(Left(UFName, Len(UFName) - 2)) ' Supprimer l'ancienne version
                                        On Error GoTo 0
                                                    
                                        ' Importer la nouvelle version
                                        wb.VBProject.VBComponents.Import UFFile.Path
                                    End If
                                End If
                            Next UFFile
                        End If
                        
                        'Changer la date dans le fichier base de données macros
                        ws.Cells(foundCell.Row, DateCol).Value = fileLastModified
                         
                        ' Supprimer l'ancienne version
                        On Error Resume Next
                        wb.VBProject.VBComponents.Remove wb.VBProject.VBComponents(basFileName)
                        On Error GoTo 0
                        
                        ' Importer la nouvelle version
                        wb.VBProject.VBComponents.Import objFile.Path
                    End If
                End If
            End If
        End If
    Next objFile
    
    ' Centrer l'UserForm
    UF_BDD.StartUpPosition = 0 ' Centrer la fenêtre
    UF_BDD.Width = 245 ' Définir la taille de la fenètre
    UF_BDD.Height = 250
    UF_BDD.Left = Application.Left + (0.5 * Application.Width) - (0.5 * UF_BDD.Width)
    UF_BDD.Top = Application.Top + (0.5 * Application.Height) - (0.5 * UF_BDD.Height)
    UF_BDD.Show ' Ouvrir la fenêtre
    
    ' Sortir de la macro quand on appuie sur "cancel"
    If Cancel = True Then
        Exit Sub
    End If
    
    ' Exécuter la macro
    If UF_BDD.ouvrir = True Then
        On Error Resume Next
        Application.Run "'" & currentwb.FullName & "'!" & selectedmacro & "." & Right(selectedmacro, Len(selectedmacro) - 2)
        If Err.Number <> 0 Then
            MsgBox "Error: " & Err.Description
        End If
        On Error GoTo 0
    End If
End Sub
Function ModuleNeedsUpdate(basFileName As String, objFile As Object, ByRef foundCell As Range, ws As Worksheet, ByRef fileLastModified As Date) As Boolean
    ' Vérifier si la version du module est plus récente que celle dans la feuille
    Dim moduleExportDate As Date
    ' Rechercher le nom du module dans la colonne H
    Set foundCell = ws.Columns(NameCol).Find(What:=basFileName, LookIn:=xlValues, LookAt:=xlWhole)
    ModuleNeedsUpdate = False
 
    If Not foundCell Is Nothing Then
        If ws.Cells(foundCell.Row, DateCol).NumberFormat = "m/d/yyyy" Then 'Vérifier si la cellule est bien sous format Date
            ' Si le nom du module est trouvé, vérifier la date d'exportation dans la colonne L
            moduleExportDate = ws.Cells(foundCell.Row, DateCol).Value
            
            ' Obtenir la date de la dernière modification du fichier .bas
            fileLastModified = Left(objFile.DateLastModified, 10)
            If fileLastModified > moduleExportDate Then
                ModuleNeedsUpdate = True
            End If
        Else
            MsgBox basFileName & " n'a pas une date d'export valide entrée."
            ModuleNeedsUpdate = False
        End If
    Else
        MsgBox "Nom ou date d'explortation du module " & basFileName & " introuvable."
    End If
End Function


Function ModuleExists(moduleName As String, wb As Workbook) As Boolean
    ' Vérifier si un module avec le nom spécifié existe
    Dim vbComp As Object
    For Each vbComp In wb.VBProject.VBComponents
        If vbComp.Type = 1 And vbComp.Name = moduleName Then
            ModuleExists = True
            Exit Function
        End If
    Next vbComp
    ModuleExists = False
End Function
    
0

There are 0 best solutions below