[VBA] Save AVEC macro par défaut sur un modèle Excel

Bonjour à tous.

J'ai crée des petits outils Excel automatisé par macro. Pour ne pas que l'utilisateur écrase la version vierge du classeur, j'ai envoyé à mes collaborateurs le raccourci des outils sous format "Modèle Excel prenant en charge les macros"

Me voila face à un problème que je n'avais pas anticipé:

Au moment de sauver le modèle le classeur, le format par défaut est "Classeur Excel"

Et quelques utilisateurs ne lisent pas le message d'avertissement et enregistre donc l'outil sans macro....

J'aimerais que par défaut le Type de fichier soit .xlsm tout en gardant la possibilité de changer si nécessaire.

Je sais que on peux changer le type par défaut dans les options Excel mais ici pas d'intérêt car c'est partagé sur d'autre PC.

D'avance merci pour vos idées !

Salut Gabin,

Peux-tu essayer comme ceci :

'MODULE THISWORKBOOK DU CLASSEUR MODELE
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
'FileType = "Excel Macro-Enabled Workbook (*.xlsm), *.xlsm, Excel Workbook (*.xlsx), *.xlsx" '<<< directement
tTypes = Array("Excel Macro-Enabled Workbook (*.xlsm), *.xlsm", _
                "Excel Workbook (*.xlsx), *.xlsx", _
                "Excel Workbook (*.xls), *.xls")
FileType = Join(tTypes, ", ") 'en joignant la liste des extensions désirées
If ThisWorkbook.Path = "" Then
    Cancel = True
    spath = Environ("userprofile") & "\Downloads\MonSuperClasseur.xlsm"
    spath = Application.GetSaveAsFilename(spath, FileType)
End If
End Sub

A plus,

Salut 3GB,

Merci de t'as participation.

Je n'ai aucun message d'erreur mais au moment de sauvegarder rien ne se passe. La sauvegarde n'est pas faite et mon document est tjrs considéré comme un modèle Excel.

A+

J'ai modifié le code comme suit:

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
If InStr(Right(ActiveWorkbook.Name, 5), ".xl") <= 0 Then
    'FileType = "Excel Macro-Enabled Workbook (*.xlsm), *.xlsm, Excel Workbook (*.xlsx), *.xlsx" '<<< directement
    tTypes = Array("Excel Macro-Enabled Workbook (*.xlsm), *.xlsm", _
                    "Excel Workbook (*.xlsx), *.xlsx", _
                    "Excel Workbook (*.xls), *.xls")
    FileType = Join(tTypes, ", ") 'en joignant la liste des extensions désirées
    If ThisWorkbook.Path = "" Then
        Cancel = True
        spath = Environ("userprofile") & "\Documents\" & Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 5) & ".xlsm"
        spath = Application.GetSaveAsFilename(spath, FileType)
    End If
End If
End Sub

Pour que cela ne se déclenche plus lorsque le fichier n'est plus un modèle Excel.

Re,

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
If InStr(Right(ActiveWorkbook.Name, 5), ".xl") <= 0 Then
'
' Arguments : nomClasseur         [in]  Nom du classeur (sans extension)
'             strChemin           [in]  Chemin de destination (répertoire)
'
' 18/02/15    Patrice33740        V1-1-00  Création
'
Dim dlgSaveAs As FileDialog        'Boite de dialogue Office
Dim ext As String                  'Extension du classeur
Dim msg As String                  'Message pour boite de dialogue
Dim formule As String              'Formule de calcul
Dim rép As Integer                 'Réponse boite de dialogue
Dim idx As Integer                 'Index

  ext = ".xlsm"
  nomClasseur = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 5) & ".xlsm"
  'Proposer l'enregistrement du classeur
  Set dlgSaveAs = Application.FileDialog(msoFileDialogSaveAs)
  With dlgSaveAs
    ' nom du classeur
    If strChemin = "" Then
      .InitialFileName = ThisWorkbook.Path & "\" & nomClasseur
    Else
      .InitialFileName = strChemin & "\" & nomClasseur
    End If
    ' filtrer sur l'extension *.xls
    For idx = 1 To .Filters.Count
      If .Filters(idx).Extensions = "*" & ext Then
        .FilterIndex = idx
        Exit For
      End If
    Next idx
  End With
    ' afficher la boite de dialogue Enregistrer sous
    If dlgSaveAs.Show = 0 Then Exit Sub
    ' vérifier le nom du classeur
    formule = StrReverse(dlgSaveAs.SelectedItems.Item(1))
    formule = StrReverse(Mid(formule, 1, InStr(1, formule & "\", "\") - 1))
  Application.ScreenUpdating = False
  On Error GoTo ErrorHandler
  Application.DisplayAlerts = False
  Application.EnableEvents = False
  dlgSaveAs.Execute
  Application.EnableEvents = True
  Application.DisplayAlerts = True
  On Error GoTo 0
  Application.ScreenUpdating = True

Exit Sub

ErrorHandler:          'Routine de gestion d'erreur.
Select Case Err.Number
  Case 1004
    'Le classeur est déjà ouvert ou l'enregistrement à été annulé
    If Err.Description = "La méthode 'SaveAs' de l'objet '_Workbook' a échoué" Then
      Resume Next
    Else
      MsgBox "L'enregistrement à échoué :" & vbCr & vbCr & Err.Description, vbInformation
      Resume Next
    End If
  Case Else
    MsgBox Err.Description, vbCritical
    Stop
    Resume Next
End Select
End If
End Sub

J'ai poursuivit mes recherches et j'ai trouvé ce code sur l'internet de Patrice33740. Cependant, il demande a l'utilisateur de sauvegarder 2 fois, une fois dans le code, puis une fois a la fin de l'exécution (car après tout on a demandé un Save à Excel)

Salut Gabin,

Ah mince, le fichier n'est pas enregistré ? Je t'avoue que je me suis concentré sur la boite de dialogue et pas sur le sort du fichier...

Je referai un essai quand j'aurai un peu de temps.

Sinon, tu peux essayer la procédure de Patrice33740 en l'appelant dans la procédure beforesave :

'MODULE THISWORKBOOK DU CLASSEUR MODELE
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
If ThisWorkbook.Path = "" Then
    Cancel = True
    ProposerEnregistrement "MonSuperClasseur"
End If
End Sub

Public Sub ProposerEnregistrement(nomClasseur As String, Optional strChemin As String = "", Optional ext as string = ".xlsm")
' Propose l'enregistrement d'un classeur
'
' Arguments : nomClasseur         [in]  Nom du classeur (sans extension)
'             strChemin           [in]  Chemin de destination (répertoire)
'
' 18/02/15    Patrice33740        V1-1-00  Création
'
Dim dlgSaveAs As FileDialog        'Boite de dialogue Office
Dim msg As String                  'Message pour boite de dialogue
Dim formule As String              'Formule de calcul
Dim rép As Integer                 'Réponse boite de dialogue
Dim idx As Integer                 'Index

  nomClasseur = nomClasseur & ext
  'Proposer l'enregistrement du classeur
  Set dlgSaveAs = Application.FileDialog(msoFileDialogSaveAs)
  With dlgSaveAs
    ' nom du classeur
    If strChemin = "" Then
      .InitialFileName = environ("userprofile") & "\Documents\" & nomClasseur
    Else
      .InitialFileName = strChemin & "\" & nomClasseur
    End If
    ' filtrer sur l'extension *.xls
    For idx = 1 To .Filters.Count
      If .Filters(idx).Extensions = "*" & ext Then
        .FilterIndex = idx
        Exit For
      End If
    Next idx
  End With
  Do
    ' afficher la boite de dialogue Enregistrer sous
    If dlgSaveAs.Show = 0 Then Exit Sub
    ' vérifier le nom du classeur
    formule = StrReverse(dlgSaveAs.SelectedItems.Item(1))
    formule = StrReverse(Mid(formule, 1, InStr(1, formule & "\", "\") - 1))
    If formule <> nomClasseur Then
      msg = "Confirmer le remplacement du nom normalement prévu : " & vbCr & _
            "«" & nomClasseur & "»" & vbCr & _
            "par le nom qui vient d'être saisi :" & vbCr & _
            "«" & formule & "»"
      rép = MsgBox(msg, vbExclamation + vbOKCancel)
      If rép = vbOK Then nomClasseur = formule
    End If
  Loop While formule <> nomClasseur
  'Enregistrer
  Application.ScreenUpdating = False
  On Error GoTo ErrorHandler
  Application.DisplayAlerts = False
  Application.EnableEvents = False
  dlgSaveAs.Execute
  Application.EnableEvents = True
  Application.DisplayAlerts = True
  On Error GoTo 0
  Application.ScreenUpdating = True

Exit Sub

ErrorHandler:          'Routine de gestion d'erreur.
Select Case Err.Number
  Case 1004
    'Le classeur est déjà ouvert ou l'enregistrement à été annulé
    If Err.Description = "La méthode 'SaveAs' de l'objet '_Workbook' a échoué" Then
      Resume Next
    Else
      MsgBox "L'enregistrement à échoué :" & vbCr & vbCr & Err.Description, vbInformation
      Resume Next
    End If
  Case Else
    MsgBox Err.Description, vbCritical
    Stop
    Resume Next
End Select

End Sub

Cdlt,

Sinon, j'ai testé ce code qui semble fonctionner :

'MODULE THISWORKBOOK DU CLASSEUR MODELE
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
tTypes = Array("Excel Macro-Enabled Workbook (*.xlsm), *.xlsm", _
                "Excel Workbook (*.xlsx), *.xlsx", _
                "Excel Workbook (*.xls), *.xls")
tExtens = Array("xlsm", "xlsx", "xls")
tFormat = Array(52, 51, 43)
FileType = Join(tTypes, ", ") 'en joignant la liste des extensions désirées
If ThisWorkbook.Path = "" Then
    Cancel = True
    spath = Environ("userprofile") & "\Downloads\MonSuperClasseur.xlsm"
    spath = Application.GetSaveAsFilename(spath, FileType)
    If spath <> False Then
        extension = Split(spath, ".")(1)
        n = MATCH(extension, tExtens)
        Application.EnableEvents = False
        ThisWorkbook.SaveAs spath, tFormat(n)
        Application.EnableEvents = True
    End If
End If
End Sub

Function MATCH(vcherchee, tbl) As Long
MATCH = -1
For i = LBound(tbl) To UBound(tbl)
    If tbl(i) = vcherchee Then MATCH = i: Exit Function
Next i
End Function

Cdlt,

Bonjour 3GB merci du temps accordé à me répondre.

Les deux codes répondent parfaitement au cahier des charges !

Cependant, le code de Patrice que tu à adapté permet d'accéder à tout les types de fichier dans la boite de dialogue juste en sélectionnant par défaut .XLSM

Je vais donc opter pour celui ci

Merci, bon Lundi !