Projet Classeur Excel vérouillé ?

Signaler
Messages postés
151
Date d'inscription
lundi 16 janvier 2006
Statut
Membre
Dernière intervention
19 avril 2016
-
Messages postés
151
Date d'inscription
lundi 16 janvier 2006
Statut
Membre
Dernière intervention
19 avril 2016
-
Bonjour,
Je ne sais ce que j'ai touché dans les options, mais...
_ mes macros se sont plus "modifiable"
_ l'ouverture de VBAProject pour afficher les feuilles de code m'indique que le projet est verrouillé.
Pourquoi ? Que faire ?
Ma sénilité doit s'accroître... Merci d'avance à mes interlocuteurs; Bab

9 réponses

Messages postés
6778
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
29 mai 2020
107
Bonjour,

Tu vas dans l'éditeur:

Outils- Propriétés de VBAProject- Protection-

Tu mets ton mot de passe pour déverouiller.

Si tu ne te souviens pas du mot de passe que tu as mis, nous ne pouvons pas faire grand chose pour toi sur ce site!

Bon courage

Messages postés
6778
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
29 mai 2020
107
il faut lire deverrouiller
Messages postés
151
Date d'inscription
lundi 16 janvier 2006
Statut
Membre
Dernière intervention
19 avril 2016

Merci, Le Pivert, pour ta réponse.
Quoique mon classeur est perdu (aucune des macros n'est accessibles) même si je ne refais pas, j'aurais tout de même appris beaucoup à dialoguer avec toi et ucfoutu.
Un autre de vos collègues a participé à mon projet, mais son nom (?) est mémorisé dans mes macros perdues, merci aussi à lui, en espérant qu'il se reconnaitra.
A +, bab
Messages postés
6778
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
29 mai 2020
107
La dernière solution, c'est OpenOffice.

Mais sans certitude. Tu peux avoir accès à tes macros, il faudra faire des copier coller sur un classeur Excel. C'est du boulot!

Pour télécharger

http://www.commentcamarche.net/download/telecharger-92-openoffice
Messages postés
18038
Date d'inscription
lundi 7 décembre 2009
Statut
Modérateur
Dernière intervention
11 avril 2018
224
Bonjour, Babu,
Bon ... je vais essayer (et pense réussir) de te sortir de cette impasse.
Tu vas recevoir (dans ta messagerie privée) une adresse email (la mienne) à laquelle tu vas envoyer, en pièces jointes :
1) une copie de ton classeur enregistrée en xslm
2) une copie de ton classeur enregistrée en xsl
Tu les obtiens en faisant Fichier ==>> en registrer sous ===>> choisir le type de fichier
A plus
Messages postés
18038
Date d'inscription
lundi 7 décembre 2009
Statut
Modérateur
Dernière intervention
11 avril 2018
224
Bon ...
Je viens de me mettre volontairement dans la même impasse avec un fichier xlsm, puis ai tenté de m'en sortir en trichant allègrement.
Diverses tentatives faites avec un editeur hexadecimal (j'en espérai beaucoup) se sont traduites par un échec.
J'ai alors tenté de harponner la fenêtre demandant le mot de passe et de raconter via cette fenêtre des bobards à Excel ... ====>> waouh ... je suis sorti de l'impasse.
J'attends donc que tu me fasses parvenir par email ton classeur enregistré en .xlsm ....
Je te le retournerai immédiatement, totalement libéré de cette protection.

PS : au passage : je n'ai pas vraiment "forcé" pour violer ainsi cette protection ! Si j'y suis parvenu, il doit probablement exister des milliers de personnes qui auront la même idée. A quoi bon, alors, cette "protection" qui n'est finalement qu'un gadget (puisque violable) ?
Nonobstant, je ne contribuerai pas, en divulguant le code écrit et à partir d'où je l'ai exécuté, à fragiliser encore plus ce genre de protection.
J'attends ton xlsm.


________________________
Nul ne saurait valablement coder ce qu'il ne saurait exposer clairement.
Messages postés
18038
Date d'inscription
lundi 7 décembre 2009
Statut
Modérateur
Dernière intervention
11 avril 2018
224
Bonjour, Babudrome,
J'attends toujours ce fichier !
Je crois utile de te préciser que je n'ai écrit le code à lancer pour déverrouiller ton projet que dans le but de te rendre service.
Ce code, qui m'est personnellement inutile, encombre actuellement mon disque dur.
A défaut d'une réaction de ta part dans la semaine qui vient, je le détruirai donc.
Messages postés
151
Date d'inscription
lundi 16 janvier 2006
Statut
Membre
Dernière intervention
19 avril 2016

Merci. Je prépare l'envoi.
Absent cette derniers jours, je n'avais pas d'accès à mon PC pour répondre.
A bientôt donc... Babu
Messages postés
18038
Date d'inscription
lundi 7 décembre 2009
Statut
Modérateur
Dernière intervention
11 avril 2018
224
Bon ...
1) ton classeur n'était pas avec un projet verrouillé (procédure différente de celle envisagée), mais dans une autre situation (classeur partagé et donc avec protection particulière du projet).
2) il m'a donc fallu chercher une autre voie (scabreuse elle aussi) pour y lire ce que je devais y lire (toutes tes macros et procédures) :
Les voilà ci-après :
A/ Module1 :
 Option Explicit
Declare Function Beep Lib "kernel32.dll" (ByVal dwFreq As Long, ByVal dwDuration As Long) As Long

Public Const FeuilMain = "Mes Supports", FeuilDos = "Mes Dossiers", FeuilFic = "Mes Fichiers" ', col1 = -16776961, col2 = -1003520
Public Const NbFeuilMax = 3000, Abandon = vbCr + " Annuler ==> Abandon", Sép = "|", Gris = &HC0C0C0, Vert = &H8000&
Public Const NFic = "Mes Fichiers.TXT", NDos = "Mes Dossiers.TXT", NAide = "Mon Aide.Doc", Coma = ","
Public i%, R%, C$, Col$, Qot$, QCQ$, Colmoins1$, Caff$, LastArrêt$, Déb%, n As Double, T As Double, TbFeuil(30), iFeuil%, Classeur$, Sauvegarde$
Public CheminClasseur$, SupportMax%, FFic$, FDos$, FAide, TbDoss$(30000), iDos As Double, iDosMax As Double, LastiDos As Double, iNivoDos%
Public Vdos As Double, Vfic As Double, NivoMax%, SwPréalable As Boolean
Public Lg%, Lig%, iFicDos As Double, iFicFic As Double, Vol$(9999), ZFeuilOccupées$, ChoixDoss$, ObjCaché As Boolean ' 3ème arg=0 pour Nb de lignes
'************************************* Variables données Sons ***********************
Public Const Nsons = "Mes Sons.TXT"
Global NbSons As Byte, FSons$, SwSons As Boolean
Global DQues$(4), SonQues%(), iQues As Byte
Global DErrS$(4), SonErrS%(), iErrS As Byte
Global DFinL$(4), SonFinL%(), iFinL As Byte
Global DActi$(4), SonActi%(), iActi As Byte
Global DTest$(4), SonTest%(2, 4), iTest As Byte
'*********************************************************************
' image 8 = Patience1 : le temps de recherche des supports *
' image 3 = FinInit : fin de recherche des supports *
' image 9 = Patience2 : temps de recherche des niveaux supérieurs *
' image 4 = FinAnalyse: analyse terminéee *
' *
' image 5 = pour appel de l'aide *
'*********************************************************************
Sub image4_clic() ' clic sur l'image [ ? ]
1: ActiveWorkbook.FollowHyperlink Address:=FAide: End Sub
Sub Bip(Fréq%, Durée%)
If SwSons Then Beep Fréq, Durée
End Sub
Sub BipErreurSaisie()
Dim R As Byte: For R = 1 To iErrS: Bip SonErrS(1, R), SonErrS(2, R): Next R: End Sub
Sub BipQuestion()
Dim R As Byte: For R = 1 To iQues: Bip SonQues(1, R), SonQues(2, R): Next R: End Sub
Sub BipAction()
Dim R As Byte: For R = 1 To iActi: Bip SonActi(1, R), SonActi(2, R): Next R: End Sub
Sub BipFinLigne()
Dim R As Byte: For R = 1 To iFinL: Bip SonFinL(1, R), SonFinL(2, R): Next R: End Sub
Sub BipTest()
Dim R As Byte: For R = 1 To iTest: Bip SonTest(1, R), SonTest(2, R): Next R: End Sub
Sub LireSons()
Dim i%, x$, k%, D$, L%
Close: Open FSons For Input As #1: Input #1, x, NbSons ' lire entête titre
For i = 1 To NbSons: Input #1, x, k
If UCase(Left(x, 4)) = "QUES" Then
iQues = k: ReDim SonQues(2, k): For k = 1 To iQues: Input #1, D
L = InStr(D, "_"): If L = 0 Then info "Le document " + FSons + " est erroné !!!": End
SonQues(1, k) = Val(Left(D, L - 1)): SonQues(2, k) = Val(Mid(D, L + 1, 11)): DQues(k) = D: Next k: End If
If UCase(Left(x, 4)) = "ACTI" Then
iActi = k: ReDim SonActi(2, k): For k = 1 To iActi: Input #1, D
L = InStr(D, "_"): If L = 0 Then info "Le document " + FSons + " est erroné !!!": End
SonActi(1, k) = Val(Left(D, L - 1)): SonActi(2, k) = Val(Mid(D, L + 1, 11)): DActi(k) = D: Next k: End If
If UCase(Left(x, 4)) = "ERRS" Then
iErrS = k: ReDim SonErrS(2, k): For k = 1 To iErrS: Input #1, D
L = InStr(D, "_"): If L = 0 Then info "Le document " + FSons + " est erroné !!!": End
SonErrS(1, k) = Val(Left(D, L - 1)): SonErrS(2, k) = Val(Mid(D, L + 1, 11)): DErrS(k) = D: Next k: End If
If UCase(Left(x, 4)) = "FINL" Then
iFinL = k: ReDim SonFinL(2, k): For k = 1 To iFinL: Input #1, D
L = InStr(D, "_"): If L = 0 Then info "Le document " + FSons + " est erroné !!!": End
SonFinL(1, k) = Val(Left(D, L - 1)): SonFinL(2, k) = Val(Mid(D, L + 1, 11)): DFinL(k) = D: Next k: End If
Next i: Close: End Sub
Sub RewriteSons()
Dim x$, i%, j%: Close: Open FSons For Output As #4
Print #4, "Nombre de Sons ,4"
x = "Action ," + Trim(iActi): For i = 1 To iActi: x = x + "," + DActi(i): Next i: Print #4, x
x = "Queston ," + Trim(iQues): For i = 1 To iQues: x = x + "," + DQues(i): Next i: Print #4, x
x = "ErrSaisie ," + Trim(iErrS): For i = 1 To iErrS: x = x + "," + DErrS(i): Next i: Print #4, x
x = "FinLigne ," + Trim(iFinL): For i = 1 To iFinL: x = x + "," + DFinL(i): Next i: Print #4, x
Print #4, "": Close: End Sub


Function ListeAllFeuilles() As String
Dim x$, i%, s$: s = ""
For i = 2 To Sheets.Count: x = "E" + Trim(i + 2): s = s + Right(Trim(i + 99), 2) + " " + Sheets(i).Name + vbCr: Next
ListeAllFeuilles = s: End Function
Function YesOrNo(Tx$) As Boolean
R = MsgBox(Tx, 4): If R = 6 Then YesOrNo = True Else YesOrNo = False
End Function
Sub Attente(Durée As Double)
Dim Déb As Double: Déb = Timer: Do While Timer < Déb + Durée: DoEvents: Loop: End Sub
Sub info(Mes$)
R = MsgBox(Mes, vbOK): End Sub
Sub Protect(ByRef f$, b As Boolean)
If b Then Worksheets(f).Protect Else Worksheets(f).Unprotect
End Sub
Sub DispAlert(b As Boolean)
Application.DisplayAlerts = b: End Sub
Sub FixerInfos()
Application.ScreenUpdating = True: Application.ScreenUpdating = False: End Sub
Public Sub QuitteR()
Dim x$: x = Range("Classeur").Value: DispAlert False: Workbooks(x).Save
Sauvegarde = Range("Sauvegarde").Value + x: ActiveWorkbook.SaveCopyAs Sauvegarde: Application.Quit: End Sub
Sub Activer(ByRef f$)
Sheets(f).Activate: Sheets(f).Select: ' With ActiveWindow: .Top = 10: .Left = 10: .Width = 1024: .Height = 650: End With
Protect f, False: Application.ScreenUpdating = False: End Sub
Sub WriteFFic(Donnée$)
Dim x$: Close
iFicFic = iFicFic + 1: x = Trim(iFicFic) & Coma & Donnée: Open FFic For Append As #6: Print #6, x: Close: End Sub
Sub WriteFdos(Donnée$)
Dim x$: Close
iFicDos = iFicDos + 1: x = Trim(iFicDos) & Coma & Donnée: Open FDos For Append As #6: Print #6, x: Close: End Sub
Sub Trace(x$)
Debug.Print x: End Sub
Sub VoirIndex()
Vdos = LireCellule(FeuilDos, "DernièreLigneDos"): Vfic = LireCellule(FeuilFic, "DernièreLigneFic")
SetCellule FeuilMain, "NbNivReconnus", Trim(iNivoDos): SetCellule FeuilMain, "NbDosReconnus", Trim(Vdos - 1)
SetCellule FeuilMain, "NbFicReconnus", Trim(Vfic - 1): Range("A1").Select: FixerInfos: End Sub
'************* accès Cellules *********************************************************
Sub SetCellule(ByVal Feuil$, ByVal NomCellule$, Valeur$)
On Error GoTo ER: If NomCellule = "" Then Exit Sub
Protect Feuil, False: Worksheets(Feuil).Activate
Range(NomCellule).Select: Selection.Value = Valeur: GoTo 9 'FixerInfos:
ER: info "EcrireFeuilDos " & Str(Err) & " " & Error: Resume 9
9: On Error GoTo 0: End Sub
Function LireCellule(ByVal Feuil$, ByVal NomCellule$) As String
If NomCellule = "" Then Exit Function
1: On Error GoTo ER: Activer Feuil: Protect Feuil, False: 'Worksheets(Feuil).Activate
Range(NomCellule).Select: LireCellule = Selection.Value: GoTo 9
ER: info "LireFeuilDos " & Str(Err) & " " & Error: Resume 1
9: On Error GoTo 0: End Function

Sub EcrireFeuilDos(Niv%, Nom$, Orig$, Dcréé As Date, Dmodif As Date)
Dim indx As Double, x$: On Error GoTo ER
Activer FeuilDos: x = LireCellule(FeuilDos, "DernièreLigneDos"): indx = Val(x) + 1
x = "A" + Trim(indx): Range(x).Value = Niv:
x = "B" + Trim(indx): Range(x).Value = Nom:
x = "C" + Trim(indx): Range(x).Value = Orig:
x = "D" + Trim(indx): Range(x).Value = Dcréé:
x = "E" + Trim(indx): Range(x).Value = Dmodif:
SetCellule FeuilDos, "DernièreLigneDos", Trim(indx): GoTo 9
ER: info "Arrêt Ecriture FeuilDos :" & vbCr & Str(Err) & " " & Error: Resume 9
9: On Error GoTo 0: Activer FeuilMain: End Sub

Sub EcrireFeuilFic(Niv%, Nom$, Orig$, Dcréé As Date, Dmodif As Date)
Dim indx As Double, x$: On Error GoTo ER
Activer FeuilFic: x = LireCellule(FeuilFic, "DernièreLigneFic"): indx = Val(x) + 1
x = "A" + Trim(indx): Range(x).Value = Niv:
x = "B" + Trim(indx): Range(x).Value = Nom:
x = "C" + Trim(indx): Range(x).Value = Orig:
x = "D" + Trim(indx): Range(x).Value = Dcréé:
x = "E" + Trim(indx): Range(x).Value = Dmodif:
SetCellule FeuilFic, "DernièreLigneFic", Trim(indx): GoTo 9
ER: If Err = 9 Then Resume 9
info "EcrireFeuilFic " & Str(Err) & " " & Error: Resume 9
9: On Error GoTo 0: Activer FeuilMain: End Sub

Sub Cherche()
Dim objFSO, XDrive, XLetter, XName, XFree, XType, XExist, x$, T$, n: On Error GoTo ER
Activer FeuilMain: Protect FeuilMain, False: Range("ZoneListeFeuilles").ClearContents: Range("ZoneTravail").ClearContents
Range("ZoneTravail").Select: With Selection.Font: .Color = vbBlack: .Name = "Police corps": .size = 10: .Bold = False: End With
Set objFSO = CreateObject("Scripting.FileSystemObject")
For Each XDrive In objFSO.Drives
XFree = 0: XExist = objFSO.DriveExists(XDrive): If Not XExist Then GoTo Nxt
If objFSO.DriveExists(XDrive) Then XLetter = XDrive.DriveLetter: XType = XDrive.DriveType
i = Asc(XLetter) - 64
x = "A" + Trim(i): Range(x).Value = XLetter: x = "A" + Trim(i) + ":D" + Trim(i)
Select Case XType
Case Is = 1: T = "Clé USB": Range(x).Font.Color = vbBlue: XName = XDrive.volumename: XFree = XDrive.FreeSpace
Case Is = 2: T = "Disc Fixe": Range(x).Font.Color = vbBlack: XName = XDrive.volumename: XFree = XDrive.FreeSpace
Case Is = 3: T = "Réseau": Range(x).Font.Color = vbRed: XFree = 0: XName = "Réseau"
Case Is = 4: T = "CD-ROM": Range(x).Font.Color = Vert: XFree = 0: XName = "Lecteur CD.ROM"
Case Is = 5: T = "RAM": Range(x).Font.Color = vbMagenta: XFree = 0: XName = "Mémoire interne"
Case Else: T = "inconnu": Range(x).Font.Color = Gris: XFree = 0: XName = "?"
End Select: x = "D" + Trim(i): Range(x).Value = T
x = "B" + Trim(i): Range(x).Value = XName
If XFree > 0 Then
If XFree > 1024 ^ 3 Then x = "C" + Trim(i): Range(x).Value = Format((Round(XFree / (1024 ^ 3), 1)), "0.0 Go"): GoTo 1
If XFree > 1024 ^ 2 Then x = "C" + Trim(i): Range(x).Value = Format((Round(XFree / (1024 ^ 2), 1)), "0.0 Mo"): GoTo 1
If XFree > 1024 ^ 1 Then x = "C" + Trim(i): Range(x).Value = Format((Round(XFree / (1024 ^ 1), 1)), "0.0 Ko")
1: CréerFeuille (XLetter): End If
Nxt: Next: GoTo 9
ER: If Err = 71 Then
T = "Lecteur Cartes": i = Asc(XLetter) - 64: x = "A" + Trim(i): Range(x).Value = XLetter:
x = "C" + Trim(i): Range(x).Value = "": x = "D" + Trim(i): Range(x).Value = "Sans carte"
x = "A" + Trim(i) + ":D" + Trim(i): Range(x).Font.Color = vbRed: Resume Nxt: End If
info "Erreur sur Recherche " & XLetter & vbCr & " ER:" & Str(Err) & " " & Error: Resume Nxt
9: On Error GoTo 0: Set objFSO = Nothing: RecenserFeuilles: Protect FeuilMain, True: iFicDos = 0: LireAllSupports: MarquerFeuilOccupées: End Sub 'iNivoDos = 1:
Sub VoirImage(ByVal NomImage$)
Const Hau = 370, Lar = 333, Gau = 345: Dim NomIm$: NomIm = UCase(NomImage): Activer FeuilMain
If NomIm <> "PRÉALABLE" And NomIm <> "PATIENCE1" And NomIm <> "PATIENCE2" And _
NomIm <> "FININIT" And NomIm <> "FINANALYSE" Then info "Nom IMAGE [" & NomIm & "] inconnu !!!": Exit Sub
With ActiveSheet.Shapes("image 3"): .Top = Hau: .Width = Lar: .Left = Gau: .Visible = False: End With
With ActiveSheet.Shapes("image 4"): .Top = Hau: .Width = Lar: .Left = Gau: .Visible = False: End With
With ActiveSheet.Shapes("image 7"): .Top = Hau: .Width = Lar: .Left = Gau: .Visible = False: End With
With ActiveSheet.Shapes("image 8"): .Top = Hau: .Width = Lar: .Left = Gau: .Visible = False: End With
With ActiveSheet.Shapes("image 9"): .Top = Hau: .Width = Lar: .Left = Gau: .Visible = False: End With
ActiveSheet.Shapes("image 7").Visible = NomIm = "PRÉALABLE": ActiveSheet.Shapes("image 9").Visible = NomIm = "PATIENCE2"
ActiveSheet.Shapes("image 8").Visible = NomIm = "PATIENCE1": ActiveSheet.Shapes("image 3").Visible = NomIm = "FININIT"
ActiveSheet.Shapes("image 4").Visible = NomIm = "FINANALYSE": End Sub
Sub CheckListeExclusion()
Dim i%, j%, k%, x$, z$, Sw As Boolean: i = 0: x = UCase(Range("ListExclusion").Value)
1: z = Right(x, 1): If z <> "\" And z <> "*" And z <> "" Then x = x + "\" ' contrôle présence de \ ou de * en fin des dossiers à exclute
Range("ListExclusion").Offset(i, 0).Value = x: i = i + 1: x = UCase(Range("ListExclusion").Offset(i, 0).Value): If x <> "" Then GoTo 1
2: Sw = False ' tir par ordre croissant les dossiers à exclure
For j = 0 To i - 2
If Range("ListExclusion").Offset(j, 0).Value > Range("ListExclusion").Offset(j + 1, 0).Value Then
x = Range("ListExclusion").Offset(j, 0).Value
Range("ListExclusion").Offset(j, 0).Value = Range("ListExclusion").Offset(j + 1, 0).Value
Range("ListExclusion").Offset(j + 1, 0).Value = x: Sw = True: End If
Next j: If Sw Then GoTo 2
3: For j = 0 To i - 2 ' élimine les lignes citant des sous-dossiers alors que le dossier est cité
x = Range("ListExclusion").Offset(j, 0).Value: z = Range("ListExclusion").Offset(j + 1, 0).Value
If Left(z, Len(x)) = x Then
k = j: Sw = True
4: k = k + 1: Range("ListExclusion").Offset(k, 0).Value = Range("ListExclusion").Offset(k + 1, 0).Value
If Range("ListExclusion").Offset(k, 0).Value <> "" Then GoTo 4
End If: Next j: End Sub
Sub Préalable()
Dim i As Single, j As Single, x$, x1$, x2$, CachePas As Byte, CacheHau As Single, CacheTop As Single: VoirImage "Préalable"
i = 0: j = 30: SwPréalable = True
CachePas = 15: CacheHau = 261: CacheTop = 111
x1 = "ATTENTE de Décision" + vbCr + "après": x2 = " secondes ... " + vbCr + "FERMETURE du classeur !"
Application.ScreenUpdating = False: Activer FeuilMain: ActiveWindow.DisplayHeadings = False
With Application: .WindowState = xlNormal: .Height = 648: .Width = 960: .Left = 180: .Top = 12: End With
With ActiveWorkbook.Windows(1): .DisplayWorkbookTabs = True: .Height = 480: .Zoom = 90: .Width = 940: End With: P_Init
With Worksheets(1).Cache: .Height = CacheHau: .Top = CacheTop: .Visible = True: .Value = x1 + Str(j) + x2
1: SetCellule FeuilMain, "DélaiPréalable", Trim(i): Application.ScreenUpdating = True
If i < 30 Then
DoEvents: Attente 1: i = i + 1: j = 30 - i
.Value = x1 + Str(j) + x2: CacheTop = CacheTop + CachePas: CacheHau = CacheHau - CachePas
.Top = CacheTop: .Height = CacheHau: If SwPréalable Then GoTo 1 Else GoTo 2
End If: .Visible = False: End With: QuitteR: Exit Sub
2: Worksheets(1).Visible = False: Application.ScreenUpdating = False: End Sub
' SetCellule FeuilMain, "DélaiPréalable", ""
Sub P_Init()
Qot = Chr(34): QCQ = Qot & "," & Qot: Application.ScreenUpdating = True: Application.ScreenUpdating = False
If Range("Fic_Fichiers").Value = "" Then Range("Fic_Fichiers").Value = FFic
FFic = Range("Fic_Fichiers").Value: Close: Open FFic For Output As #6
Print #6, Left(" Noms des fichiers" & Space(40), 40) & Left(" Origine Dossiers" & Space(60), 60) & " Créé Modifié Enreg. "
Close
If Range("Fic_Dossiers").Value = "" Then Range("Fic_Dossiers").Value = FDos
FDos = Range("Fic_Dossiers").Value: Close: Open FDos For Output As #6
Print #6, Left(" Noms des dossiers" & Space(40), 40) & Left(" Origine Dossiers" & Space(60), 60) & " Créé Modifié Enreg. "
Close
If Range("CheminSons").Value = "" Then Range("CheminSons").Value = FSons
FSons = Range("CheminSons").Value: Close: LireSons: Close
If Worksheets(1).CheckSons.Value Then Worksheets(1).CheckSons.Caption = "Les Sons sont entendus" Else Worksheets(1).CheckSons.Caption = "Pas de Sons"
SwSons = Worksheets(1).CheckSons.Value
If Range("CheminAide").Value = "" Then Range("CheminAide").Value = FAide
FSons = Range("CheminSons").Value: CheckListeExclusion: initFeuilList FeuilDos: initFeuilList FeuilFic
Range("Classeur").Value = ThisWorkbook.Name: Range("CheminClasseur").Value = CheminClasseur
SetCellule FeuilDos, "DernièreLigneDos", "1": SetCellule FeuilFic, "DernièreLigneFic", "1"
SetCellule FeuilMain, "CheminSons", FSons: SetCellule FeuilMain, "NbDosReconnus", "": SetCellule FeuilMain, "Nivatteint", "": End Sub

Sub Initialiser()
1: P_Init: VoirImage "Patience1": DeleteAllFeuilles: Application.Goto Reference:="R1C1": iNivoDos = 1: Cherche: Application.ScreenUpdating = True: BipAction
VoirImage "FinInit": End Sub
Sub RecenserFeuilles()
Dim f$, x$, y$, i%, NbF As Byte, Sw As Boolean
1: Sw = False
For i = 4 To Sheets.Count: Sheets(i).Activate: y = ActiveSheet.Name: TbFeuil(i) = y: Next
For i = 4 To Sheets.Count: y = TbFeuil(i) ' supprime les feuilles autres que celles des supports
If Not (Len(y) = 1 Or y = FeuilMain Or y = FeuilDos Or y = FeuilFic) Then
DispAlert False: Sheets(y).Activate: Sheets(y).Delete: Sw = True: DispAlert True: End If
Next: If Sw = True Then GoTo 1
Protect FeuilMain, False: Sheets(FeuilMain).Activate: End Sub
Sub DeleteAllFeuilles()
Dim f$, i%, j%: On Error GoTo ER: DispAlert False: i = 1
1: If Sheets.Count > 3 Then
f = Sheets(i).Name
If f = FeuilMain Or f = FeuilDos Or f = FeuilFic Then i = i + 1: GoTo 1 'interdit la suppression de feuilles maîtresse
Sheets(i).Select: ActiveWindow.SelectedSheets.Delete: GoTo 1
End If: GoTo 9
ER: If Err <> 1004 Then Resume 1 ' Erreur définie par l'application ou par l'objet
9: On Error GoTo 0: Activer FeuilMain: DispAlert True: End Sub
Sub CréerFeuille(ByRef f$)
On Error GoTo ER: Activer FeuilMain: DispAlert False
Sheets.Add after:=Sheets(Sheets.Count): Sheets(Sheets.Count).Name = f: FormaterNewFeuille f: GoTo 9
ER: If Err = 1004 Then Resume Next
info "CréerFeuille " & Str(Err) & " " & Error: Resume 9
9: On Error GoTo 0: Activer FeuilMain: End Sub
Sub LireAllSupports()
Dim i%, j%, k%, x$, y$, z$, Nam$, L$, Nivo As Byte, HeadFeuilSupp$, Chdoss$, N°Support As Byte
Activer FeuilMain: Range("ZoneListeFeuilles").ClearContents 'RzTbListe:
Range("ZoneListeFeuilles").Select
With Selection.Interior: .Pattern = xlNone: .TintAndShade = 0: .PatternTintAndShade = 0: End With
Range("ZoneListeFeuilles").Font.Color = vbBlack: Nivo = 1
For i = 3 To 26: x = "E" + Trim(i): Range(x).Value = "": Next i: k = 3 '<== début liste des supports traités
For i = 3 To 26: L = Chr(64 + i): N°Support = i
x = "C" + Trim(i): If Val(Range(x).Value) = 0 Then GoTo Nxt
x = "A" + Trim(i): L = Range(x).Value:
x = "B" + Trim(i): Nam = Range(x).Value:
If Len(L) = 1 Then HeadFeuilSupp = L + ":\": x = "E" + Trim(k): Range(x).Value = HeadFeuilSupp: k = k + 1
Activer L: x = "A:E": x = "A1": Range(x).Value = HeadFeuilSupp
Sheets(L).Select: With ActiveWorkbook.Sheets(L).Tab: .Color = vbBlue: .TintAndShade = 0: End With
Chdoss = L + ":\": If Not TesTExclusion(Chdoss) Then ExtraireContenuVolume Chdoss
Activer FeuilMain
Nxt: Next i: VoirIndex: End Sub
Sub ExtraireContenuVolume(Chdoss$)
Dim fs, f, f1, fc, sf, Tb%, i%, j%, L%, x$, z$, z2$, Att, Sw As Boolean: On Error GoTo ER0: i = 18 '<== début liste dossiers à exclure
a1: x = "I" + Trim(i): z = Range(x).Value: If z = "" Then GoTo 1
If Right(z, 1) = "*" Then L = Len(z) - 1: If Left(Chdoss, L) = Left(z, L) Then Exit Sub
If z = Chdoss Then Exit Sub Else i = i + 1: GoTo a1
1: Set fs = CreateObject("Scripting.FileSystemObject")
If Dir(Chdoss$, vbDirectory) = vbNullString Then Exit Sub
Set f = fs.GetFolder(Chdoss): Set sf = f.SubFolders: On Error GoTo ER1
For Each f1 In sf: Att = f1.Attributes: Sw = Att And 6 And ObjCaché: If Sw Then GoTo Nx1
x = Trim(iNivoDos) & Coma & Qot & Chdoss & f1.Name & "\" & Qot & Coma & vbTab
If Att And 6 Then GoTo Nx1
2: iDos = iDos + 1: 'z = Chdoss & f1.Name & "\"
WriteFdos x & Qot & FormatDate(f1.DateCreated) & QCQ & FormatDate(f1.DateLastModified) & QCQ & FormatDate(Date) & Qot
EcrireFeuilDos iNivoDos, f1.Name, Chdoss, f1.DateCreated, f1.DateLastModified
Nx1: Next: LastiDos = iDos: Set fs = Nothing: On Error GoTo ER2
Set fs = CreateObject("Scripting.FileSystemObject"): Set fc = f.Files
For Each f1 In fc: Att = f1.Attributes: Sw = Att And 6 And ObjCaché: If Sw Then GoTo Nx2
x = Trim(iNivoDos) & Coma & f1.Name & Coma & Chdoss & Coma
If Att And 6 Then GoTo Nx2
WriteFFic x & FormatDate(f1.DateCreated) & Coma & FormatDate(f1.DateLastModified) & Coma & FormatDate(Date)
EcrireFeuilFic iNivoDos, f1.Name, Chdoss, f1.DateCreated, f1.DateLastModified
CopieFeuil Chdoss, f1.Name, FormatDatHeur(f1.DateCreated), FormatDatHeur(f1.DateLastModified), iNivoDos
Nx2: Next: GoTo 9
ER0: If Err = 5 Or Err = 52 Then GoTo 9 ' Argument ou appel de procédure incorrect
info "Sur Extraire Contenu : " & vbCr & Chdoss & vbCr & " ER0 " & Str(Err) & " " & Error: GoTo 9
ER1: If Err = 9 Then Resume Nx1 ' L'indice n'appartient pas à la sélection
info "Sur Extraire Contenu : " & vbCr & Chdoss & vbCr & " ER1 " & Str(Err) & " " & Error: Resume Nx1
ER2: If Err = 5 Then Resume Nx2 ' Argument ou appel de procédure incorrect
If Err = 9 Then Resume Nx2 ' L'indice n'appartient pas à la sélection
info "Sur Extraire Contenu : " & vbCr & Chdoss & vbCr & " ER2 " & Str(Err) & " " & Error: Resume Nx2
9: On Error GoTo 0: SetCellule FeuilMain, "NbDosReconnus", Trim(LastiDos - 1): Set fs = Nothing: End Sub ' z
Function FormatDate(dat As Date) As String
FormatDate = Format(dat, "dd/mm/yy"): End Function
Function FormatDatHeur(dat As Date) As String
FormatDatHeur = Format(dat, "dd/mm/yy hh:mm:ss"): End Function
Sub CopieFeuil(Doss$, Fich$, Dcré$, Dmod$, Niv%)
' Debug.Print Doss, Fich, Dcré, Dmod, Niv
Dim Lettre$, x$, DerLig%: Lettre = Left(Doss, 1) ': Debug.Print Lettre; " "; Doss; " | "; Fich; " "; Dcré; " "; Dmod; " "; Trim(Niv)
Activer Lettre: DerLig = LireCellule(Lettre, "F2") + 1: SetCellule Lettre, "F2", Trim(DerLig)
x = "A" + Trim(DerLig): SetCellule Lettre, x, Doss
x = "B" + Trim(DerLig): SetCellule Lettre, x, Fich
x = "C" + Trim(DerLig): SetCellule Lettre, x, Dcré
x = "D" + Trim(DerLig): SetCellule Lettre, x, Dmod
x = "E" + Trim(DerLig): SetCellule Lettre, x, Trim(Niv)

End Sub
Sub AppelDossiers()
Dim i%, j%, iNiv%, Niv%, n%, Chdoss$, OldiDos As Double, ADos As Double, D1$, D2$, D3$
NivoMax = Val(LireCellule(FeuilMain, "NivoMaxi"))
On Error GoTo ER: iNiv = iNivoDos: iDos = 1: VoirImage "Patience2"
1: Open FDos For Input As #5: Input #5, Chdoss ' lecture première ligne (titres sans virgule)
OldiDos = LastiDos: ADos = 0: Chdoss = ""
2: If EOF(5) Then GoTo 6
DoEvents
Input #5, n, Niv, Chdoss, D1, D2, D3: If Niv < iNiv Then GoTo 2 ' saute les dossiers de niveau déjà traités
4: If TesTExclusion(Chdoss) Then GoTo 5
ADos = ADos + 1: TbDoss(ADos) = Chdoss: ' stocke les dossiers du niveau donné et non exclus
5: If EOF(5) Then GoTo 6
DoEvents
Input #5, n, Niv, Chdoss, D1, D2, D3: If Niv = iNiv Then GoTo 4
6: Close: VoirIndex: For i = 1 To iNiv: BipFinLigne: Next: If ADos = 0 Then SetCellule FeuilMain, "Nivatteint", "niveau maxi atteint : " & Trim(iNiv - 1): GoTo 7
iNiv = iNiv + 1: iNivoDos = iNiv: If iNiv > NivoMax Then SetCellule FeuilMain, "Nivatteint", "Niveau " & Trim(iNiv - 1) & " demandé atteint ": GoTo 7
For i = 1 To ADos: Chdoss = TbDoss(i): DoEvents
ExtraireContenuVolume Chdoss: Next ' recherche dossiers du niveau en cours
LastiDos = iFicDos: GoTo 1
7: On Error GoTo 0: TriDonnéesRecensées: VoirImage "FinAnalyse": BipAction: Exit Sub
ER: If Err = 62 Then Resume Next
info "Sur Appel Dossier : " & vbCr & Chdoss & vbCr & " ER:" & Str(Err) & " " & Error: Resume Next
End Sub
Function TesTExclusion(Doss$) As Boolean
Dim i%, x$, L%: x = Range("ListExclusion").Value: L = Len(x)
1: If Right(x, 1) = "*" Then L = L - 1
If UCase(Left(x, L)) = UCase(Left(Doss, L)) Then TesTExclusion = True: Exit Function
i = i + 1: x = Range("ListExclusion").Offset(i, 0).Value: L = Len(x): If L > 0 Then GoTo 1
End Function
Sub TriDonnéesRecensées()
Sheets(FeuilDos).Select
Application.Goto Reference:="ZTriDos"
ActiveWorkbook.Worksheets(FeuilDos).Sort.SortFields.Clear
ActiveWorkbook.Worksheets(FeuilDos).Sort.SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets(FeuilDos).Sort
.SetRange Range("A2:E78000"): .Header = xlNo: .MatchCase = False
.Orientation = xlTopToBottom: .SortMethod = xlPinYin: .Apply: End With
ActiveWorkbook.Worksheets(FeuilDos).Sort.SortFields.Clear
ActiveWorkbook.Worksheets(FeuilDos).Sort.SortFields.Add Key:=Range("B2:B78000"), SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets(FeuilDos).Sort
.SetRange Range("A1:E78000"): .Header = xlYes: .MatchCase = False
.Orientation = xlTopToBottom: .SortMethod = xlPinYin: .Apply: End With
ActiveWindow.ScrollRow = 1

Sheets(FeuilFic).Select
Application.Goto Reference:="ZTriFic"
ActiveWorkbook.Worksheets(FeuilFic).Sort.SortFields.Clear
ActiveWorkbook.Worksheets(FeuilFic).Sort.SortFields.Add Key:=Range("B2:B88709"), SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets(FeuilFic).Sort
.SetRange Range("A1:E88709"): .Header = xlYes: .MatchCase = False
.Orientation = xlTopToBottom: .SortMethod = xlPinYin: .Apply: End With
ActiveWorkbook.Worksheets(FeuilFic).Sort.SortFields.Clear
ActiveWorkbook.Worksheets(FeuilFic).Sort.SortFields.Add Key:=Range("B2:B88709"), SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets(FeuilFic).Sort
.SetRange Range("A1:E88709"): .Header = xlYes: .MatchCase = False
.Orientation = xlTopToBottom: .SortMethod = xlPinYin: .Apply: End With
ActiveWindow.ScrollRow = 1
Sheets(FeuilMain).Select
End Sub

------------------------------------------------------------------------

B/ Module2 :
Option Explicit

Function ChercheIndexSheets(f$) As Integer ' donne l'index de la feuille (0 si non trouvée)
Dim i%: ChercheIndexSheets = 0
For i = 2 To Sheets.Count: If UCase(f) = UCase(Sheets(i).Name) Then ChercheIndexSheets = i: Exit Function
Next: End Function
Sub MarquerFeuilOccupées()
Dim i%, x$, y$: Protect FeuilMain, False: Range("E3:E995").Select
With Selection.Interior: .Pattern = xlNone: .TintAndShade = 0: .PatternTintAndShade = 0: End With
ZFeuilOccupées = "E3:E" + Trim(Sheets.Count - 1): Range(ZFeuilOccupées).Select
With Selection.Interior: .Pattern = xlSolid: .PatternColorIndex = xlAutomatic: .ThemeColor = xlThemeColorAccent1
.TintAndShade = 0.799981688894314: .PatternTintAndShade = 0: End With
For i = 4 To Sheets.Count: x = "E" + Trim(i - 1): y = Right(Trim(i + 97), 2) + " " + Sheets(i).Name: Range(x).Value = y: Next: End Sub
Sub FormaterNewFeuille(f$) ' met en forme les feuilles de niveau 1
Dim x$, i%: x = f + "\"
Range("A:G").ClearContents: Range("A:G").Select: Selection.RowHeight = 14
With Selection.Font
.Name = "Police corps": .size = 10: .TintAndShade = 0: .Strikethrough = False:
.Superscript = False: .Subscript = False: .OutlineFont = False: .Shadow = False
.Underline = xlUnderlineStyleNone: .ThemeFont = xlThemeFontNone: End With
Columns("A:B").Select: Selection.ColumnWidth = 30: Selection.HorizontalAlignment = xlLeft
Columns("C:D").Select: Selection.ColumnWidth = 6: Selection.HorizontalAlignment = xlCenter
Columns("E").Select: Selection.ColumnWidth = 2: Selection.HorizontalAlignment = xlCenter
Columns("F").Select: Selection.ColumnWidth = 3: Selection.HorizontalAlignment = xlCenter

Range("A1:B1").Select
With Selection
.HorizontalAlignment = xlCenter: .WrapText = False: .Orientation = 0: .IndentLevel = 0
.VerticalAlignment = xlCenter: .AddIndent = False: .MergeCells = False: .ShrinkToFit = False
.ReadingOrder = xlContext: .Value = x: .Font.size = 16: End With
With Selection.Interior
.Pattern = xlNone: .TintAndShade = 0: .PatternTintAndShade = 0: End With
Sheets(f).Select: With ActiveWorkbook.Sheets(f).Tab: .Color = xlAutomatic: .TintAndShade = 0: End With
Range("A1").Font.Color = vbBlue
Columns("C:D").Select: Selection.NumberFormat = "dd/mm/yy hh:mm:ss"
Range("C1:D1").Select
With Selection
.HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter: .WrapText = False: .Orientation = 0: .Merge: .ColumnWidth = 10
.AddIndent = False: .IndentLevel = 0: .ShrinkToFit = False: .ReadingOrder = xlContext: .MergeCells = False: End With
ActiveCell.FormulaR1C1 = "Dates" & Chr(10) & " Création Modification"
With ActiveCell.Characters(Start:=1, Length:=29).Font: .Name = "Police corps": .FontStyle = "Normal": .size = 10
.Strikethrough = False: .Superscript = False: .Subscript = False: .OutlineFont = False: .Shadow = False: .Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1: .TintAndShade = 0: .ThemeFont = xlThemeFontNone: End With
With Selection: .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter: .WrapText = True: .Orientation = 0: .AddIndent = False
.IndentLevel = 0: .ShrinkToFit = False: .ReadingOrder = xlContext: .MergeCells = True: End With
Selection.Font.Bold = True: Selection.RowHeight = 30
Range("F1").Select: Selection.Value = ChercheIndexSheets(f): Selection.VerticalAlignment = xlTop
Range("F2").Value = 1: Range("G2").Value = "'<== der. ligne"
Range("G1").Select
With Selection
.HorizontalAlignment = xlCenter: .VerticalAlignment = xlTop: .WrapText = False: .Orientation = 0
.AddIndent = False: .IndentLevel = 0: .ShrinkToFit = False: .ReadingOrder = xlContext: .MergeCells = False
.Font.Bold = True: .ColumnWidth = 5: End With
ActiveCell.FormulaR1C1 = "<== Rang" & Chr(10) & "feuille"
Range("B1").Select
With Selection
.HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter: .WrapText = False: .Orientation = 0: .Merge
.AddIndent = False: .IndentLevel = 0: .ShrinkToFit = False: .ReadingOrder = xlContext: .MergeCells = False
.Font.Bold = True: .Font.size = 10: .ColumnWidth = 30: End With
ActiveCell.FormulaR1C1 = "' dossiers | fichiers ¯¯¯¯¯¯¯¯¯|" & vbCrLf & "<-----/¯¯¯¯¯¯¯¯¯¯¯¯¯ v ."
Range("E1").Select
With Selection
.HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter: .WrapText = False: .Orientation = 0: .Merge: .ColumnWidth = 2
.AddIndent = False: .IndentLevel = 0: .ShrinkToFit = False: .ReadingOrder = xlContext: .MergeCells = False: .Font.Bold = True: End With
ActiveCell.FormulaR1C1 = "Niv-" & Chr(10) & "eau"
Range("A1:E1").Select
With Selection.Interior
.Pattern = xlSolid: .PatternColorIndex = xlAutomatic: .Color = 65535
.TintAndShade = 0: .PatternTintAndShade = 0: End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft): .LineStyle = xlContinuous: .ColorIndex = 0: .TintAndShade = 0: .Weight = xlThin: End With
With Selection.Borders(xlEdgeTop): .LineStyle = xlContinuous: .ColorIndex = 0: .TintAndShade = 0: .Weight = xlThin: End With
With Selection.Borders(xlEdgeBottom): .LineStyle = xlContinuous: .ColorIndex = 0: .TintAndShade = 0: .Weight = xlThin: End With
With Selection.Borders(xlEdgeRight): .LineStyle = xlContinuous: .ColorIndex = 0: .TintAndShade = 0: .Weight = xlThin: End With
With Selection.Borders(xlInsideVertical): .LineStyle = xlContinuous: .ColorIndex = 0: .TintAndShade = 0: .Weight = xlThin: End With
With Selection.Borders(xlInsideHorizontal): .LineStyle = xlContinuous: .ColorIndex = 0: .TintAndShade = 0: .Weight = xlThin: End With
Range("A2").Select: End Sub
Sub initFeuilList(ByRef f$)
On Error GoTo ER: Activer f
Cells.ClearContents
' Cells.Select.Font.size = 8
' Range("A1:L1").Select.Font.size = 10
Columns("F:F").ColumnWidth = 3.4
Range("F2").Select: With Selection
.HorizontalAlignment = xlCenter: .VerticalAlignment = xlBottom: .WrapText = False
.Orientation = 0: .AddIndent = False: .IndentLevel = 0: .ShrinkToFit = False
.ReadingOrder = xlContext: .MergeCells = False: End With
If f = FeuilDos Then
Range("B1").Value = "Noms des Dossiers": Range("C1").Value = "Origines du dossier"
Else
Range("B1").Value = "Noms des Fichiers": Range("C1").Value = "Origines du fichier"
End If
Range("A1").Value = "Niv- eau": Range("D1").Value = "Dates création"
Range("F1").Value = "Der. ligne": Range("E1").Value = "Dates modif."
Range("F2").Value = 0
Application.DisplayFormulaBar = False: ActiveWindow.DisplayHeadings = False: GoTo 9
ER: info "Sur init.FeuilList " & f & vbCr & " ER:" & Str(Err) & " " & Error: Resume Next
9: On Error GoTo 0: End Sub


C/ Module 3 :
Option Explicit

Sub Macro1()
'
' Macro1 Macro
'

'
Range("K19").Select
Sheets("Mes Supports").Select
Range("A9").Select
End Sub
</code)
-------------------------------------------------------------
D/ TES FEUILLES :
feuil10(mes fichiers) :
<code>Option Explicit

Private Sub CmdRetourMain_Click()
Activer FeuilMain: End Sub

</code>
----------------------------------------------------------------

Feuil9(Mes Dossiers) :
Option Explicit

Private Sub CmdRetour_Click()
Activer FeuilMain: End Sub

--------------------------------------------------------
Sheet1(Mes Supports) :
Option Explicit

Private Sub Cache_Change()
SwPréalable = False: End Sub
Private Sub CheckSons_Click()
SwPréalable = False
If CheckSons.Value Then CheckSons.Caption = "Les Sons sont entendus" Else CheckSons.Caption = "Pas de Sons"
SwSons = CheckSons.Value: End Sub
Private Sub CmdVoirDos_Click()
SwPréalable = False: Activer FeuilDos: End Sub
Private Sub CmdVoirFic_Click()
SwPréalable = False: Activer FeuilFic: End Sub
Private Sub CmdLireAutresDossiers_Click()
SwPréalable = False: AppelDossiers: End Sub
Private Sub CmdPréalable_Click()
SwPréalable = False: End Sub
Private Sub CmdAnalyseSupports_Click()
SwPréalable = False
1: ObjCaché = CheckBox2.Value: SwSons = CheckSons.Value: If Not ObjCaché Then GoTo 1
2: Initialiser: End Sub
Private Sub CheckBox2_Click()
SwPréalable = False
If CheckBox2.Value Then CheckBox2.Caption = "Les éléments cachés le restent " Else CheckBox2.Caption = "Les éléments cachés sont vus"
ObjCaché = CheckBox2.Value:
End Sub
Private Sub CmdTestSons_Click()
SwPréalable = False
Dim i As Byte, j As Byte, k As Byte, L As Byte, n(4) As Byte, iSon As Byte, Fr%, Du%, x$(4), y$, s$
For i = 1 To 4: x(i) = "": Next i
y = "Pour chacun des 4 types de sons, chaque note est" + vbCrLf + " définie par sa fréquence =>'1500_50'<= et sa durée. " + vbCrLf + vbCrLf
j = iActi: n(1) = j: y = y + "1) Attente Action" + vbTab + Trim(j) + " note(s)" + vbCrLf + vbTab
For i = 1 To j: x(1) = x(1) + Trim(SonActi(1, i)) + "_" + Trim(SonActi(2, i)) + vbTab: Next i
j = iQues: n(2) = j: y = y + x(1) + vbCrLf + "2) Question (?) " + vbTab + Trim(j) + " note(s)" + vbCrLf + vbTab
For i = 1 To j: x(2) = x(2) + Trim(SonQues(1, i)) + "_" + Trim(SonQues(2, i)) + vbTab: Next i
j = iFinL: n(3) = j: y = y + x(2) + vbCrLf + "3) Fin Saisie " + vbTab + Trim(j) + " note(s)" + vbCrLf + vbTab
For i = 1 To j: x(3) = x(3) + Trim(SonFinL(1, i)) + "_" + Trim(SonFinL(2, i)) + vbTab: Next i
j = iErrS: n(4) = j: y = y + x(3) + vbCrLf + "4) Erreur " + vbTab + Trim(j) + " note(s)" + vbCrLf + vbTab
For i = 1 To j: x(4) = x(4) + Trim(SonErrS(1, i)) + "_" + Trim(SonErrS(2, i)) + vbTab: Next i
y = y + x(4) + vbCrLf + "Quel Son (de 1 à 4) faut-il tester ?" + vbCrLf + Abandon
1: i = Val(InputBox(y, "Ecoute / Echange Sons")): If i = 0 Then Exit Sub
If i < 1 Or i > NbSons Then GoTo 1 Else iSon = i
Select Case iSon
Case Is = 1: BipAction: s = "Action "
Case Is = 2: BipQuestion: s = "Question "
Case Is = 3: BipFinLigne: s = "FinSaisie "
Case Is = 4: BipErreurSaisie: s = "Erreur "
End Select
If Not YesOrNo("Faut-il changer ce son [" + s + "] ?") Then GoTo 1
2: j = Val(InputBox("Combieb de notes pour [" + s + "] ?" + vbCrLf + _
Trim(n(i)) + " note(s) actuelle(s)" + vbCrLf + vbTab + "Réponse de 1 à 4" + vbCrLf + Abandon, "Saisie Nb. de notes", Trim(n(i))))
If j = 0 Then Exit Sub
If j < 1 Or j > 4 Then GoTo 2 Else iTest = j
3: For k = 1 To iTest
4: y = InputBox("Saisir la note N°" + Trim(k) + vbCrLf + " (fréqence et durée sous la forme 99999_9999)" + vbCrLf + _
x(i) + vbCrLf + Abandon, "Saisie Fréq._Durée", x(i))
If Len(y) = 0 Then Exit Sub
L = InStr(y, "_"): Fr = Left(y, L - 1): Du = Mid(y, L + 1, 11): Bip Fr, Du
If Not YesOrNo("Est-ce corect ?") Then GoTo 4
DTest(k) = y: SonTest(1, k) = Fr: SonTest(2, k) = Du: Next k
For j = 1 To 4: BipTest: Attente 0.4: Next j
If Not YesOrNo("Est-ce un son acceptable ?") Then GoTo 3
' recopie nouveau son (Test) to ancien
Select Case iSon
Case Is = 1: iActi = iTest
For j = 1 To iTest: DActi(j) = DTest(j): SonActi(1, j) = SonTest(1, j): SonActi(2, j) = SonTest(2, j): Next j
Case Is = 2: iQues = iTest
For j = 1 To iTest: DQues(j) = DTest(j): SonQues(1, j) = SonTest(1, j): SonQues(2, j) = SonTest(2, j): Next j
Case Is = 3: iFinL = iTest
For j = 1 To iTest: DFinL(j) = DTest(j): SonFinL(1, j) = SonTest(1, j): SonFinL(2, j) = SonTest(2, j): Next j
Case Is = 4: iErrS = iTest
For j = 1 To iTest: DErrS(j) = DTest(j): SonErrS(1, j) = SonTest(1, j): SonErrS(2, j) = SonTest(2, j): Next j
End Select: RewriteSons: End Sub


Aucune de tes autres feuilles ne contient du code autre que Option Explicit
--------------------------------------------------
E/ THISWORKBOOK :


Option Explicit
Private Sub Workbook_Open()
Application.DisplayFormulaBar = True: ActiveWindow.DisplayHeadings = True: SwPréalable = False
FFic = Path + "\" + NFic: FDos = Path + "\" + NDos: FSons = Path + "\" + Nsons: FAide = Path + "\" + NAide
CheminClasseur = Path + "\" + Name: Activer FeuilMain: Range("CheminClasseur").Value = CheminClasseur: Range("CheminAide").Value = "":
Range("Fic_Fichiers").Value = "": Range("Fic_Dossiers").Value = "": Range("CheminSons").Value = "": Préalable: End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
QuitteR
End Sub


Que faire avec cela ? ===>>W>
Crée donc un NOUVEAU CLASSEUR (important)
Copie/colle tes feuilles depuis ton fichier xlt (sans les macros)
Réinsère toutes ces procédures et macros dans le nouveau classeur
Sauvegarde (important, bien sûr)

EDIT : Pour tout dire, je ne sais pas ce qu'il s'est passé avec ton classeur (ce qui a provoqué cet incident) : Il contenait un "drapeau" de partage que l'on ne pouvait ôter ni normalement (en départageant) ni depuis une instruction externe sur ce classeur (objet_classeur.UnprotectSharing)
On dirait que ce "drapeau" est anormalement resté là à la suite d'une interruption brutale, alors que le fichier était utilisé depuis ailleurs !)

Bon ... la "chose" devrait maintenant avoir été réglée. Confirme-le moi de sorte à ce que j'efface maintenant tout cela sur mon disque dur.

________________________
Nul ne saurait valablement coder ce qu'il ne saurait exposer clairement.
Messages postés
151
Date d'inscription
lundi 16 janvier 2006
Statut
Membre
Dernière intervention
19 avril 2016

Bien reçu toutes mes macros.
Je m'y attelle demain et pense que tu peux effacer la partie que je devais occuper sur ton disque dur.
J'ai déjà copier ces macros dans un texte.

Je te remercie encore pour ta grande attention à mon besoin et surtout ton efficacité. Dès réparation terminée, je t'enverrai un bilan de mon opération réparatrice.
A +, Babu