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 |
Partager