Contrôle de contenu et Style de word vers Excel

Bonjour,

Je me permets de faire appel à vos connaissance pour résoudre un problème sur quel je planche depuis quelques jours.

J'ai retourné la plupart des forums d'aide mais je ne parviens pas à trouver le code ou les bouts de code me permettant d'avancer.

J'ai un fichier word, ouvert, constitué de titres et de paragraphes de différents styles et d'un certain nombre de Contrôle de contenu de texte enrichi.

Cela ressemble à :

TITRE 1 (Style Titre 1)

SOUS-TITRE 1 (Style Titre 2)

Texte (Style Normal)

Contrôle de contenu de texte enrichi 1

TITRE 2 (Style Titre 1)

Contrôle de contenu de texte enrichi 2

Texte (Style Normal)

Contrôle de contenu de texte enrichi 3

Je souhaiterais pouvoir récupérer les Titres, sous-titres et les Contrôle de contenu de texte enrichi et les coller dans un fichier excel (ouvert), dans la forme suivante:

COLONNE A | COLONNE B | COLONNE C

TITRE 1 | SOUS-TITRE 1 | Contrôle de contenu de texte enrichi 1

TITRE 2 | | Contrôle de contenu de texte enrichi 2

TITRE 2 | | Contrôle de contenu de texte enrichi 3

D'après mes recherches il semble pouvoir automatiser tout cela avec une macro en utilisant les styles et les objets Contrôle de contenu de texte enrichi, mais je parviens par à faire quoi que ce soit.

Merci par avance pour votre aide.

Bonjour,

Pour commencer voici une démo : le code demande à pointer sur un doc, boucle sur les paragraphes et pour chacun affiche le style et son contenu.

Sub Recup_Styles_Word()
Dim NDF As Variant
Dim WordApp As Object, WordDoc As Object, Prgf As Object
Dim lg As Integer

    ChDrive Left(ActiveWorkbook.Path, 1)
    ChDir ActiveWorkbook.Path
    NDF = Application.GetOpenFilename
    If Not NDF = False Then
        Set WordApp = CreateObject("Word.Application")
        Set WordDoc = WordApp.Documents.Open(NDF, ReadOnly:=True)

        lg = 2
        For Each Prgf In WordDoc.Paragraphs
            With Prgf.Range
                If Len(.Text) > 2 Then
                    ActiveSheet.Range("A" & lg).Value = .Style
                    ActiveSheet.Range("B" & lg).Value = Left(.Text, Len(.Text) - 1)
                    lg = lg + 1
                End If
            End With
        Next Prgf

        WordDoc.Close
        WordApp.Application.Quit
        Set Prgf = Nothing
        Set WordDoc = Nothing
        Set WordApp = Nothing
    End If
End Sub

Pierre

20recup-styles.zip (30.49 Ko)

Bonjour Pierre,

Merci pour ton message et pour ton début de solution.

J'ai commencé à bidouiller ton code afin que ne remontent que les styles qui m’intéressent (dans l'exemple Titre 1, Titre 2 et Titre 3 ).

C'est lent mais ça fonctionne.

Sub Recup_Style_Word()
Dim NDF As Variant
Dim WordApp As Object, WordDoc As Object, Prgf As Object
Dim lg As Integer

    ChDrive Left(ActiveWorkbook.Path, 1)
    ChDir ActiveWorkbook.Path
    NDF = Application.GetOpenFilename
    If Not NDF = False Then
        Set WordApp = CreateObject("Word.Application")
        Set WordDoc = WordApp.documents.Open(NDF, ReadOnly:=True)
        lg = 2
        For Each Prgf In WordDoc.Paragraphs
            With Prgf.Range
                If Prgf.Style = "Titre 1" Or Prgf.Style = "Titre 2" Or Prgf.Style = "Titre 3" Then
                    ActiveSheet.Range("A" & lg).Value = .Style
                    ActiveSheet.Range("B" & lg).Value = Left(.Text, Len(.Text) - 1)
                    lg = lg + 1
                End If
            End With
        Next Prgf
        WordDoc.Close
        WordApp.Application.Quit
        Set Prgf = Nothing
        Set WordDoc = Nothing
        Set WordApp = Nothing
    End If
End Sub

Me reste à trouver comment extraire les Contrôles de contenu, puis à trouver la manière de les ranger comme je souhaite dans Excel

(Colonne A - Titre 1, Colonne B - Titre 2,...)

Merci encore Pierre.

Tu peux essayer un truc du genre :

Sub Recup_Styles_Word()
Dim NDF As Variant
Dim WordApp As Object, WordDoc As Object, Prgf As Object, Ctrl As Object
Dim lg As Integer

    ChDrive Left(ActiveWorkbook.Path, 1)
    ChDir ActiveWorkbook.Path
    NDF = Application.GetOpenFilename
    If Not NDF = False Then
        Set WordApp = CreateObject("Word.Application")
        Set WordDoc = WordApp.Documents.Open(NDF, ReadOnly:=True)

        lg = 2
        For Each Prgf In WordDoc.Paragraphs
            With Prgf.Range
                If .Style = "Titre 1" Or .Style = "Titre 2" Or .Style = "Titre 3" Then   'If Len(.Text) > 2 Then
                    ActiveSheet.Range("A" & lg).Value = .Style
                    ActiveSheet.Range("B" & lg).Value = Left(.Text, Len(.Text) - 1)
                    For Each Ctrl In .ContentControls
                         ActiveSheet.Range("C" & lg).Value = Ctrl.Range.Text
                    Next Ctrl
                    lg = lg + 1
                End If
            End With
        Next Prgf

        WordDoc.Close
        WordApp.Application.Quit

        Set Ctrl = Nothing
        Set Prgf = Nothing
        Set WordDoc = Nothing
        Set WordApp = Nothing
    End If
End Sub

Pierre,

Les ContentControls ne sont pas reconnus avec ta proposition. J'ai essayé de déclarer Ctrl comme ContentControl mais j'ai l'erreur Type non défini.

Une idée?

Cordialement,

Bonjour,

Finalement avec le code suivant ça se passe relativement bien. J'ai assigné un style au texte de mes ContentControls (titre 4)

Sub ()
Dim NDF As Variant
Dim WordApp As Object, WordDoc As Object, Prgf As Object
Dim lg As Integer, i As Integer, C As Integer, Cdest As Integer
Dim ligne As Long

    ChDrive Left(ActiveWorkbook.Path, 1)
    ChDir ActiveWorkbook.Path
    NDF = Application.GetOpenFilename
    If Not NDF = False Then
        Set WordApp = CreateObject("Word.Application")
        Set WordDoc = WordApp.documents.Open(NDF, ReadOnly:=True)
        lg = 2
        For Each Prgf In WordDoc.Paragraphs
            With Prgf.Range
                    If Prgf.Style = "Titre 1" Or Prgf.Style = "Titre 2" Or Prgf.Style = "Titre 3" Then
                        Sheets("Feuil1").Range("A" & lg).Value = .Style
                        Sheets("Feuil1").Range("B" & lg).Value = Left(.Text, Len(.Text) - 1)
                        lg = lg + 1
                    Else
                        If Prgf.Style = "Titre 4;" Then
                        For Each Ctrl In .ContentControls
             Sheets("Feuil1").Range("A" & lg).Value = .Style
             Sheets("Feuil1").Range("B" & lg).Value = Ctrl.Range.Text
                        lg = lg + 1
                        Next Ctrl
                     End If

                    End If
                End With
            Next Prgf
        WordDoc.Close
        WordApp.Application.Quit
        Set Ctrl = Nothing
        Set Prgf = Nothing
        Set WordDoc = Nothing
        Set WordApp = Nothing
    End If

J'ai toutefois une autre questions. Mes ContentControls sont parfois composés de retour chariot ou de listes. Est-il possible de conserver cette mise en forme lors de la copie vers Excel? En effet avec la méthode actuelle tout est collé à la suite.

Merci

Rechercher des sujets similaires à "controle contenu style word"