Problème de sauvegarde

Version imprimable

1 pièce(s) jointe(s)

Hello le forum

J'ai un petit problème de sauvegarde, la validation de l'enregistrement ne se fait quand je clique sur le bouton Enregistrer. La boîte de dialogue apparaît une seconde fois et là si je reclique sur Enregistrer, l'enregistrement s'effectue.

Spécificités de l'enregistrement :

1) Le répertoire de destination est prédéfini dans les macros.

2) La sauvegarde est forcée au format XLSM.

3) Le classeur d'origine est au format modèle XLTM

Voici mon code :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
 
 
Public Repertoire As String
Public Sous_Rep_1 As String
 
---------------------
 
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
 
Sauve
 
Cancel = True
 
End Sub
 
---------------------
 
Sub Sauve()
 
Repertoire = "C:\Users\Olivier\Documents\Mon_Repertoire"
Sous_Rep_1 = "C:\Users\Olivier\Documents\Mon_Repertoire\Mon_Sous_Repertoire"
Dim Enregistrement As Office.FileDialog
 
 
Creation_Repertoire Repertoire
 
Set Enregistrement = Application.FileDialog(msoFileDialogSaveAs)
With Enregistrement
    Enregistrement.Title = "Veuillez enregistrer votre fichier au format XLSM !"
    Enregistrement.InitialFileName = Sous_Rep_1 & "\"
    Enregistrement.InitialFileName = "toto-fichier"
    Enregistrement.FilterIndex = 2
    Enregistrement.AllowMultiSelect = False
    Enregistrement.ButtonName = "Sauvez au format &XLSM"
    Enregistrement.Show
 
    If .SelectedItems.Count = 1 Then
        On Error Resume Next
 
        ' si  ces deux codes ne sont pas présents, aucun enregistrement
        ActiveWorkbook.SaveAs Filename:=.SelectedItems(1)
        Enregistrement.Execute
 
    Else
        Exit Sub
    End If
 
End With
 
 
Set Enregistrement = Nothing
 
Application.EnableEvents = False
 
 
End Sub
 
---------------------
 
Sub Creation_Repertoire(Repertoire As String)
 
If Dir(Repertoire, vbDirectory) = "" Then
    MkDir Repertoire
End If
 
If Dir(Sous_Rep_1, vbDirectory) = "" Then
    MkDir Sous_Rep_1
End If
 
End Sub

Je joint le fichier au format ZIP car le format XLSM ou XLTM n'est pas supporté.

:) Merci à tous ceux qui pourront m'aider a ce que l'enregistrement se fasse normalement :)

Bonjour,

Essaie comme ça (j'ai mis les macros que j'ai modifiées; remets tes répertoires) :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
 
Cancel = True
 
Sauve
 
End Sub
 
 
Sub Sauve()
 
Repertoire = "C:\Users\Daniel\Documents\Donnees\Daniel\mpfe"
Sous_Rep_1 = "C:\Users\Daniel\Documents\Donnees\Daniel\mpfe"
Dim Enregistrement As Office.FileDialog
 
 
Creation_Repertoire Repertoire
 
Application.EnableEvents = False
Set Enregistrement = Application.FileDialog(msoFileDialogSaveAs)
With Enregistrement
    Enregistrement.Title = "Veuillez enregistrer votre fichier au format XLSM !"
    Enregistrement.InitialFileName = Sous_Rep_1 & "\"
    Enregistrement.InitialFileName = "toto-fichier"
    Enregistrement.FilterIndex = 2
    Enregistrement.AllowMultiSelect = False
    Enregistrement.ButtonName = "Sauvez au format &XLSM"
    Enregistrement.Show
 
    If .SelectedItems.Count = 1 Then
        On Error Resume Next
 
        ' si  ces deux codes ne sont pas présents, aucun enregistrement
        Application.EnableEvents = False
        ActiveWorkbook.SaveAs Filename:=.SelectedItems(1)
 
        Enregistrement.Execute
        Application.EnableEvents = True
    End If
 
End With
 
 
Set Enregistrement = Nothing
Application.EnableEvents = True
 
 
End Sub

:P Salut Daniel, Hello le forum :P

Un grand merci pour ta contribution.

En fait, les instructions

Application.EnableEvents = False

Application.EnableEvents = True

manquaient dans ma procédure.

Un petit truc en passant, il ne faut pas "sucrer" le "Else - Exit Sub"" car si l'utilisateur clique sur Annuler, au prochain clic sur Enregistrer,la sauvegarde se fait par défaut au format XLSX (sans prise en charge des macros)

Voici les 3 macros qui fonctionnent (testé 10x)

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
 
 
Public Repertoire As String
Public Sous_Rep_1 As String
 
----------------
 
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
 
Sauve
 
Cancel = True
 
End Sub
 
----------------
 
Sub Sauve()
 
Repertoire = "C:\Users\Olivier\Documents\Mon_Repertoire"
Sous_Rep_1 = "C:\Users\Olivier\Documents\Mon_Repertoire\Mon_Sous_Repertoire"
Dim Enregistrement As Office.FileDialog
Dim Mon_Fichier As String
 
Creation_Repertoire Repertoire
 
Set Enregistrement = Application.FileDialog(msoFileDialogSaveAs)
 
With Enregistrement
    Enregistrement.Title = "Veuillez enregistrer votre fichier au format XLSM !"
    Enregistrement.InitialFileName = Sous_Rep_1 & "\"
    Enregistrement.InitialFileName = "toto-fichier"
    Enregistrement.FilterIndex = 2
    Enregistrement.AllowMultiSelect = False
    Enregistrement.ButtonName = "Sauvez au format &XLSM"
    Enregistrement.Show
 
    If .SelectedItems.Count = 1 Then
        On Error Resume Next
        Application.EnableEvents = False
        Enregistrement.Execute
        Application.EnableEvents = True
    Else
        Exit Sub
    End If
 
End With
 
Set Enregistrement = Nothing
 
Application.EnableEvents = False
 
End Sub
 
----------------
 
Sub Creation_Repertoire(Repertoire As String)
 
If Dir(Repertoire, vbDirectory) = "" Then
    MkDir Repertoire
End If
 
If Dir(Sous_Rep_1, vbDirectory) = "" Then
    MkDir Sous_Rep_1
End If
 
End Sub

Encore merci et A++++