[Résolu] Macro par Macro

[Lebonetletruand]

Bonjour,

Une petite question. Est-il possible de créer une macro dans un nouveau classeur depuis une macro?

L'intérêt est le suivant : A l'aide d'une macro, je crée un nouveau classeur. Dans la macro de création de ce classeur je souhaiterais affecter une macro à ce nouveau classeur, à savoir, quitter Excel en évitant le message "Voulez-vous enregistrer..., oui non annuler" car la sauvegarde de ce fichier est prévue automatiquement dans la macro de création et l'utilisateur ne pourra pas modifier ce nouveau classeur (c'est un classeur de consultation).

Quelqu'un pourrait-il m'aider à solutionner ce problème.

Merci pas avance

 

[Softmama]

Re : Macro par Macro

Bonsoir,

il se fait tard et n'ai pas testé. Mais à priori, ce code résoud ta demande :

Sub go()
    'Nécéssite d'activer la référence
    '"Microsoft Visual basic For Application Extensibility 5.3"
    Dim Wb As Workbook
    Dim X As Integer
    Workbooks.Add
    
    'Définit le classeur cible
    ActiveWorkbook.SaveAs "toto.xls"
    Set Wb = Workbooks("toto.xls")
    
    With Wb.VBProject.VBComponents("ThisWorkbook").CodeModule
        X = .CountOfLines
        .InsertLines X + 1, "Private Sub Workbook_BeforeClose(Cancel As Boolean)"
        .InsertLines X + 2, "ThisWorkbook.Close(True)"
        .InsertLines X + 3, "End Sub"
    End With
End Sub

 

[Lebonetletruand]

Re : Macro par Macro

Je vais tester cette solution, merci pour la rapidité de ta réponse

Je te tiens au courant

 

[Lebonetletruand]

Re : Macro par Macro

J'ai testé ton application, elle fonctionne très bien

Tu m'as même résolu un problème d' Erreur '9 à cette occasion...

Merci beaucoup Softmama

 

[MJ13]

Re : Macro par Macro

Bonjopur LBLT, Softmama


Déjà merci Softmama pour ton code.

Mais il y a quelque chose qui me dérange.

Si je le lance la macro avec un stop, cela fonctionne mais si je le met à la suite d'une macro, cela ne fonctionne pas.

Merci pour l'aide .

J'ai testé ton code comme ceci:

Sub Ajoute_Code_Ins_img_Ouvrir()
    'Nécéssite d'activer la référence
    '"Microsoft Visual basic For Application Extensibility 5.3"
    Dim Wb As Workbook
    Dim X, iajcode As Integer
    'Workbooks.Add
    'Stop
    'Définit le classeur cible
   ' ActiveWorkbook.SaveAs "toto.xls"
    'Set Wb = Workbooks("toto.xls")
    Set Wb = ActiveWorkbook
    'Normalment la première fauille a déjà des code donc sur les 2 feuilles, on place le code pour ouvrir sur click droit (normalment la feuille 2 doit être supprimée après incorporation d'images)
    MsgBox ActiveWorkbook.Sheets.Count
    For iajcode = 2 To ActiveWorkbook.Sheets.Count
        'With Wb.VBProject.VBComponents("Feuil8").CodeModule
        MsgBox Sheets(iajcode).Name
        MsgBox Sheets(iajcode).CodeName
        
        With Wb.VBProject.VBComponents(Sheets(iajcode).CodeName).CodeModule
        'X = .CountOfLines
        '.InsertLines X + 1, "Private Sub Workbook_BeforeClose(Cancel As Boolean)"
        '.InsertLines X + 2, "ThisWorkbook.Close(True)"
        '.InsertLines X + 3, "End Sub"
        .InsertLines X + 1, "Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)"
.InsertLines X + 2, "Cancel = True"
.InsertLines X + 3, "'Stop"
.InsertLines X + 4, "Dim NF As String"
.InsertLines X + 5, "On Error Resume Next"
.InsertLines X + 6, "'Adapter le Nom du fichier (NF) au nom du dossier et du fichier"
.InsertLines X + 7, "NF = ActiveCell.Offset(0, -ActiveCell.Column + 1) &" & Chr(34) & "\" & Chr(34) & "& ActiveCell"
'on fait en 2 fois pour que cela soit plusfacile, on teste sur la prmière partie puis en suite sur le reste
'.InsertLines X + 8, "If Mid(ActiveCell, 2, 1) = ":" Then Shell "explorer /e,," & ActiveCell & "", vbMaximizedFocus"
'.InsertLines X + 8, "If Mid(ActiveCell, 2, 1) = " & Chr(34) & ":" & Chr(34) & " Then Shell " & Chr(34) & "explorer /e,," & Chr(34)
.InsertLines X + 8, "If Mid(ActiveCell, 2, 1) = " & Chr(34) & ":" & Chr(34) & " Then Shell " & Chr(34) & "explorer /e,," & Chr(34) & " & ActiveCell & " & Chr(34) & Chr(34) & ", vbMaximizedFocus" ' & chr(34)"
.InsertLines X + 9, " 'Stop"
.InsertLines X + 10, "If Mid(ActiveCell, Len(ActiveCell) - 4, 2) = " & Chr(34) & "xl" & Chr(34) & " Or Mid(ActiveCell, Len(ActiveCell) - 3, 2) = " & Chr(34) & "xl" & Chr(34) & "Then Workbooks.Open Filename:=NF Else ThisWorkbook.FollowHyperlink NF"
.InsertLines X + 11, " End Sub"
'pour coder les ", remplacer par chr(34) lorsqu'il y en a dans le code et " pour concaténer
'"If Mid(ActiveCell, 2, 1) = " & chr(34) & ":"&chr(34) & " Then Shell " & chr(34) & "explorer /e,," &chr(34)  & " & ActiveCell & " & chr(34() &chr(34) & ", vbMaximizedFocus & chr(34)
    End With

 

[MJ13]

Re : Macro par Macro

Re

Bon, j'ai trouvé la solution:

Il faut metre activeworkbook dans la ligne:

With Wb.VBProject.VBComponents(activeworkbook.Sheets(iajcode).CodeName).CodeModule

Ah ces objets!

Et merci encore, Softmama, car ce code comme par hasard, j'en avais besoin aujourdhui . Allez c'était fait exprès .

 

[Softmama]

Re : Macro par Macro

Bonsoir à vous,

Heureux que ce code ait pu vous être utile