Discussion :

[article50]

Bonjour,
Présentation :
J'ai un énorme répertoire remplis de pleins de trucs dont pleins de fichiers.doc
Beaucoup de ces fichiers.doc contiennent des formulaires et modules qui ne me sont plus utiles et prennent de la place..

Ce serait vraiment très audacieux de parvenir à créer un code qui fonctionnerait comme suit :
Dans un répertoire donné (dossiers, sous-dossiers) :
- trouver tous les fichiers.doc
- en ouvrir un (le premier),
- supprimer les formulaires, modules, ..
- le sauvegarder,
- ouvrir le suivant,
- idem, etc.

Actuellement je gère ça au coup par coup comme ceci (trouvé d'ailleurs sur ce site) :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Dim LeDoc As Document, MotdePasse As String
Set LeDoc = ThisDocument
MotdePasse = "toto"
UnprotectVBProject LeDoc, MotdePasse
 
For Each VbComp In ThisDocument.VBProject.VBComponents
        Select Case VbComp.Type
            Case 1 To 3
                ThisDocument.VBProject.VBComponents.Remove VbComp
            Case Else
                With VbComp.CodeModule
                .DeleteLines 1, .CountOfLines
                End With
        End Select
    Next VbComp

J'ignore si c'est réalisable. En tous cas, je l'espère et donc merci d'avance pour votre aide précieuse!

[Souriane]

Bonjour,

Voici le code que j'utilise quand je veux effectuer une tâche sur les documents d'un répertoire.

Tu n'as qu'à l'adapter!

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Public Sub ActionSurTousLesFichiersRepertoire()
 
'Changer le répertoire sous "PathToUse
 
Application.ScreenUpdating = True
 
Dim myFile As String
Dim PathToUse As String
Dim myDoc As Document
Dim Response As Long
 
PathToUse = "c:\temp\"    'Changer ici le répertoire
 
'Error handler to handle error generated whenever
'the FindReplace dialog is closed
 
On Error Resume Next
 
'Close all open documents before beginning
 
Documents.Close SaveChanges:=wdPromptToSaveChanges
 
 
myFile = Dir$(PathToUse & "*.doc*")     'Ici, indique de traiter tous les document .doc, donc ça inclus les docx, docm, etc.  Modifier au goût.
 
While myFile <> ""
 
WordBasic.DisableAutoMacros 1   'Disables auto macros
 
    'Open document
        Set myDoc = Documents.Open(PathToUse & myFile)
 
 
 
'Procédure à exécuter ici:
   '[INSÉRER LE CODE À EXÉCUTER POUR CHAQUE DOCUMENT]
 
    'Next file in folder
 
    myFile = Dir$()
 
Wend
 
WordBasic.DisableAutoMacros 0   'Enables auto macros
 
    On Error GoTo 0 ' resume normal error handling
 
End Sub

Bonne chance!

Souriane

[article50]

merci pour la réponse. J'ai avancé un peu

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub AllégerFichiers()
 
Dim sPath As String, sFilename As String
Dim objWord As New Word.Application
Dim WordDoc As Word.Document
 
Application.ScreenUpdating = False
 
sPath = "C:\temp\"
 
sFilename = Dir(sPath & "*.doc*")
 
Do While Len(sFilename) > 0
 
    Set WordDoc = objWord.Documents.Open(sPath & sFilename)
    objWord.Visible = True
    objWord.Activate
 
 
UnprotectVBProject WordDoc, "toto"
 
For Each VbComp In WordDoc.VBProject.VBComponents
        Select Case VbComp.Type
            Case 1 To 3
                WordDoc.VBProject.VBComponents.Remove VbComp
            Case Else
                With VbComp.CodeModule
                .DeleteLines 1, .CountOfLines
                End With
        End Select
    Next VbComp
 
WordDoc.Close True
 
sFilename = Dir
 
Loop
 
Application.ScreenUpdating = True
objWord.Quit
 
End Sub

J'ai fait des tests concluants mais la ligne :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

UnprotectVBProject WordDoc, "toto"

me renvoie une erreur de compilation "Sub ou Fonction non définie"...

merci pour votre aide!

[Invité]

Bonjour,

UnprotectVBProject est une fonction. Elle permet de simuler les touches correspondant à la chaîne du mot de passe. Cette fonction est-elle présente dans un de vos modules ?

Par ailleurs "Toto" est le mot de passe du / des documents. Dans votre code, cela suppose que tous vos documents ont le même mot de passe.

[article50]

"Toto" est le mot de passe du / des documents. Dans votre code, cela suppose que tous vos documents ont le même mot de passe.

Oui c'est correct!

UnprotectVBProject est une fonction. Elle permet de simuler les touches correspondant à la chaîne du mot de passe. Cette fonction est-elle présente dans un de vos modules ?

Grâce à votre observation, j'ai rajouté ceci :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
Public Sub UnprotectVBProject(Wdc As Document, ByVal Pwd As String)
 
Dim vbProj As Object
Set vbProj = Wdc.VBProject
If vbProj.Protection <> 1 Then Exit Sub
Set Application.VBE.ActiveVBProject = vbProj
SendKeys Pwd & "~~"
Application.VBE.CommandBars(1).FindControl(ID:=2578, recursive:=True).Execute
 
End Sub

Maintenant quand je lance la macro, Word 2013 "cesse de fonctionner" et me propose des récupérations de fichiers

[Invité]

Cette fonction ne semble pas complète :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
Function UnprotectVBProject(WB As Document, ByVal Password As String) As Boolean
Dim vbProj As VBProject
 
Set vbProj = WB.VBProject
 
'Inutile si le projet est déjà déprotégé
If vbProj.Protection <> 1 Then
    UnprotectVBProject = True
    Set vbProj = Nothing
    Exit Function
Else
 
    Set Application.VBE.ActiveVBProject = vbProj
    'vbproj.Collection
    'Saisie du mot de passe avec SendKeys, {ESC} sort de la fenêtre de saisie du mot de passe
    SendKeys Password & "~~" & "{ESC}"
    Application.VBE.CommandBars(1).FindControl(ID:=2578, recursive:=True).Execute
    If vbProj.Protection <> 1 Then
        UnprotectVBProject = True
    Else
        'Password n'est pas le bon
        UnprotectVBProject = False
        SendKeys "%{F11}", True
    End If
End If
End Function

Dans ma version, elle nécessite de cocher la référence Microsoft Visual Basic For Application Extensibility 5.3 (ou autre version pour 2013, je suis sur 2010)

Par ailleurs, dans votre code principal, il vous faudra sans doute mettre un

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

DoEvents

après cette fonction.

[clementmarcotte]

Bonjour,

Si tu n'as pas besoin de rouvrir tes fichiers doc avec Word 2003 ou un Word précédent, un moyen simple de te débarrasser des macros c'est, du moins en théorie, d'enregistrer tes documents en docx, avec saveas.

[article50]

Eric KERGRESSE

Merci bcp pour le code complété. Mais voilà, rien n'y fait.. Word crash systématiquement Voici ce qu'il m'indique comme info :

Informations supplémentaires sur le problème :
LCID: 1036
Brand: Office11Crash
skulcid: 1036

Certainement dû aux Senkeys je suppose. Je sens que je vais capituler ..

[article50]

Bonjour Eric, Clément, Souriane,
Merci encore une fois pour vos messages très utiles.
Voici le code que j'utilise pour recréer mes fichiers .doc sans macros. Il fonctionne!

Pouvez-vous m'aider à l'adapter de manière à ce qu'il traite aussi les sous-dossiers ?

Bon dimanche

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
 
Sub FichiersSansMacros()
 
Dim sPath As String, sFilename As String
Dim objWord As New Word.Application
Dim WordDoc As Word.Document
Application.ScreenUpdating = False
 
sPath = "C:\temp\"
 
sFilename = Dir(sPath & "*.doc*")
 
Do While Len(sFilename) > 0
 
    Set WordDoc = objWord.Documents.Open(sPath & sFilename)
    objWord.Visible = True
 
    objWord.Selection.WholeStory
    objWord.Selection.Copy
    Documents.Add DocumentType:=wdNewBlankDocument
    Selection.PasteAndFormat (wdPasteDefault)
 
    Call PressePapier
    WordDoc.Close True
 
Dim oFSO As Scripting.FileSystemObject
Dim oFl As Scripting.File
Set oFSO = New Scripting.FileSystemObject
      oFSO.DeleteFile sPath & sFilename, False
 
    ChangeFileOpenDirectory sPath
    ActiveDocument.SaveAs FileName:=sPath & Left(sFilename, Len(sFilename) - 3) & "doc"
    ActiveDocument.Close
 
sFilename = Dir
 
Loop
 
Application.ScreenUpdating = True
objWord.Quit
 
End Sub
 
Private Sub PressePapier()
    OpenClipboard 0
    EmptyClipboard
    CloseClipboard
End Sub

[Invité]

Bonjour,

Il est inutile de créer une nouvelle session Word. Un exemple de traitement récursif :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
Sub FichiersSansMacros()
 
Dim fso As New Scripting.FileSystemObject
Dim Dossier As Folder
Dim SousRep As Folder
Dim sPath As String, sFilename As String
Dim WordDoc As Document
 
 
        sPath = "C:\Users\......"
 
        Set Dossier = fso.GetFolder(sPath)
        ' Application.ScreenUpdating = False
 
        ' Traitement récursif des sous dossiers
        For Each SousRep In Dossier.SubFolders
 
             sFilename = Dir$(SousRep.Path & "\*.doc*")
 
             Do While sFilename <> ""
 
                 Set WordDoc = Documents.Open(SousRep.Path & "\" & sFilename)
                 MsgBox "Sous répertoire en cours : " & SousRep.Name &  Chr(10)  &  "Chemin sous répertoire : " & SousRep.Path & Chr(10) &  "Document en cours : " & WordDoc.Name
                 WordDoc.Close True
                 Set WordDoc = Nothing
                 sFilename = Dir
 
             Loop
 
        Next SousRep
        'Application.ScreenUpdating = True
 
       Set Dossier = Nothing
       Set fso = Nothing
 
End Sub

[article50]

Merci beaucoup Eric KERGRESSE! Je suis arrivé à mon but et j'ai appris de nouvelles choses grâce à ton aide.