Suppression mot de passe fichier en masse (en ayant le mot de passe)

Version imprimable

18/11/2021, 10h07
Seifkone

Suppression mot de passe fichier en masse (en ayant le mot de passe)

Bonjour !

J'ai 550 fichiers a deverrouiller (le code qui est demandé à l'ouverture du fichier). J'ai pas très envie de passer ma journée a faire des C/C et F12 sur chaque fichier ...

Quelqu'un a une solution pour m'aider à faire un deverouillage de masse ? J'ai le mot de passe d'ouverture donc pas un souci mais des solutions comme aspose le supprime carrément sans mot de passe ... mais que 10 par 10 :/

Merci d'avance !
18/11/2021, 12h18
tototiti2008

Bonjour,

Sais tu où se trouvent chacun de ces fichiers ? sont-ils regroupés dans un même dossier ou possèdes-tu la liste de leur chemin complet ?
as-tu la liste des mot de passe ou est-ce le même mot de passe ?
de ces réponses dépendra une réponse adaptée, mais à mon avis il faudra ouvrir chacun des fichiers pour le réenregistrer sans mot de passe, donc ça peut être long à exécuter
18/11/2021, 12h58
Seifkone

Oui, je sais ou il se situe :) Ils sont dans un répertoire (FORMATION) et dispactché dans 142 sous-repertoires qui ne contiennent que ces documents.

Il s'agit d'un mot de passe unique que j'ai en ma possession.

Merci :)

Bonjour,

A coller dans un module
Adapter le chemin du dossier parent à tous les fichiers
Adapter le mot de passe

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
 
Dim ListeFic() As String, Fs
 
 
Sub SansMDP()
Dim i As Long, Wkb As Workbook
    ReDim ListeFic(1 To 1)
    Set Fs = CreateObject("Scripting.FileSystemObject")
    ListeFichiers "C:\Users\Toto\Desktop\test\", "*.xls*"
    Application.ScreenUpdating = False
    If ListeFic(UBound(ListeFic)) = "" Then ReDim Preserve ListeFic(1 To UBound(ListeFic) - 1)
    Application.DisplayAlerts = False
    For i = LBound(ListeFic) To UBound(ListeFic)
        Set Wkb = Workbooks.Open(Filename:=ListeFic(i), UpdateLinks:=2, Password:="toto")
        Wkb.SaveAs Filename:=ListeFic(i), Password:=""
        Wkb.Close False
    Next i
    Set Fs = Nothing
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox UBound(ListeFic) & " fichiers traités"
End Sub
 
Sub ListeFichiers(Dossier As String, NomFic As String)
Dim Fic, Doss
    For Each Fic In Fs.Getfolder(Dossier).Files
        If ListeFic(UBound(ListeFic)) <> "" Then ReDim Preserve ListeFic(1 To UBound(ListeFic) + 1)
        If Fic.Name Like NomFic Then ListeFic(UBound(ListeFic)) = Fic.Path
    Next Fic
    For Each Doss In Fs.Getfolder(Dossier).subFolders
        ListeFichiers Doss.Path & "\", NomFic
    Next Doss
End Sub

Oups, la version précédente marche pour Excel

pour des documents Word :

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
Dim ListeFic() As String, Fs
 
 
Sub SansMDP()
Dim i As Long, Doc As Document
    ReDim ListeFic(1 To 1)
    Set Fs = CreateObject("Scripting.FileSystemObject")
    ListeFichiers "C:\Users\toto\test\", "*.doc*"
    If ListeFic(UBound(ListeFic)) = "" Then ReDim Preserve ListeFic(1 To UBound(ListeFic) - 1)
    For i = LBound(ListeFic) To UBound(ListeFic)
        Set Doc = Documents.Open(FileName:=ListeFic(i), PasswordDocument:="toto")
        'If Doc.ProtectionType <> wdNoProtection Then Doc.Unprotect
        Doc.EncryptionProvider = ""
        Doc.Password = ""
        Doc.SaveAs FileName:=ListeFic(i), Password:=""
        Doc.Close False
    Next i
    Set Fs = Nothing
    MsgBox UBound(ListeFic) & " fichiers traités"
End Sub
 
Sub ListeFichiers(Dossier As String, NomFic As String)
Dim Fic, Doss
    For Each Fic In Fs.Getfolder(Dossier).Files
        If ListeFic(UBound(ListeFic)) <> "" Then ReDim Preserve ListeFic(1 To UBound(ListeFic) + 1)
        If Fic.Name Like NomFic Then ListeFic(UBound(ListeFic)) = Fic.Path
    Next Fic
    For Each Doss In Fs.Getfolder(Dossier).subFolders
        ListeFichiers Doss.Path & "\", NomFic
    Next Doss
End Sub