Selection de paragraphe par titre ou numero

**hedidev1** · 19/03/2015, 19h35

Bonjour, le probleme avec mon programme est que il ne trouve pas certains titre de paragraphes.

Au fait ceux qu'il trouve quand je suis sur le doc word sur le titre juste apres le numero et que je saute une ligne le numero reste en haut une ligne et sauté avec le titre et un numero s'insere avant. Quand il ne trouve pas et que je fait cette manip, pas de saut de ligne et le numero s'incremente.

1.2. Test

devient

1.2
1.3 Test

La ca marche

1.2 Test

devient

1.3 Test

La ca marche pas

Voici le code:

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
119
120
121
122
123
124
Public Sub Bouton_Export_Clic()
 
    Dim fso As Object
    Dim oWdApp As Object
    Dim oWdDocExp As Object
    Dim oWdDocBase As Object
    Dim oRng1 As Object
    Dim sDebut As String
    Dim sFin As String
    Dim lPage As Long
 
    'Export si le menu (Nom fichier, Chemin de destination) est bien remplit
    If Fonctions.bVerifTypeEtExistence(PATH_FILE_L, PATH_FILE_C) = True And Fonctions.bVerifTypeEtExistence(PATH_FILE_DEST_L, PATH_FILE_DEST_C) = True And Cells(SELECT_CASE_NAME_L + 1, SELECT_CASE_NAME_C) <> "" Then
        'Selection du doc de base
        If bWordIsOpen(Cells(PATH_FILE_L, PATH_FILE_C).Value) = False Then
            Set oWdApp = CreateObject("Word.Application")
            oWdApp.Visible = True
            Set oWdDocBase = oWdApp.Documents.Open(Cells(PATH_FILE_L, PATH_FILE_C).Value)
        ElseIf bWordIsOpen(Cells(PATH_FILE_L, PATH_FILE_C).Value) = True Then
            Set oWdDocBase = GetObject(Cells(PATH_FILE_L, PATH_FILE_C).Value)
        End If
        'Copie du fichier en un fichier dans lequel on va travailler
        Set fso = CreateObject("Scripting.FileSystemObject")
        fso.CopyFile Cells(PATH_FILE_L, PATH_FILE_C).Value, Cells(PATH_FILE_DEST_L, PATH_FILE_DEST_C).Value
        'Selection du doc d'export
        If Fonctions.bWordIsOpen(Cells(PATH_FILE_DEST_L, PATH_FILE_DEST_C).Value) = False Then
            Set oWdApp = CreateObject("Word.Application")
            oWdApp.Visible = True
            Set oWdDocExp = oWdApp.Documents.Open(Cells(PATH_FILE_DEST_L, PATH_FILE_DEST_C).Value)
        ElseIf Fonctions.bWordIsOpen(Cells(PATH_FILE_DEST_L, PATH_FILE_DEST_C).Value) = True Then
            Set oWdDocExp = GetObject(Cells(PATH_FILE_DEST_L, PATH_FILE_DEST_C).Value)
        End If
        'Insertion saut de paragraphes (utile pour une bonne mise en forme
        '(dans certains docs, si il n'y a rien entre un nom de paragraphe et de sous-paragraphe, la renumerotation ne fonctionne pas)
        'Parcours du tableau des paragraphes
        'For i = SELECT_CASE_NAME_L + 1 To Cells(SELECT_CASE_NAME_L + 1, SELECT_CASE_NAME_C).End(xlDown).Row
            'Si le paragraphe est selectionné et est un paragraphe (pas un sous_paragraphe)
            'If Cells(i, SELECT_CASE_C).Value = "X" And Len(Cells(i, SELECT_CASE_NUM_C)) = 1 Then
               ' sDebut = "^p" & Cells(i, SELECT_CASE_NAME_C).Value
                'oWdDocExp.Parent.Selection.HomeKey unit:=6
                'With oWdDocExp.Parent.Selection.Find
                    '.Forward = True
                   ' .ClearFormatting
                   ' .MatchWholeWord = True
                   ' .Text = sDebut
                   ' .Execute
                  '  Debug.Print .Found & "start"
               ' End With
                'oWdDocExp.Parent.Selection.Collapse Direction:=0
               ' oWdDocExp.Parent.Selection.Bookmarks.Add Name:="SS", Range:=oWdDocExp.Parent.Selection.Range
               ' oWdDocExp.Parent.Selection.InsertParagraphAfter
           ' End If
       ' Next i
       'Suppression pages avant paragraphes
        oWdDocExp.Parent.Selection.HomeKey unit:=6
        rDeb = oWdDocExp.Parent.Selection.Goto(What:=wdGoToPage, Which:=wdGoToNext, Name:=1).Start
        rFin = oWdDocExp.Parent.Selection.Goto(What:=wdGoToPage, Which:=wdGoToNext, Name:=2).Start
        oWdDocExp.Range(rDeb, rFin).Delete
        'Export paragraphes
        For i = SELECT_CASE_NAME_L + 1 To Cells(SELECT_CASE_NAME_L + 1, SELECT_CASE_NAME_C).End(xlDown).Row
            'Si le paragraphe n'est pas selectionné
            If Cells(i, SELECT_CASE_C).Value = "" Then
                'Mise en memoire du nom de paragraphe non selectionné et de celui du dessous
                sDebut = "^p" & Cells(i, SELECT_CASE_NAME_C).Value
                sFin = "^p" & Cells(i + 1, SELECT_CASE_NAME_C).Value
                'Recherche du debut de paragraphe dans le doc de base
                oWdDocExp.Parent.Selection.HomeKey unit:=6
                With oWdDocExp.Parent.Selection.Find
                    .Forward = True
                    .ClearFormatting
                    .MatchWholeWord = True
                    .Text = sDebut
                    .Execute
                    Debug.Print .Found & "start"
                End With
                'Ajout d'un signet de debut de copie
                oWdDocExp.Parent.Selection.Collapse Direction:=1
                oWdDocExp.Parent.Selection.Bookmarks.Add Name:="SS", Range:=oWdDocExp.Parent.Selection.Range
                'Recherche de la fin de paragraphe dans le doc de base
                oWdDocExp.Parent.Selection.HomeKey unit:=6
                With oWdDocExp.Parent.Selection.Find
                    .Forward = True
                    .ClearFormatting
                    .MatchWholeWord = True
                    .Text = sFin
                    .Execute
                    Debug.Print .Found & "end"
                End With
                'Ajout d'un signet de fin de copie
                oWdDocExp.Parent.Selection.Collapse Direction:=1
                oWdDocExp.Parent.Selection.Bookmarks.Add Name:="SE", Range:=oWdDocExp.Parent.Selection.Range
                'Selection du texte a supprimer
                'Si la derniere case des noms du tableau du paragraphe n'est pas vide on selectionne entre les signets
                If sFin <> "" Then
                    oWdDocExp.Range(Start:=oWdDocExp.Bookmarks("ss").Range.Start, End:=oWdDocExp.Bookmarks("se").Range.Start).Select
                'Si la derniere case des noms du tableau du paragraphe est vide on selectionne entre le signet et la fin du doc
                ElseIf sFin = "" Then
                    oWdDocExp.Range(Start:=oWdDocExp.Bookmarks("ss").Range.Start, End:=oWdDocExp.Range.End).Select
                End If
                'Suppression des paragraphes
                Debug.Print oWdDocExp.Parent.Selection.Text
                oWdDocExp.Parent.Selection.Delete
            End If
        Next i
        'Revisions enlevées
        With oWdApp.ActiveWindow.View
            .ShowRevisionsAndComments = False
            .RevisionsView = 0
        End With
        'MAJ champs (sommaire)
        For i = 1 To oWdDocExp.TablesOfContents.Count
            oWdApp.ActiveDocument.TablesOfContents(i).Update
        Next i
        'Sauvegarde
        oWdDocExp.Save
        'Fermeture doc de base
        oWdDocBase.Close savechanges:=False
        'Activation du nouveau doc
        oWdDocExp.Parent.Activate
    'Erreur si le menu n'est pas bien remplit
    ElseIf Fonctions.bVerifTypeEtExistence(PATH_FILE_L, PATH_FILE_C) = False Or Fonctions.bVerifTypeEtExistence(PATH_FILE_DEST_L, PATH_FILE_DEST_C) = False Or Cells(SELECT_CASE_NAME_L + 1, SELECT_CASE_NAME_C) = "" Then
        MsgBox "Erreur de parametrage"
    End If
End Sub

Merci pour votre aide !

**clementmarcotte** · 19/03/2015, 20h00

Bonjour,

Sans avoir essayé ni trop étudié ton code, tu pourrais utiliser/rechercher les styles de paragraphes. Les styles "tritreX" permettent de composer facilement des listes hiérarchisées.

Tous les styles utilisés dans le document sont regroupés dans la collection Styles, que l'on peut itérer et vérifier le nom.

**hedidev1** · 20/03/2015, 10h18

Bonjour, ca marche tres bien.

Nouveau probleme: le numerotation se refait pas sur tout les numeros. donc ca marche bien et un moment au lieu de passer a 2. on passe a 3.

Merci de ton aide !

(C'est assez important :s)

**hedidev1** · 20/03/2015, 16h38

Bon probleme resolu, maintenant avec ce nouveau code il n'exporte pas les entetes et si il y a 2 colonnes de texte a la derniere page du doc de base, il met 2 colonnes partout dans le doc d'export.

merci !

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
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
Public Sub Bouton_Export_Clic()
 
    Dim fso As Object
    Dim oWdApp As Object
    Dim oWdDocExp As Object
    Dim oWdDocBase As Object
    Dim oRng1 As Object
    Dim sDebut As String
    Dim sFin As String
    Dim lPage As Long
 
    'Export si le menu (Nom fichier, Chemin de destination) est bien remplit
    If Fonctions.bVerifTypeEtExistence(PATH_FILE_L, PATH_FILE_C) = True And Fonctions.bVerifTypeEtExistence(PATH_FILE_DEST_L, PATH_FILE_DEST_C) = True And Cells(SELECT_CASE_NAME_L + 1, SELECT_CASE_NAME_C) <> "" Then
        'Selection du doc de base
        If bWordIsOpen(Cells(PATH_FILE_L, PATH_FILE_C).Value) = False Then
            Set oWdApp = CreateObject("Word.Application")
            oWdApp.Visible = True
            Set oWdDocBase = oWdApp.Documents.Open(Cells(PATH_FILE_L, PATH_FILE_C).Value)
        ElseIf bWordIsOpen(Cells(PATH_FILE_L, PATH_FILE_C).Value) = True Then
            Set oWdDocBase = GetObject(Cells(PATH_FILE_L, PATH_FILE_C).Value)
        End If
        'Copie du fichier en un fichier dans lequel on va travailler
        Set fso = CreateObject("Scripting.FileSystemObject")
        fso.CopyFile Cells(PATH_FILE_L, PATH_FILE_C).Value, Cells(PATH_FILE_DEST_L, PATH_FILE_DEST_C).Value
        'Selection du doc d'export
        If Fonctions.bWordIsOpen(Cells(PATH_FILE_DEST_L, PATH_FILE_DEST_C).Value) = False Then
            Set oWdApp = CreateObject("Word.Application")
            oWdApp.Visible = True
            Set oWdDocExp = oWdApp.Documents.Open(Cells(PATH_FILE_DEST_L, PATH_FILE_DEST_C).Value)
        ElseIf Fonctions.bWordIsOpen(Cells(PATH_FILE_DEST_L, PATH_FILE_DEST_C).Value) = True Then
            Set oWdDocExp = GetObject(Cells(PATH_FILE_DEST_L, PATH_FILE_DEST_C).Value)
        End If
        'Mise a 0 du doc d'export
        oWdDocExp.Range(0, 0).Select
        oWdDocExp.Parent.Selection.MoveEnd wdStory
        oWdDocExp.Parent.Selection.Delete
 
        'Mise en page 1 colonne (se met automatiquement sur certains docs a 2 colonnes)
        'With owdDocExp.Parent.Selection.PageSetup.TextColumns
          '  .SetCount NumColumns:=1
          '  .EvenlySpaced = True
          '  .LineBetween = False
         'End With
        'oWdDocBase.Parent.Selection.EndKey unit:=6
        'lPage = oWdDocBase.Parent.Selection.Information(3)
        'For i = 1 To lPage
        'owdDocExp.Parent.Selection.InsertNewPage
        'Next i
        'Trouver page 1er paragraphe
        sDebut = Cells(SELECT_CASE_NAME_L + 1, SELECT_CASE_NAME_C).Value
        oWdDocBase.Parent.Selection.HomeKey unit:=6
        With oWdDocBase.Parent.Selection.Find
            .Forward = True
            .ClearFormatting
            .MatchWholeWord = True
            .Text = sDebut
            .Style = oWdDocBase.Styles(Cells(SELECT_CASE_STYL_L + 1, SELECT_CASE_STYL_C).Value)
            .Execute
            Debug.Print .Found & "start"
        End With
       'Copier/coller pages avant paragraphes (sauf table)
        lPage = oWdDocBase.Parent.Selection.Information(3)
        oWdDocBase.Parent.Selection.HomeKey unit:=6
        rdeb = oWdDocBase.Parent.Selection.Goto(What:=1, which:=2, Name:=2).Start
        rFin = oWdDocBase.Parent.Selection.Goto(What:=1, which:=2, Name:=lPage).Start
        oWdDocBase.Range(rdeb, rFin).Copy
        oWdDocExp.Parent.Selection.HomeKey unit:=6
        oWdDocExp.Parent.Selection.Paste
        'Export paragraphes
        For i = SELECT_CASE_NAME_L + 1 To Cells(SELECT_CASE_NAME_L + 1, SELECT_CASE_NAME_C).End(xlDown).Row
            'Si le paragraphe est selectionné
            If Cells(i, SELECT_CASE_C).Value = "X" Then
                'Mise en memoire du nom de paragraphe selectionné et de celui du dessous
                sDebut = Cells(i, SELECT_CASE_NAME_C).Value
                sFin = Cells(i + 1, SELECT_CASE_NAME_C).Value
                'Recherche du debut de paragraphe dans le doc de base
                oWdDocBase.Parent.Selection.HomeKey unit:=6
                With oWdDocBase.Parent.Selection.Find
                    .Forward = True
                    .ClearFormatting
                    .MatchWholeWord = True
                    .Text = sDebut
                    .Style = oWdDocBase.Styles(Cells(i, SELECT_CASE_STYL_C).Value)
                    .Execute
                    Debug.Print .Found & "start"
                End With
                'Ajout d'un signet de debut de copie
                oWdDocBase.Parent.Selection.Collapse Direction:=1
                oWdDocBase.Parent.Selection.Bookmarks.Add Name:="SS", Range:=oWdDocBase.Parent.Selection.Range
                'Recherche de la fin de paragraphe dans le doc export
                If sFin <> "" Then
                    oWdDocBase.Parent.Selection.HomeKey unit:=6
                    With oWdDocBase.Parent.Selection.Find
                        .Forward = True
                        .ClearFormatting
                        .MatchWholeWord = True
                        .Text = sFin
                        .Style = oWdDocBase.Styles(Cells(i + 1, SELECT_CASE_STYL_C).Value)
                        .Execute
                        Debug.Print .Found & "end"
                    End With
                    'Ajout d'un signet de fin de copie
                    oWdDocBase.Parent.Selection.Collapse Direction:=1
                    oWdDocBase.Parent.Selection.Bookmarks.Add Name:="SE", Range:=oWdDocBase.Parent.Selection.Range
                End If
                'Selection du texte
                'Si la derniere case des noms du tableau du paragraphe n'est pas vide on selectionne entre les signets
                If sFin <> "" Then
                    oWdDocBase.Range(Start:=oWdDocBase.Bookmarks("ss").Range.Start, End:=oWdDocBase.Bookmarks("se").Range.Start).Select
                'Si la derniere case des noms du tableau du paragraphe est vide on selectionne entre le signet et la fin du doc
                ElseIf sFin = "" Then
                    oWdDocBase.Range(Start:=oWdDocBase.Bookmarks("ss").Range.Start, End:=oWdDocBase.Range.End).Select
                End If
                'Copie/colle
                Debug.Print oWdDocBase.Parent.Selection.Text
                oWdDocBase.Parent.Selection.Copy
                oWdDocExp.Parent.Selection.EndKey unit:=6
                oWdDocExp.Parent.Selection.Paste
            End If
        Next i
        'Revisions enlevées
        With oWdApp.ActiveWindow.View
            .ShowRevisionsAndComments = False
            .RevisionsView = 0
        End With
        'MAJ champs
        For i = 1 To oWdDocExp.TablesOfContents.Count
            oWdApp.ActiveDocument.TablesOfContents(i).Update
        Next i
        'Mise a jour styles
        For i = SELECT_CASE_NAME_L + 1 To Cells(SELECT_CASE_NAME_L + 1, SELECT_CASE_NAME_C).End(xlDown).Row
            'Si le paragraphe est selectionné
            If Cells(i, SELECT_CASE_C).Value = "X" Then
                'Mise en memoire du nom de paragraphe
                sDebut = Cells(i, SELECT_CASE_NAME_C).Value
                sFin = Cells(i, SELECT_CASE_NAME_C).Value
                'Recherche du debut de paragraphe dans le doc de base
                oWdDocExp.Parent.Selection.HomeKey unit:=6
                With oWdDocExp.Parent.Selection.Find
                    .Forward = True
                    .ClearFormatting
                    .MatchWholeWord = True
                    .Text = sDebut
                    .Style = oWdDocExp.Styles(Cells(i, SELECT_CASE_STYL_C).Value)
                    .Execute
                    Debug.Print .Found & "start"
                End With
                'Ajout d'un signet de debut de copie
                oWdDocExp.Parent.Selection.Collapse Direction:=1
                oWdDocExp.Parent.Selection.Bookmarks.Add Name:="SS", Range:=oWdDocExp.Parent.Selection.Range
                'Recherche de la fin de paragraphe dans le doc de base
                If sFin <> "" Then
                    oWdDocExp.Parent.Selection.HomeKey unit:=6
                    With oWdDocExp.Parent.Selection.Find
                        .Forward = True
                        .ClearFormatting
                        .MatchWholeWord = True
                        .Text = sFin
                        .Style = oWdDocExp.Styles(Cells(i, SELECT_CASE_STYL_C).Value)
                        .Execute
                        Debug.Print .Found & "end"
                    End With
                    'Ajout d'un signet de fin de copie
                    oWdDocExp.Parent.Selection.Collapse Direction:=0
                    oWdDocExp.Parent.Selection.Bookmarks.Add Name:="SE", Range:=oWdDocExp.Parent.Selection.Range
                End If
                'Selection du texte
                'Si la derniere case des noms du tableau du paragraphe n'est pas vide on selectionne entre les signets
                If sFin <> "" Then
                    oWdDocExp.Range(Start:=oWdDocExp.Bookmarks("ss").Range.Start, End:=oWdDocExp.Bookmarks("se").Range.Start).Select
                'Si la derniere case des noms du tableau du paragraphe est vide on selectionne entre le signet et la fin du doc
                ElseIf sFin = "" Then
                    oWdDocExp.Range(Start:=oWdDoWdDocExpocBase.Bookmarks("ss").Range.Start, End:=oWdDocExp.Range.End).Select
                End If
                oWdDocExp.Parent.Selection.Style = (oWdDocExp.Styles(Cells(i, SELECT_CASE_STYL_C).Value))
            End If
        Next i
        'Entetes pieds
        'Sauvegarde
        oWdDocExp.Save
        'Fermeture doc de base
        oWdDocBase.Close savechanges:=False
        'Activation du nouveau doc
        oWdDocExp.Parent.Activate
    'Erreur si le menu n'est pas bien remplit
    ElseIf Fonctions.bVerifTypeEtExistence(PATH_FILE_L, PATH_FILE_C) = False Or Fonctions.bVerifTypeEtExistence(PATH_FILE_DEST_L, PATH_FILE_DEST_C) = False Or Cells(SELECT_CASE_NAME_L + 1, SELECT_CASE_NAME_C) = "" Then
        MsgBox "Erreur de parametrage"
    End If
End Sub

Selection de paragraphe par titre ou numero

VBA Word

Discussions similaires

Partager

Partager