'Find My VBA - www.xlExe.com - Tous droits réservés modifié et adaapté par Michel Bertauche
'ATTENTION de bien valider les référzences Microsoft Scriptime runtime et Mocrosof forms 2.0 Object Library
Public Chaine As String
Public Cellule_De_Depart, Valeur_De_Depart, Formule_De_Depart, Nouvelle_Valeur, Nouvelle_Formule As Variant

Function sc(ByRef maChaine As String) As String ' Revoie uniquement la valeur de la colonne sans les "$"
Set rationelleExp = CreateObject("vbscript.regexp")
rationelleExp.Global = True
rationelleExp.Pattern = "[a-zA-Z]"
Set trouve = rationelleExp.Execute(maChaine)
For i = 0 To trouve.Count - 1
sc = sc & trouve(i)
Next i
End Function

Sub Calcul_Valeur(C, f, v As Variant)
Cellule_De_Depart = C
Valeur_De_Depart = v
Formule_De_Depart = f
End Sub

Sub Calcul_Nouvelle_Valeur(n, f As Variant)
Nouvelle_Valeur = n
Nouvelle_Formule = f
End Sub

Sub ShowFileInfo(filespec)
Dim fs, f
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFile(filespec)
Date_Fich = "Fichier crée le: " & f.DateCreated
End Sub

Sub StokerVariable() 'Réinitialisation de la variable à 0 pour voir le module "Info" à l'ouverture
Dim Lavariable As Variant
Lavariable = 0
Names.Add "MaVar", Lavariable, False ' Définir un nom masqué
End Sub

Sub RécupérerVariable() ' Pour info
Lavariable = [MaVar]
MsgBox Lavariable
End Sub

Function EnregistrerAction(ActionNom As String)
On Error GoTo Fin

Dim CheminCompletFichierJournal As String
Dim ContenuEnregistrement As String
Dim Chemin, Repertoire, Mes As String
Dim Feuille As String
Dim Fichier As String

Fichier = ThisWorkbook.Name
Feuille = ActiveWorkbook.ActiveSheet.Name
Chemin = ActiveWorkbook.Path
Repertoire = "Log"
ActionMoment = Now

'vérification si le dossier "Log" existe dans le patch

If Len(Dir(ObtenirCheminBureau & "/" & Repertoire, vbDirectory)) = 0 Then
Call CreerNouveauDossier(ObtenirCheminBureau & "/" & Repertoire)
' ----------------------------------------------------------------
End If
NomFichierJournal = "Suivi du fichier {" & ActiveWorkbook.Name & "}" & ".txt"
'NomFichierJournal = "Suivi du fichier " & ActiveWorkbook.Name & ".txt"
CheminCompletFichierJournal = ObtenirCheminBureau & "\" & Repertoire & "\" & NomFichierJournal

If ActionNom = "Sauvegarde du Classeur" Then
YearActionMoment = Format(ActionMoment, "dddd d mmmm yyyy")
ContenuEnregistrement = YearActionMoment & " " _
& "à " & Right("0" & Hour(ActionMoment), 2) & "h " & Right("0" _
& Minute(ActionMoment), 2) & ":" _
& Right("0" & Second(ActionMoment), 2) & " par " _
& Environ("UserName") & " sauvegarde du classeur" & " " & """" & Fichier & """" & " " & "Chenim = : " & Chemin
GoTo Suite
End If

If ActionNom = "Ouverture du Classeur" Then

YearActionMoment = Format(ActionMoment, Mes & vbCrLf & "dddd d mmmm yyyy")
ContenuEnregistrement = YearActionMoment & " " _
& "à " & Right("0" & Hour(ActionMoment), 2) & "h " & Right("0" _
& Minute(ActionMoment), 2) & ":" & Right("0" & Second(ActionMoment), 2) & " par " _
& Environ("UserName") & " ouverture du classeur" & " " & """" & Fichier & """" & " " & "Chenim = : " & Chemin
GoTo Suite
End If

If ActionNom = "Fermeture du Classeur" Then
YearActionMoment = Format(ActionMoment, "dddd d mmmm yyyy")
ContenuEnregistrement = YearActionMoment & " " _
& "à " & Right("0" & Hour(ActionMoment), 2) & "h " _
& Right("0" & Minute(ActionMoment), 2) & ":" & Right("0" & Second(ActionMoment), 2) & " par " _
& Environ("UserName") & " fermeture du classeur" & " " & """" & Fichier & """" & " " & "Chenim = : " & Chemin
GoTo Suite
End If
If Valeur_De_Depart = "" Then Valeur_De_Depart = """cellule vide"""
If Formule_De_Depart = "" Then Formule_De_Depart = """cellule vide"""
If Nouvelle_Valeur = "" Then Nouvelle_Valeur = """cellule vide""" '
If Nouvelle_Formule = "" Then Nouvelle_Formule = """cellule vide"""
YearActionMoment = Format(ActionMoment, "dddd d mmmm yyyy")
ContenuEnregistrement = YearActionMoment & " " _
& "sur la feuille " & """" & Feuille & """" _
& " à " & Right("0" & Hour(ActionMoment), 2) & "h " & Right("0" & Minute(ActionMoment), 2) & ":" _
& Right("0" & Second(ActionMoment), 2) & " par " & Environ("UserName") _
& " " & ActionNom & " ancienne valeur: " & Valeur_De_Depart & " ;" & " nouvelle valeur: " _
& Nouvelle_Valeur & " ; " & "ancienne formule: " & Formule_De_Depart & " ; " & "nouvelle formule: " & Nouvelle_Formule
Suite:
'vérifier si le fichier journal existe déjà & enregistrer l'information
VerificationFichierJournal = Len(Dir(CheminCompletFichierJournal))
If VerificationFichierJournal = 0 Then
's'il n'existe pas encore -> créer un nouveau
LogResult = SauvegarderChaineCommeFichierTexte(ContenuEnregistrement, CheminCompletFichierJournal)
Else
's'il existe -> ajouter la nouvelle ligne
LogResult = AjouterAuFichierTexte(ContenuEnregistrement, CheminCompletFichierJournal)
End If
Fin: Exit Function
End Function

'Public Date_Fich, Nouv_Fich As String
Public Function AjouterAuFichierTexte(ContenuAAjouter As String, CheminFichier As String)
Dim oFSO As FileSystemObject
Set oFSO = New FileSystemObject
Dim oFS As TextStream
Set oFS = oFSO.OpenTextFile(CheminFichier, ForAppending)
oFS.WriteLine ContenuAAjouter
oFS.Close
Set oFS = Nothing
Set oFSO = Nothing
End Function

Public Function SauvegarderChaineCommeFichierTexte(Contenu As String, CheminFichier As String)
Dim Chemin, Fic, CheminFich As String
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim oFile As Object
Set oFile = fso.CreateTextFile(CheminFichier)
' Récuperer la date et l'heure de creation du fichier qui vient d'etre crée
Chemin = ThisWorkbook.Path & "\" & "Log" & "\"
Fic = Dir(Chemin)
CheminFich = Chemin & Fic
Date_Fich = FileDateTime(CheminFich)
Mes = "Fichier du log crée le: " & Date_Fich & vbCrLf
oFile.WriteLine Mes & Contenu
oFile.Close
Set fso = Nothing
Set oFile = Nothing
End Function

Public Function ObtenirCheminBureau() As String
On Error GoTo ObtenirCheminBureauError
Dim CheminBureau As String
CheminBureau = ""
Dim oWSHShell As Object
Set oWSHShell = CreateObject("WScript.Shell")
CheminBureau = ThisWorkbook.Path
If (Not (oWSHShell Is Nothing)) Then Set oWSHShell = Nothing
ObtenirCheminBureau = CheminBureau
Exit Function
ObtenirCheminBureauError:
If (Not (oWSHShell Is Nothing)) Then Set oWSHShell = Nothing
ObtenirCheminBureau = ""
End Function

Public Function CreerNouveauDossier(NouveauChemin As String)
On Error GoTo CreerNouveauDossierError
MkDir (NouveauChemin)
Exit Function
CreerNouveauDossierError:
End Function

Sub ImportTxt()
Dim FichierTxt
FichierTxt = ThisWorkbook.Path & "\" & "Log" & "\" & "Suivi du fichier {log.xlsm}.txt"
'MsgBox FichierTxt

'FichierTxt = Application.GetOpenFilename("Text Files (*.txt), *.txt")
If FichierTxt <> False Then
With Worksheets("Feuil2")
.UsedRange.ClearContents
With .QueryTables.Add(Connection:="TEXT;" & FichierTxt & "", Destination:=.Range("A1"))
.TextFileSemicolonDelimiter = True
.Refresh BackgroundQuery:=False
.Delete
End With
End With
End If
Worksheets("feuil2").Activate
End Sub