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