logiciel pour changer les mots de passe office

[matsch77]

Bonjour,

je suis a la recherche d'un logiciel qui pourrait m'aider a changer le mot de passe de plusieurs fichiers Word/Excel/Powerpoint (plus de 8000 dans mes archives)
Les mots de passe ont change... je les connais tous mais j'aimerais qu'ils soient tous changes pour le nouveau.

Est-ce que vous connaissez un tel logiciel?

Merci beaucoup

@++

Matsch

[Heureux-oli]

Salut,
Point besoin de logiciel, VBA devrait pouvoir le faire.

Pour Word,

Code :

1
2
3
4
Documents.Open (FileName:= "" , Passwordocument:="Ancien mot de passe")
Document.PassWord = "Nouveau mot de passe"
Document.Save
Document.Close

Il faut faire une boucle sur les fichiers

http://warin.developpez.com/access/fichiers/

Et pareil pour les autres formats de fichiers.

[Heureux-oli]

Salut,

Apres quelques tests :

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
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
60
61
62
63
64
Option Explicit
Dim xlApp As New Excel.Application

Sub Document_Open()
'Déclaration des variables
Dim oFSO As FileSystemObject
Dim oFol As Folder
Dim oFil As File
Dim oDlg As FileDialog

'Affectation des objets
Set oFSO = New FileSystemObject
Set oDlg = Application.FileDialog(msoFileDialogFolderPicker)
oDlg.Show

Set oFol = oFSO.GetFolder(oDlg.SelectedItems(1))
'Boucle sur les fichiers du répertoire
For Each oFil In oFol.Files
Debug.Print Mid(oFil.Name, InStr(1, oFil.Name, ".") + 1)
Select Case Mid(oFil.Name, InStr(1, oFil.Name, ".") + 1)
'Si c'est un document Word
Case "docm" Or "docx" Or "doc"
PWDDocument oFil.Path
'Si c'est un fichier Excel
Case "xlsx" Or "xlsm" Or "xls"

End Select
'Debug.Print oFil.Path
Next oFil
Set oFol = Nothing
Set oFSO = Nothing
Set oDlg = Nothing



End Sub

Sub PWDDocument(myDocpath As String)
Dim oDoc As Document

Set oDoc = Documents.Open(FileName:=myDocpath, passworddocument:="")
With oDoc
    .Password = ""
    .Save
    .Close
End With
Set oDoc = Nothing

End Sub

Sub PWDExcelFile(myWBPath As String)
Dim oWB As Workbook

Set oWB = Workbooks.Open(FileName:=myWBPath, Password:="")
With oWB
    .Password = ""
    .Save
    .Close
End With
Set oWB = Nothing


End Sub

Il faut ajouter au projet

La référence à Microsoft Scripting Runtime
La référence à Excel en partant du principe que le code est éxécuté au départ de Word.

[matsch77]

Merci a toi Heureux Oli !


Je vais tester ca et je te donne mon feed back ce WE

@++

Matsch

[matsch77]

Salut

desole du retard j'ai pas trop acces a Internet:
voici ma solution... vous pouvez l'adpatez... :-)

quelques changements: l'extraction de l'extension ne fonctionnait pas donc je l'ai changer et j'ai ajouter pour Excel

Encore merci Heureux Oli :-)

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
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
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
Option Explicit
Dim xlApp As New Excel.Application
Dim nChanged As Integer
Dim sLogFile As String


Sub Document_Open()
    'Déclaration des variables
    Dim oFSO As FileSystemObject
    Dim oFol As Folder
    Dim oFil As File
    Dim oDlg As FileDialog
    Dim oDoc As Document
    sLogFile = "D:\log.txt"
    'Affectation des objets
    nChanged = 0
    Set oFSO = New FileSystemObject
    Set oDlg = Application.FileDialog(msoFileDialogFolderPicker)
    oDlg.Show
    
    Set oFol = oFSO.GetFolder(oDlg.SelectedItems(1))
    If oFSO.FileExists(sLogFile) Then
        oFSO.DeleteFile sLogFile, False
    End If
    ' recursive sur les dossiers
    Explorer (oFol)
    If oFSO.FileExists(sLogFile) Then
        Set oDoc = Documents.Open(sLogFile)
    End If
    MsgBox "End of process. M@tsch. number changed: " + Str(nChanged)
    
    Set oFol = Nothing
    Set oFSO = Nothing
    Set oDlg = Nothing
    Set oDoc = Nothing
End Sub

Sub PWDDocument(myDocpath As String)
Dim oDoc As Document
Dim intFic As Integer
On Error GoTo err
    Set oDoc = Documents.Open(FileName:=myDocpath, passworddocument:="password1", WritePasswordDocument:="password1")
    If oDoc.HasPassword = True Then
        With oDoc
            .Password = "NouveauPassword"
            .Save
        End With
        nChanged = nChanged + 1
    End If
    oDoc.Close
    GoTo fin
SubDir:
On Error GoTo err2
    Set oDoc = Documents.Open(FileName:=myDocpath, passworddocument:="password2", WritePasswordDocument:="password2")
    If oDoc.HasPassword = True Then
        With oDoc
            .Password = "NouveauPassword"
            .Save
        End With
        nChanged = nChanged + 1
    End If
        oDoc.Close
    GoTo fin
SubDir2:
' pour trouver si le fichier est vraiment avec un password inconnu
On Error GoTo err3
    Set oDoc = Documents.Open(FileName:=myDocpath, passworddocument:="NouveauPassword", WritePasswordDocument:="NouveauPassword")
    oDoc.Close
    GoTo fin
fin:
    Set oDoc = Nothing
    Exit Sub
err:
    Select Case err.Number
    'wrong password
       Case 5408: Resume SubDir
    Case Else:
        MsgBox "Erreurinconnue: " + myDocpath
        Resume fin
    End Select
err2:
    Select Case err.Number
    'wrong password
       Case 5408: Resume SubDir2
    Case Else:
        MsgBox "Erreurinconnue: " + myDocpath
        Resume fin
    End Select
err3:
    intFic = FreeFile
    Open sLogFile For Append As intFic
    Print #intFic, "Other password: " + myDocpath
    Close intFic
    Resume fin
End Sub


Sub PWDExcelFile(myWBPath As String)
    Dim oWB As Workbook
    Dim intFic As Integer
    'xlApp.AutomationSecurity = msoAutomationSecurityForceDisable
    xlApp.AutomationSecurity = msoAutomationSecurityLow
    On Error GoTo err
        Set oWB = Workbooks.Open(FileName:=myWBPath, UpdateLinks:=2, Password:="password1", WriteResPassword:="password1", IgnoreReadOnlyRecommended:=True)
        If oWB.HasPassword = True Then
            With oWB
                .Password = "NouveauPassword"
                .Save
            End With
            nChanged = nChanged + 1
        End If
        oWB.Close SaveChanges:=True
        GoTo fin
SubDir:
    On Error GoTo err2
        Set oWB = Workbooks.Open(FileName:=myWBPath, UpdateLinks:=2, Password:="password2", WriteResPassword:="password2", IgnoreReadOnlyRecommended:=True)
        If oWB.HasPassword = True Then
            With oWB
                .Password = "NouveauPassword"
                .Save
            End With
            nChanged = nChanged + 1
        End If
        oWB.Close SaveChanges:=True
        GoTo fin
SubDir2:
    ' pour trouver si le fichier est vraiment avec un password inconnu
    On Error GoTo err3
        Set oWB = Workbooks.Open(FileName:=myWBPath, UpdateLinks:=2, Password:="NouveauPassword", WriteResPassword:="NouveauPassword", IgnoreReadOnlyRecommended:=True)
        oWB.Close SaveChanges:=True
        GoTo fin
fin:
        Set oWB = Nothing
        Exit Sub
err:
        Select Case err.Number
        'wrong password
           Case 1004: Resume SubDir
        Case Else:
            MsgBox "Erreurinconnue: " + myWBPath
            Resume fin
        End Select
err2:
        Select Case err.Number
        'wrong password
           Case 1004: Resume SubDir2
        Case Else:
            MsgBox "Erreurinconnue: " + myWBPath
            Resume fin
        End Select
err3:
        intFic = FreeFile
        Open sLogFile For Append As intFic
        Print #intFic, "Other password: " + myWBPath
        Close intFic
        Resume fin
End Sub

Sub Explorer(p_strCheminDepart As String, Optional p_oFld As Scripting.Folder)
On Error GoTo err
    Dim oFSO As Scripting.FileSystemObject
    Dim oFld As Scripting.Folder
    Dim oFil As File
    Dim sStr, sStr2, sStr3, sExt
    If p_oFld Is Nothing Then
        'Instanciation du FSO
        Set oFSO = New Scripting.FileSystemObject
        'Accèdeaurépertoiredudépartderecherche
        Set p_oFld = oFSO.GetFolder(p_strCheminDepart)
    End If
   ' Boucle sur tous les fichiers
    For Each oFil In p_oFld.Files
    
    'retrouve l'extension du fichier meme si plusieurs point dans le titre
    sStr = Mid(oFil.Name, InStr(1, oFil.Name, ".") + 1)
    sStr2 = Mid(sStr, InStr(1, sStr, ".") + 1)
    sStr3 = Mid(sStr2, InStr(1, sStr2, ".") + 1)
    sExt = Mid(sStr3, InStr(1, sStr3, ".") + 1)
    'Debug.Print sExt
        
    'Debug.Print oFSO.GetExtensionName(oFil.Name)
    'Select Case Mid(oFil.Name, InStr(1, oFil.Name, ".") + 1)
    Select Case sExt
        'Si c'est un document Word
        ''Case "docm" Or "docx" Or "doc"
        Case "doc"
            PWDDocument (oFil.Path)
        Case "DOC"
            PWDDocument (oFil.Path)

        'Si c'est un fichier Excel
        ''Case "xlsx" Or "xlsm" Or "xls"
        Case "xls"
            PWDExcelFile (oFil.Path)
        Case "XLS"
            PWDExcelFile (oFil.Path)
    End Select
    'Debug.Print oFil.Path
    Next oFil
SubDir:
    'Explore les sous-dossiers
    For Each oFld In p_oFld.SubFolders
        Explorer p_strCheminDepart, oFld
        DoEvents
    Next oFld
fin:
    Exit Sub
err:
    Select Case err.Number
        Case 53: Resume SubDir
        Case Else:
        MsgBox "Erreurinconnue"
        Resume fin
    End Select
Set oFSO = Nothing
Set oFld = Nothing
Set oFil = Nothing
Set sStr = Nothing
Set sStr2 = Nothing
Set sStr3 = Nothing
Set sExt = Nothing
End Sub