1. #1
    Membre éclairé Avatar de Souriane
    Femme Profil pro
    Assistant aux utilisateurs
    Inscrit en
    septembre 2009
    Messages
    461
    Détails du profil
    Informations personnelles :
    Sexe : Femme
    Localisation : Canada

    Informations professionnelles :
    Activité : Assistant aux utilisateurs
    Secteur : Service public

    Informations forums :
    Inscription : septembre 2009
    Messages : 461
    Points : 660
    Points
    660

    Par défaut Ajout de Building blocks en lot - macro qui ne fonctionne plus

    Bonjour,

    J'ai un soucis avec un code que j'utilise depuis plusieurs années. C'est un code que j'avais pris sur le net et adapté pour mes besoins.

    Le code ouvre un fichier Word dans lequel se trouve un tableau contenant toutes mes Corrections automatiques (Building Blocks) et les intègres une à une.

    Sauf que là, ça ne fonctionne plus. Quand j'ouvre "Building Blocks" aucune Correction ne s'est ajoutée et je n'ai aucun message d'erreur lors de l'exécution de la macro.

    Est-ce que quelqu'un voit ce qui cloche?


    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
    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
    223
    224
    225
    226
    227
    228
    229
    230
    231
    232
    233
    234
    235
    236
    237
    238
    239
    240
    241
    242
    243
    244
    245
    246
    247
    248
    249
    250
    251
    252
    253
    254
    255
    256
    257
    258
    259
    260
    261
    262
    263
    264
    265
    266
    267
    268
    269
    270
    271
    272
    273
    274
    275
    276
    277
    278
    279
    280
    281
    282
    283
    284
    285
    286
    287
    288
    289
    290
    291
    292
    293
    294
    295
    296
    297
    298
    299
    300
    301
    302
    Option Explicit
    Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function CloseClipboard Lib "user32" () As Long
    Private Declare Function EmptyClipboard Lib "user32" () As Long
    '
     
     
    Private Sub CommandButton1_Click()
     
    'NÉCESSITE les fonctions "CorrectionAutomatiques_OpenACDoc" et "CorrectionAutomatiques_RestoreACEntries"
     
    ' First warns the user that this will replace their existing entries.
    ' If they answer no it jumps to the end of the function.   Next calls CorrectionAutomatiques_OpenACDoc() to open
    ' the file. If successful it calls CorrectionAutomatiques_RestoreACEntries(). Finally, it closes the document.
     
    Dim ACFileName, Title As String
    Dim MsgBoxButtons As Long, Response As Long, X As Long
     
     
    ' warn users about replaced entries...
    MsgBoxButtons = vbYesNo + vbInformation + vbDefaultButton2 ' Define buttons.
    Title = "AutoCorrect Utility"
    Response = MsgBox("Cette macro va remplacer toutes vos entrées de Corrections Automatiques avec celles contenues dans le document du Greffe si toutefois elles ont le même nom. Souhaitez-vous continuer?", MsgBoxButtons, Title)
    If Response = vbNo Then
       'exit
        GoTo bye:
    End If
     
    'Nom du fichier où se trouve les Corrections automatiques
    ACFileName = "\\villong\public\Juridique\jursecrgref\Administration du service\Setting informatique\zSettings_Greffe\Developpement\Word Developpement\Corrections automatiques\Greffe - Corrections et insertions automatiques - Officiel.doc"
     
     
     
     
    ' Open a Document,call CorrectionAutomatiques_OpenACDoc() user defined
    If CorrectionAutomatiques_OpenACDoc(ACFileName) = True Then 'error
        ' Restore Entries, call CorrectionAutomatiques_RestoreACEntries() user defined
        X = CorrectionAutomatiques_RestoreACEntries()
        ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
        End If
    bye:
    System.Cursor = wdCursorNormal
    End Sub
     
    Private Function CorrectionAutomatiques_RestoreACEntries()
    'Fonction utilisée par CorrectionAutomatiques_integration_a_l_utilisatrice
     
    Dim oDoc As Document, oACorrect As Object, oTable As Table, oRow As Row
    Dim strName As String, strValue As String, strRTF As String, MyRange As Range, RTFRange As Range
    Dim X As Long
     
    Err.Clear
    On Error GoTo 0
     
    If ActiveDocument.Words(1) <> "rien" Then
     
    'Vider la fenêtre de rechecher/remplacer via l'appel d'une macro:
    Vider_ChercherRemplacer
     
    '''''Application.ScreenUpdating = False
     
    ActiveDocument.TablesOfContents(1).delete
     
    'Efface les "F3"
        With selection.Find
            .Text = "^wf3"
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindContinue
            .MatchWildcards = False
            .Execute Replace:=wdReplaceAll
        End With
     
    'Va au tableau sinon se trouve sur la première page du doc
    selection.GoTo What:=wdGoToTable, Which:=wdGoToNext, count:=1, Name:=""
    If selection.Information(wdWithInTable) = True Then
    ' go to the last row
    selection.Move Unit:=wdRow, count:=selection.tables(1).Rows.count
    ' go to the last cell of that row
    selection.Move Unit:=wdCell, count:=selection.tables(1).Columns.count
    ' Now move down two lines, beyond the table end
    selection.Move Unit:=wdLine, count:=2
    End If
    'Efface ce qui se trouve après le tableau
        selection.EndKey Unit:=wdStory, Extend:=wdExtend
        selection.delete Unit:=wdCharacter, count:=1
     
    'La section suivante vérifie s'il y a des titres de section.
    Do
    selection.HomeKey Unit:=wdStory
            selection.Find.Style = ActiveDocument.Styles("InsertionTitre1")
        With selection.Find
            .Text = "^?"
            .Forward = True
            .Wrap = wdFindContinue
         End With
        selection.Find.Execute
     
                  If selection.Find.Found = False Then
        Else
                  selection.Rows.delete
        End If
      Loop While selection.Find.Found = True
     
       selection.GoTo What:=wdGoToTable, Which:=wdGoToNext, count:=1, Name:=""
     
    'Met en minuscule le nom de l'insertion
            Dim aTable As Table
     
            For Each aTable In ActiveDocument.tables
            Dim aRow As Row
     
            With aTable
                    For Each aRow In aTable.Range.Rows
                    aRow.Cells(1).Select
                        selection.Range.Case = wdLowerCase
                       Next
            End With
            Next
     
     
    'Efface les lignes vides
    Effacer_lignes_vides
     
    'Vider la fenêtre de rechecher/remplacer via l'appel d'une macro:
    Vider_ChercherRemplacer
     
     
     
     
        Set oDoc = ActiveDocument
        Set oTable = oDoc.tables(1)
        Set oACorrect = Application.AutoCorrect.Entries
        Set MyRange = oTable.Cell(2, 1).Range
        MyRange.End = MyRange.End - 1
        System.Cursor = wdCursorWait
     
        Do
            Application.ScreenUpdating = False
     
            strName = MyRange.Text
            Set MyRange = MyRange.Next(wdCell)
            MyRange.End = MyRange.End - 1
     
                    'if AutoCorrect entry is a table then gets the entry, deletes the table within a table,
                'and goes to next row if there are any more rows
                If Not MyRange.tables(1).Range.IsEqual(oTable.Range) Then
                    Application.AutoCorrect.Entries.AddRichText strName, MyRange
                    MyRange.Cut
                    If IsObjectValid(MyRange.Next(wdCell, 2)) Then
                        Set MyRange = MyRange.Next(wdCell, 2)
                        MyRange.End = MyRange.End - 1
                        GoTo NextLoop
                    Else
                        Exit Do
                    End If
                End If
     
     
            strValue = MyRange.Text
     
            Set RTFRange = MyRange.Next(wdCell)
            RTFRange.End = RTFRange.End - 1
            strRTF = RTFRange.Text
     
            Application.StatusBar = "Adding AutoCorrect Entry: " & strName
     
     
            If strRTF = "False" Then
                Application.AutoCorrect.Entries.Add Name:=strName, Value:=strValue
            Else
     
                Application.AutoCorrect.Entries.AddRichText strName, MyRange
            End If
     
            If IsObjectValid(RTFRange.Next(wdCell)) Then
                Set MyRange = RTFRange.Next(wdCell)
                MyRange.End = MyRange.End - 1
            Else
                Exit Do
            End If
    NextLoop:
        Loop
     
        System.Cursor = wdCursorNormal
        Application.ScreenUpdating = True
        MsgBox "Intégration des corrections automatiques du greffe terminée"
     
    Else
        MsgBox "Erreur"
    End If
     
    'Vide le presse-papier
       ViderPressePapier
     
    CorrectionAutomatiques_RestoreACEntriesErrors:
    Select Case Err.Number
        Case 0:
        ' no error
        Case Else
          MsgBox ("There was an error. The document may be in the incorrect format." & vbCr & Err.Number & "  " & Err.Description & " " & strName)
    End Select
     
     
    End Function
     
    Public Sub ViderPressePapier()
        'Ouverture du presse-papier
        OpenClipboard 0&
        'On vide le presse-papier
        EmptyClipboard
        'Fermeture du presse-papier
        CloseClipboard
    End Sub
    Private Function CorrectionAutomatiques_OpenACDoc(ByVal ACFileOpenName As String) As Boolean
    'Fonction utilisée par CorrectionAutomatiques_integration_a_l_utilisatrice
    Dim MsgBoxButtons As Long
     
    CorrectionAutomatiques_OpenACDoc = True
    On Error GoTo CorrectionAutomatiques_OpenACDocErrors
     
    Documents.Open FileName:=ACFileOpenName
    On Error GoTo 0
    Exit Function
     
    CorrectionAutomatiques_OpenACDocErrors:
       CorrectionAutomatiques_OpenACDoc = False
     
    End Function
     
     
    Sub Vider_ChercherRemplacer()
    'Macro appelée à la fin de d'autres macros pour remettre
    'le rechercher remplacer à zéro
    'NE PAS EFFACER CETTE MACRO
     
     
        With selection.Find
            .ClearFormatting
            .Text = ""
            .Replacement.ClearFormatting
            .Replacement.Text = ""
            .MatchAllWordForms = False
            .MatchCase = False
            .MatchSoundsLike = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .Wrap = wdFindContinue
            .Forward = True
            .Format = False
        End With
     
    End Sub
     
     
     
    Sub Effacer_lignes_vides()
    'Deleting all empty rows in a table
     
        ''Note that you could delete the empty rows from all tables in a document by replacing the line:
        ''    Set oTable = Selection.Tables(1)
        ''With the line
        ''    For Each oTable In ActiveDocument.Tables
        ''and adding the line:
        ''    Next oTable
        ''just Before:
        ''    Application.ScreenUpdating = True
     
    Dim oTable As Table, oRow As Range, oCell As Cell, Counter As Long, _
    NumRows As Long, TextInRow As Boolean
     
    ' Specify which table you want to work on.
    Set oTable = selection.tables(1)
    ' Set a range variable to the first row's range
    Set oRow = oTable.Rows(1).Range
    NumRows = oTable.Rows.count
    Application.ScreenUpdating = False
     
    For Counter = 1 To NumRows
     
        StatusBar = "Row " & Counter
        TextInRow = False
     
        For Each oCell In oRow.Rows(1).Cells
            If Len(oCell.Range.Text) > 2 Then
                'end of cell marker is actually 2 characters
                TextInRow = True
                Exit For
            End If
        Next oCell
     
        If TextInRow Then
            Set oRow = oRow.Next(wdRow)
        Else
            oRow.Rows(1).delete
        End If
     
    Next Counter
     
    Application.ScreenUpdating = True
     
    End Sub
    Merci!

    Souriane
    __________________________________
    Une question bien posée est à moitié résolue!

    Merci de ne pas oublier de mettre RÉSOLU quand le sujet l'est. Cela aide tous les DVPnautes dans leur recherche

  2. #2
    Expert éminent

    Homme Profil pro
    Développeur Vba Excel
    Inscrit en
    avril 2013
    Messages
    3 099
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Ille et Vilaine (Bretagne)

    Informations professionnelles :
    Activité : Développeur Vba Excel
    Secteur : High Tech - Éditeur de logiciels

    Informations forums :
    Inscription : avril 2013
    Messages : 3 099
    Points : 8 032
    Points
    8 032
    Billets dans le blog
    19

    Par défaut

    Bonjour Souriane,

    N'as-tu qu'une seule table dans ton document ? Es-tu sure de pointer sur la bonne table ?
    S'il n'y a normalement qu'une seule table, que donnerait le Debug.print dans ta fonction CorrectionAutomatiques_RestoreACEntries

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
     
                Set oDoc = ActiveDocument
                Debug.Print oDoc.Tables.Count
                Set oTable = oDoc.Tables(1)
    Eric KERGRESSE
    https://sites.google.com/site/erickergresseeirl/
    Lorsque vous avez la réponse à votre question, n'oubliez pas de cliquer sur et si celle-ci est pertinente pensez à voter

  3. #3
    Membre éclairé Avatar de Souriane
    Femme Profil pro
    Assistant aux utilisateurs
    Inscrit en
    septembre 2009
    Messages
    461
    Détails du profil
    Informations personnelles :
    Sexe : Femme
    Localisation : Canada

    Informations professionnelles :
    Activité : Assistant aux utilisateurs
    Secteur : Service public

    Informations forums :
    Inscription : septembre 2009
    Messages : 461
    Points : 660
    Points
    660

    Par défaut

    J'ai eu un moment de clairvoyance ce matin... pour me rendre compte que la macro sur laquelle je travaillais n'était pas la bonne!!!!

    En effet, celle que j'ai mis dans mon message ci-dessus est le gabarit initial. Depuis, je l'ai modifiée et intégré dans un fichier .dotm à partir du quel j'active toujours la macro...! Bref, voilà pourquoi ça ne fonctionnait pas comme je voulais... * soupir * Tant de temps gaspillé !

    Merci pour ton aide quand même!
    __________________________________
    Une question bien posée est à moitié résolue!

    Merci de ne pas oublier de mettre RÉSOLU quand le sujet l'est. Cela aide tous les DVPnautes dans leur recherche

+ Répondre à la discussion
Cette discussion est résolue.

Discussions similaires

  1. Macro qui ne fonctionne plus sur 2010
    Par Charlie3 dans le forum Macros et VBA Excel
    Réponses: 4
    Dernier message: 26/01/2013, 16h29
  2. [WD-2003] Macro qui ne fonctionne plus depuis changement OS
    Par kinto dans le forum VBA Word
    Réponses: 2
    Dernier message: 16/11/2012, 15h06
  3. Macro qui ne fonctionne qu'avec F5 !
    Par Ocin2 dans le forum Macros et VBA Excel
    Réponses: 2
    Dernier message: 28/03/2011, 00h22
  4. [XL-2003] Problème avec 2 macros qui fonctionnaient mais qui ne fonctionnent plus
    Par amilka dans le forum Macros et VBA Excel
    Réponses: 1
    Dernier message: 22/03/2010, 08h25
  5. Macro qui ne marche plus depuis un userform
    Par Ramoneur dans le forum Macros et VBA Excel
    Réponses: 39
    Dernier message: 19/06/2008, 15h37

Partager

Partager
  • Envoyer la discussion sur Viadeo
  • Envoyer la discussion sur Twitter
  • Envoyer la discussion sur Google
  • Envoyer la discussion sur Facebook
  • Envoyer la discussion sur Digg
  • Envoyer la discussion sur Delicious
  • Envoyer la discussion sur MySpace
  • Envoyer la discussion sur Yahoo