Bonsoir,

Je ne trouve pas comment sauver une copie de mon fichier avec "ActiveWorkbook.SaveCopyAs" en lecture seule avec mot de passe pour l'écriture

Le but et d'éviter l'erreur d'enregistrement lorsqu'un autre utilisateur à la copie ouverte

Merci pour votre aide

Je deviens fou ...... le code "FileFormat:=xlOpenXMLWorkbookMacroEnabled ...... " ne fonctionne pas avec ActiveWorkbook.SaveCopyAs

Ce code fonctionne avec ActiveWorkbook.SaveAs
Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
   ActiveWorkbook.SaveAs Filename:=CheminPublic & "Copie du " & MonFichier, _
       Password:="", WriteResPassword:="2017", ReadOnlyRecommended:=False, _
       CreateBackup:=False
Mais ne fonctionne pas avec ActiveWorkbook.SaveCopyAs
Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
   ActiveWorkbook.SaveCopyAs Filename:=CheminPublic & "Copie du " & MonFichier, _
       Password:="", WriteResPassword:="2017", ReadOnlyRecommended:=False, _
        CreateBackup:=False
Le code de mon fichier
Code : Sélectionner tout - Visualiser dans une fenêtre à part
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
Option Explicit
'Sauvegarde une copie du fichier nommé: Date & la date, dans un dossier, dans le même dossier du fichier, nommé: Backup & le nom du fichier + une copie en lecture seule sur le disque public
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
 
Dim Chemin As String
Dim CheminSource As String
Dim CheminBackup As String
Dim DossierBackup As String
Dim CheminPublic As String
Dim MonFichier As String
Dim Mdp As String
 
Mdp = "CHUV"
 
'Username de l'utilisateur en majuscule
Dim Nom As String
Dim NomMajuscule As String
    Nom = Environ("USERNAME")
    NomMajuscule = UCase(Nom) 'UCase = Mise en majuscule - LCase = minuscule - Application.proper = Nom propre
 
 
    DossierBackup = "Backup " & Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 5) 'Pour enlever le .xlsm les 5 caractères depuis la droite
    CheminSource = ThisWorkbook.Path & "\" & DossierBackup & "\"
 
'Test si le dossier existe déjà
On Error Resume Next 'N'éxécute pas la ligne qui suit en cas d'erreur
       MkDir CheminSource
On Error GoTo 0 'Ressort de l'erreur qui permet de nouvelles erreurs
 
    Chemin = CheminSource
 
        'Sauvegarde d'une copie du fichier avec la date
        ActiveWorkbook.SaveCopyAs Chemin & Format(Now(), "YYYY.MM.DD hh-mm-ss ") & NomMajuscule & " " & ThisWorkbook.Name
 
            CheminPublic = "C:\Users\Philippe\Documents\"
 
'Copie du fichier sur le public
        MonFichier = ThisWorkbook.Name
On Error GoTo MessageErreur
 
        ActiveWorkbook.SaveCopyAs CheminPublic & "Copie du " & MonFichier
 
Exit Sub
 
MessageErreur:
        MsgBox _
                vbCrLf & _
                "!!! ATTENTION !!!" & _
                vbCrLf & vbCrLf & _
                "La copie du fichier n'a pas été sauvegardée sur : " & _
                vbLf & _
                CheminPublic & "" & _
                vbCrLf & vbCrLf & "Vérifier :" & vbCrLf & _
                "- Que le réseau soit accessible " & _
                vbCrLf & _
                "- Que le fichier ne soit pas ouvert par un autre utilisateur" _
                , vbExclamation, "! Oups !"
 
End Sub