Attribute VB_Name = "Gestion_Ecriture_v121"
'----------------------------------------------------------------------------------------
' Procédure_____: Gestion_Ecriture
' Date__________: 08/07/2023
' Auteur________: www.CapLSS.com - https://www.caplss.com/viewtopic.php?t=273
' Objet_________: Ne permet la modification que par un utilisateur
' Référence_____: Fonction d'Initialisation
' Appel_________: Automatique à l'ouverture et fermeture (auto_open, auto_close)
' Appel_________: Gestion_Ecriture_Open (Opt. PasdInfo)
' Appel_________: Gestion_Ecriture_Close (Opt. PasdInfo)
' Appel_________: /!\ Nécessite : Exploser
' Appel_________: /!\ Nécessite : Imploser
' Appel_________: /!\ Nécessite : Nom_Utilisateur_Reseau
' Retour________: -1 en cas de levée d'une alerte, 0 sinon
' Options_______: Si PasdInfo := true, pas de message d'information
' Compatibilité_: (2003-2019)Office     (11.0-16.0)Excel     (+)32-bit     (+)64-bit
' Statut________: (x)Validé ()En attente validation ()En cours développement
'----------------------------------------------------------------------------------------
' 2021.03.19 v1.00 DEV Création initiale, renomme les fichiers pendant l'écriture
' 2022.01.28 v1.10 DEV Force le fichier original a être ouvert en lecture seule par défaut
'                  DEV Amélioration et simplification de la gestion des noms avec Imploser et Exploser
'                  DEV Gestion des alertes en mode muet possible
' 2022.09.07 v1.11 DEV Ajout de l'événement Workbook_SheetChange pour alerter d'une ouverture incorrecte
' 2023.02.15 v1.20 DEV Empêche l'ouverture du fichier s'il ne s'agit pas du fichier original.
' 2023.07.08 v1.21 BUG Pour certains noms du fichier, ne précise pas le nom déjà ouvert
'                  FIX Robustifie l'affichage de l'utilisateur déjà en cours d'utilisation 

Option Explicit

'+ v111 : Ce bloc est à copier dans le classeur principal : ThisWorkbook
'         Puis à décommenter (enlever les premières cotes ' de Private à End Sub)
'         Et si déjà existant, intégrer l'ancien contenu avant le End If)
' ----------------------------------------------------------------------------
'Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
'  If ThisWorkbook.ReadOnly Then
'    ' Aucune modification en lecture seule
'    ' Annule la Modif (si possible)
'    Application.EnableEvents = False
'    On Error Resume Next
'      Application.Undo
'    On Error GoTo 0
'    Application.EnableEvents = True
'    ' Informe de la tentative de modification en lecture seule
'    Call MsgBox("Attention toutes les modifications seront perdues en quittant." & Chr(13) & Chr(13) & "Quitter et réouvrir ce fichier en écriture pour le modifier !", vbCritical, "Fichier ouvert en Lecture Seule")
'  Else
'    ' Autres gestions de modifications en Ecriture si besoin ci-dessous
'    '
'  End If
'End Sub
' ----------------------------------------------------------------------------
'- v111

Sub auto_open()
    '
    ' S'exécute après Workbook.Open()
    ' -------------------------------
    ' Sécurisation du Fichier en Ecriture
    ' Avec Message d'Erreur
    Call Gestion_Ecriture_Open
    ' Sans Message d'Erreur
    ' Call Gestion_Ecriture_Open(True)
    '
End Sub

Sub auto_close()
    '
    ' S'exécute après Workbook.BeforeClose()
    ' --------------------------------------
    ' Restauration du Fichier Modifié
    ' Avec Message d'Erreur
    Call Gestion_Ecriture_Close
    ' Sans Message d'Erreur
    ' Call Gestion_Ecriture_Close(True)
    '
End Sub

Function Gestion_Ecriture_Open(Optional ByVal PasdInfo As Boolean = False) As Integer
    '
    ' Nécessite : Exploser
    ' Nécessite : Imploser
    ' Nécessite : Nom_Utilisateur_Reseau
    '
    ' Le Fichier doit être ouvert en écriture, sinon ne fait rien
    '
    Gestion_Ecriture_Open = 0
    If Not ThisWorkbook.ReadOnly Then
        ' Variables locales
        Dim LeNom, NomExt, NomArr()
        ' Fichier en écriture: <NomFichier>_LOGIN.xlsm
        NomArr = Exploser(".", ThisWorkbook.Name)
        NomExt = NomArr(UBound(NomArr))
        ReDim Preserve NomArr(UBound(NomArr) - 1)
        LeNom = Dir(ThisWorkbook.Path & "\" & Imploser(".", NomArr) & "_*." & NomExt)
        If LeNom > "" Then
          ' Erreur : Ouverture Original alors qu'une Modif est déjà en cours
          NomArr = Exploser("_", LeNom)
          If Not PasdInfo Then
            MsgBox "Une Modification est déjà en cours par : " & Chr(10) & Exploser(".", NomArr(UBound(NomArr)))(0) & Chr(10) & _
                 "Si c'est vous, vous devez renommer manuellement votre Fichier, sinon attendre que la modification soit terminée.", vbInformation, "Sortie du Fichier"
            Gestion_Ecriture_Open = -1
          End If
          ' Sortir de Force !
          Application.EnableEvents = False
          ThisWorkbook.Close SaveChanges:=False
        Else
          ' Gestion des caractères _ "normaux"
          If InStr(1, NomArr(0), "_") > 0 Then
            If Dir(ThisWorkbook.Path & "\" & Exploser("_", NomArr(0))(0) & "." & NomExt) > "" Then
              ' Erreur : Ouverture Modif déjà en cours (Fichier existe sans le dernier Caractère _)
              NomArr = Exploser("_", NomArr(0))
              MsgBox "Une Modification est déjà en cours par : " & Chr(10) & NomArr(UBound(NomArr)) & Chr(10) & _
                  "Si c'est vous, vous devez renommer manuellement votre Fichier, sinon attendre que la modification soit terminée.", vbInformation, "Sortie du Fichier"
              Gestion_Ecriture_Open = -1
              ' Sortir de Force !
              Application.EnableEvents = False
              ThisWorkbook.Close SaveChanges:=False
            End If
          End If
        End If    
        ' Fichier en lecture : <NomFichier>.xlsm
        NomArr = Exploser(".", ThisWorkbook.Name)
        If (UBound(NomArr) - LBound(NomArr)) <> 1 Then
          MsgBox "Nom de Fichier incorrect : " & Chr(10) & ThisWorkbook.Name, vbCritical
          ' Sortir de Force !
          Application.EnableEvents = False
          ThisWorkbook.Close SaveChanges:=False
        End If
        ' Renomme le Fichier et le Sauvegarde
        ActiveWorkbook.SaveAs Filename:= _
        ThisWorkbook.Path & "\" & NomArr(LBound(NomArr)) & "_" & Nom_Utilisateur_Reseau() & "." & NomExt, FileFormat _
        :=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
    End If
    '
End Function

Function Gestion_Ecriture_Close(Optional ByVal PasdInfo As Boolean = False) As Integer
    '
    ' Nécessite : Exploser
    ' Nécessite : Imploser
    ' Nécessite : Nom_Utilisateur_Reseau
    '
    Gestion_Ecriture_Close = 0
    If ThisWorkbook.ReadOnly Then
      ' Pas de demande de sauvegarde, et quitte
      ThisWorkbook.Saved = True
      '
    Else
      ' Lecture seule recommandée par défaut
      If Not ThisWorkbook.ReadOnlyRecommended Then
        ThisWorkbook.ReadOnlyRecommended = True
      End If
        ' Variables locales
        Dim NomKil, NomArr(), NomExt, NomUR
        NomArr = Exploser(".", ThisWorkbook.Name)
        NomExt = NomArr(UBound(NomArr))
        NomArr = Exploser("_", ThisWorkbook.Name)
        ReDim Preserve NomArr(UBound(NomArr) - 1)
        NomUR = Nom_Utilisateur_Reseau()
        ' Genérique pour supprimer des extensions éventuelles dans l'appli (ex. 001.tmp, .ini)
        NomKil = Imploser("_", NomArr) & "_" & NomUR & "*.*"
        ' Sauvegarde (écrase celui en lecture seule)
        Application.DisplayAlerts = False
        ActiveWorkbook.SaveAs Filename:= _
          ThisWorkbook.Path & "\" & Imploser("_", NomArr) & "." & NomExt, FileFormat _
            :=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
        Application.DisplayAlerts = True
        ' Essaie de Supprimer le Fichier de Modification libéré
        On Error Resume Next
          Kill ThisWorkbook.Path & "\" & NomKil
        On Error GoTo 0
        ' Gestion de la suppression non réussie !?
        If Dir(ThisWorkbook.Path & "\" & NomKil) > "" Then
          If Not PasdInfo Then
            MsgBox "La suppression automatique impossible de : " & Chr(10) & NomKil & Chr(10) & Chr(10) & _
                 "Il vous faudra les supprimer manuellement.", vbInformation, "Nettoyage Impossible"
            Gestion_Ecriture_Close = -1
          End If
        End If
    End If
    '
End Function