Discussion :

[marot_r]

Bonjour à tous, merci de votre temps et de votre aide.

J'ai utilisé le code situé ici : http://www.developpez.net/forums/d60...doc-principal/ 2ième version qui permet de trouver tous les paragraphes qui contiennent un mot particulier et d'en faire la liste dans un document.

Ce code fonctionne très bien mais pour une raison que je ne comprend pas l'exécution semble se mettre en boucle infinie. Ce n'est apparament pas un problème avec le code ni avec le doc fouilé car tout s'exécute bien si on passe en pas à pas.

Le code parcours une bonne partie de mes documents puis d'un coup la CPU monte à 100% et le Word qui contient les résultats et fait la recherche reste gelé la. Il n'a réaction au [Ctrl][Break] et la seule méthode et de demander la fermeture avec le menu contextuel.

Cela viendrait-il de la sauvegarde automatique du document courant ?

Quelqu'un a-t-il déjà rencontré ce problème ?

A+

[Heureux-oli]

Salut,

Je propose qu'on fasse plus simple.

Que possèdes tu et quel résultat souhaites-tu obtenir ?

si c'est rechercher les mots dans un texte pour renvoyer les paragraphes, on peut utiliser la fonction Find de Word qui est puissante et ne consomme pas trop de ressources.

[marot_r]

OK mais j'ai très peu de connaissances en VBA Word (ma spécialité c'est Microsoft Access).

Ce que j'ai : 5 répertoires avec une cinquantaine de Word chacun.

Ce que je veux : la liste de tous les fichiers qui contiennent le caractère "\" et la ligne ou le paragraphe qui le contient. (Je cherche tous les chemins d'accès mentionnés dans mes documents Word).

Donc ce que j'avais obtenu avec le post mentionné ci dessus me convenait :

Pour chaque document :

• Le nom du fichier (comme un hyperlien)
• La liste des paragraphes contenant le "\" au sein de ce document

Ce qui est étrange c'est qu'en pas à pas le code fonctionne parfaitement et qu'en automatique l'éxécuteur se met en boucle au bout d'un certain temps.

A+

[marot_r]

Juste pour info, je confirme que le document où l'appli se met en boucle n'y est pour rien. Si je ne traite que celui-ci le code s'exécute parfaitement.

A+

[marot_r]

Je ne comprends toujours pas d'où cela vient mais voici une version qui produit un fichier texte.

Inspiré du code posté par ouskel'n'or ici : http://www.developpez.net/forums/d60...doc-principal/.

Attention nécessite une référence sur Microsoft Forms pour récupérer le contenu du clipboard (explication ici : http://word.mvps.org/FAQs/MacrosVBA/...eClipboard.htm).

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
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
Option Explicit
 
Private Sub Appel()
Dim Chemin$, Tablo As Variant, LeMot$
    Chemin = "C:\CGI\DocProdRapport\Commercial\"
    If Not Dir(Chemin) <> "" Then
        MsgBox "Répertoire inexistant"
        Exit Sub
    End If
    Dim appWd As Word.Application
 
    Set appWd = CreateObject("Word.Application")
    appWd.Visible = True
    LeMot = "\" 'InputBox("Saisir le mot à chercher", "RECHERCHE", "Options")
    'CreateObject("Wscript.shell").Popup "Minute papillon, je bosse !", 1, "PATIENCE, ÇA VIENT !"
 
    If Trim(LeMot) <> "" Then
        Call Lister(appWd, Chemin, LeMot)
    End If
 
    appWd.Quit
    Set appWd = Nothing
    MsgBox "èf' I... FI, èn' i... NI c'est  FINI !"
End Sub
 
'Liste les fichiers (*.doc) du répertoire
Private Sub Lister(prmAppWd As Word.Application, Chemin As String, LeMot As String)
    Dim nomFicResult As String: nomFicResult = Chemin & ThisDocument.Name
    nomFicResult = Replace(nomFicResult, ".doc", ".txt")
    Dim numFicResult As Long: numFicResult = FreeFile()
    Open nomFicResult For Output As numFicResult
 
    Dim NomFich As String
    Dim LeDoc As Document
    NomFich = Dir(Chemin & "*.doc")
    'Vérification de l'existence de fichiers dans le répertoire
    If NomFich = "" Then
        MsgBox "Aucun fichier dans le répertoire " & Chemin
        Exit Sub
    End If
 
    'Ouverture des fichiers du répertoire
    Do While NomFich <> ""
        ThisDocument.Save
        Debug.Print NomFich
 
        If Chemin & NomFich <> ThisDocument.FullName Then
 
            Set LeDoc = prmAppWd.Documents.Open(Chemin & NomFich)
            DoEvents
            'Lance la recherche
            Call Chercher(prmAppWd, numFicResult, LeMot, Chemin & NomFich)
            'Ferme le document objet de la recherche
            LeDoc.Close False
            Set LeDoc = Nothing
 
        End If
 
        DoEvents
 
        'Passe au fichier suivant
        NomFich = Dir
    Loop
 
    Close #numFicResult
End Sub
 
'Recherche du mot dans le fichier ouvert
Private Sub Chercher(prmAppWd As Word.Application, prmNumFicResult As Long, LeMot As String, NomComplet As String)
 
    Dim clipboard As DataObject
 
    Dim Lien As Boolean
    'Utile pour n'insérer le lien qu'une seule fois, ici avant copie des paragraphes
    Lien = True
 
    'Place en début de doc avant de lancer la recherche
    prmAppWd.Selection.HomeKey Unit:=wdStory
 
    With prmAppWd.Selection.Find
        .ClearFormatting
 
        'Début la boucle de recherche : Tant que la donnée est trouvée, on continue
        Do While .Execute(FindText:=LeMot, Forward:=True, _
                  Wrap:=wdFindStop)
 
            'Crée un lien hypertexte vers le document contenant le mot
            If Lien Then
                'Insère un saut de ligne avant de coller le lien
                Print #prmNumFicResult, String(80, "=")
                Print #prmNumFicResult, "Fichier source"
                Print #prmNumFicResult, NomComplet$
                Print #prmNumFicResult, ""
                Lien = False
            End If
 
            'renvoie en début de ligne
            prmAppWd.Selection.HomeKey Unit:=wdLine
 
            'Sélectionne le paragraphe
            prmAppWd.Selection.MoveDown Unit:=wdParagraph, Count:=1, Extend:=wdExtend
 
            'Copie le paragraphe
            prmAppWd.Selection.Copy
 
            'Colle le paragraphe dans le document principal
            Set clipboard = New DataObject
            clipboard.GetFromClipboard
            Print #prmNumFicResult, String(80, "-")
            Print #prmNumFicResult, Trim(clipboard.GetText)
            Print #prmNumFicResult, String(80, ".")
            Print #prmNumFicResult, ""
 
            prmAppWd.Selection.MoveRight Unit:=wdCharacter, Count:=1
        Loop
    End With
 
End Sub

[Heureux-oli]

Salut,

J'ai fait un code qui fonctionne.

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
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
Option Explicit
Dim oDocActif As Document
 
 
Sub ParcourirRepertoire()
'Déclaration des variables
'nécessite la référence Microsoft Scriptiing Runtime
Dim oFSO As FileSystemObject
Dim oFol As Folder
Dim oFil As File
'Déclaration d'un objet FileDialog
Dim oDLG As FileDialog
Dim stATrouver As String
 
    'entrée de la chaîne à rechercher
    stATrouver = InputBox("Entre la chaîne à rechercher", "A trouver")
    'Affectation du document actif à la variable odocactif
    Set oDocActif = ActiveDocument
 
 
    'Affectation et affichage de la boîte de dialogue
    Set oDLG = Application.FileDialog(msoFileDialogFolderPicker)
    oDLG.Show
    'Affectation de l'objet File Scripting Runtime
    Set oFSO = New FileSystemObject
    'Affectation de l'objet Folder avec le résultat de la boîte de dialogue
    Set oFol = oFSO.GetFolder(oDLG.SelectedItems(1))
    'Boucle sur les fichiers du répertoire
        For Each oFil In oFol.Files
        'On ne prend que les documents
            If Right(oFil.Name, 4) = "docm" Then
            Debug.Print oFil.Path
            'Si c'est un document
            oDocActif.Select
            Selection.EndKey unit:=wdStory
 
            Selection.Hyperlinks.Add Anchor:=Selection.Range, Address:=oFil.Path, TextToDisplay:=oFil.Path
 
            RechercheTexte oFil.Path, stATrouver
 
            End If
        Next oFil
Set oDLG = Nothing
Set oFol = Nothing
Set oFSO = Nothing
Set oDocActif = Nothing
 
 
 
 
End Sub
Function RechercheTexte(stFileName As String, stAChercher As String)
'Déclaration des variables
Dim oDocTemp As Document
Dim trv As Boolean
Dim intPara As Integer
Dim stTemp As String
    'Initialisation du booleen trv
    trv = True
    'Ouverture du document pour recherche
    Set oDocTemp = Documents.Open(stFileName)
        oDocTemp.Select
        Selection.HomeKey unit:=wdStory
                'Boucle de recherche
                Do
                With Selection.Find
                    .Text = stAChercher
                    .Forward = True
                    trv = .Execute
                    'Si la recherche est fructueuse, on enregistre le résultat
                    If trv Then
                        'Déplcement sur la sélection pour trouver le paragraphe
                        Selection.HomeKey unit:=wdStory, Extend:=wdExtend
                        intPara = Selection.Paragraphs.Count
                        stTemp = stTemp & intPara & "; "
                        Selection.Collapse direction:=wdCollapseEnd
                        Selection.MoveRight
 
 
 
                    Else
                        Exit Do
 
                    End If
 
 
 
                End With
                Loop While trv
                'Ecriture dans le document actif
                    oDocActif.Select
                    Selection.EndKey unit:=wdStory
                    Selection.TypeParagraph
                    Selection.TypeText stTemp
                    Selection.TypeParagraph
                    oDocTemp.Close
 
 
 
End Function