'Activer MS VBA Extensibitity x.x au préalable
Sub zyva()
Dim nf%, fbas$, f$
Dim wb As Workbook
Dim VBProj As VBIDE.VBProject, CodeMod As VBIDE.CodeModule
Dim i&
Rep = "J:\Trames\"
fbas = Rep & "ModuleArpette.bas"
If Dir(fbas) <> "" Then Kill fbas
nf = FreeFile 'crée le fichier .bas
Open fbas For Output Access Write As #nf
Print #nf, "Attribute VB_Name = ""NewModule"""
Print #nf, "Sub Demarrer()"
Print #nf, "Dim DateDepart As Date"
Print #nf, "Dim J%, m$, Number%, bx&"
Print #nf, "If MsgBox(""Veux-tu changer la date"", vbYesNo)=vbNo then exit sub"
Print #nf, "J = VBA.Day(VBA.Date)"
Print #nf, "ActiveSheet.Cells(45, 9) = Format(Date, ""dd-mmmm-yyyy"")"
Print #nf, "DateDepart = DateSerial(Year(Date), Month(Date) + 12, J)"
Print #nf, "ActiveSheet.Cells(46, 23) = Format(DateDepart, ""dd-mmmm-yyyy"")"
Print #nf, "Sheets(""Page 1"").Select"
Print #nf, "Cells(35, 11).Select"
Print #nf, "End Sub"
Close nf
Application.ScreenUpdating = False
Application.EnableEvents = False
f = Dir(Rep & "*.xls")
Do While f <> "" 'boucle sur les fichiers du répertoire
If f <> ThisWorkbook.Name Then
Set wb = Workbooks.Open(Rep & f)
Set VBProj = wb.VBProject
With VBProj
.VBComponents.Import fbas 'importe le fichier .bas dans un module standard
Set CodeMod = VBProj.VBComponents("ThisWorkbook").CodeModule
With CodeMod
.DeleteLines 1, .CountOfLines 'supprime les lignes dans thisworkbook
i = .CreateEventProc("Open", "Workbook")
.InsertLines i + 1, "Demarrer" 'ajoute la procédure dans thisworkbook
End With
On Error GoTo 0
Set VBProj = Nothing
Set CodeMod = Nothing
End With
wb.Close True
End If
f = Dir()
Loop
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub