macro sans référence VBA Microsoft Office 16.0 Object Librairy

**Fionac** · 09/09/2021, 08h55

Bonjour,

J'ai une macro qui me permet de faire des extractions de commentaires Word vers un Excel. Il me permet également de remplir certaines cases automatiquement.
Mon programme marche bien mais fais l'usage de la référence Microsoft Office 16.0 Object Librairy donc il ne marche pas pour les version Excel 2009 et 2013.
Comment puis-je adapter mon programme à ces versions Excel.
(Je n'ai pas mit le code dans son entièreté car il est vraiment très long).

Merci d'avance.

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
Option Explicit
 
Public fen_nom As String
Public fen_prenom As String
Public fen_dpt As String
Public fen_initiale As String
 
 
Public TableauParagrapheLigne(200) As Long
 
'Tableau contenant le nom des paragraphes du document
Public TableauParagrapheNom(200) As String
 
Public Sub ExtractComments()
 
    Dim oDoc As Word.Document
    Dim o As Document
 
    Dim oRevision As Word.Revision
 
    Dim oComment As Word.Comment
 
    Dim n As Long
    Dim Ligne As Long
    Dim Ligne2 As Long
    Dim compteur As Long
    Dim I As Long
 
    Dim wddoc As Object
 
    Dim strText As String
    Dim Title As String
 
    Dim repertoire As String
    Dim nomFichier As String
    Dim extension As String
 
    Dim rParagraphs As Range
    Dim CurPos As Long
    Dim GetParNum As String
 
    Dim dlg As FileDialog
    Dim strPath As String
    Dim objPara As Paragraph
    Dim sText As String
    Dim sList As String
    Dim style As Variant
    Dim nLevel As Integer
'    Dim lignes As Integer
    Dim i2 As Integer
    Dim myRange1 As Range
    Dim name As String
    Dim dpt As String
    Dim FileSaveName As String
 
 
 
 
   'use to count extracted changes
    Dim Lign As Long
    ThisWorkbook.Sheets("Remarks").Select
    Ligne = 26 'première ligne à vérifier
    Do While Not IsEmpty(Range("A" & Ligne))
    Ligne = Ligne + 1
    Loop
 
    Title = "Extract Comments to Comment Sheet"
 
    compteur = 1
 
'    Open Word file
 
 
     Set dlg = Application.FileDialog(msoFileDialogFilePicker)
    With dlg
        .InitialFileName = "C:\temp\"
        .AllowMultiSelect = False
        .Title = "Safran Electrical & Power"
 
        If .Show = -1 Then
            Set wddoc = CreateObject("Word.Application")
            wddoc.Visible = True
            strPath = dlg.SelectedItems(1)
            Set oDoc = wddoc.Documents.Open(strPath)
            If oDoc.Comments.Count = 0 Then
                MsgBox "The active document contains no comments.", vbOKOnly, Title
                GoTo ExitHere
            Else
        'Stop if user does not click Yes
                If MsgBox("Do  you want to extract comments to Comment Sheet?" & vbCr & vbCr & _
                    "NOTE: Only comments will be included. " & _
                    "All other types of changes will be skipped.", _
                    vbYesNo + vbQuestion, Title) <> vbYes Then
                GoTo ExitHere
                End If
            End If
 
          Application.ScreenUpdating = False
 
            Load ProofReader
            ProofReader.Show
 
ThisWorkbook.Sheets("Report").Select
Ligne2 = 22
Do While Not IsEmpty(Range("A" & Ligne2))
Ligne2 = Ligne2 + 1
Loop
            'MAJ des noms
            ThisWorkbook.Sheets("Report").Cells(Ligne2, 1) = ProofReader.nom & " " & ProofReader.prenom
            name = ProofReader.nom
            ThisWorkbook.Sheets("Report").Cells(Ligne2, 6) = ProofReader.dpt
            dpt = ProofReader.dpt
            ThisWorkbook.Sheets("Report").Cells(Ligne2, 3) = ProofReader.initial
 
            Unload ProofReader
        Else
            MsgBox "Pas de fichier sélectionné, opération annulée"
            GoTo ExitHere
        End If
    End With
 
    On Error GoTo ExitHere
'Fonction permettant d'initialiser les deux vecteurs paragraphe
         For i2 = 1 To 200
 
            TableauParagrapheLigne(i2) = 999999
 
        Next i2
 
     i2 = 0
    TableauParagrapheNom(i2) = "Synopsis"
 
    For Each objPara In oDoc.Paragraphs
 
        With objPara.Range
            sText = .Text
            sList = .ListFormat.ListString
            On Error Resume Next
            style = .style
            If Left(style, 6) = "Titre " Then
 
                If sList = "" Then
                    sList = sText
                Else
                    sList = "§" & sList
                End If
 
                i2 = i2 + 1
                TableauParagrapheLigne(i2) = objPara.Range.Start
                TableauParagrapheNom(i2) = sList
 
            End If
 
        End With
 
    Next
 
    For Each oComment In oDoc.Comments
 
        'Number
        ThisWorkbook.Sheets("Remarks").Cells(Ligne, 1) = Ligne - 25
 
        'The author
        ThisWorkbook.Sheets("Remarks").Cells(Ligne, 2) = name
 
 
        'Reading subject
        'ThisWorkbook.Sheets("Remarks").Cells(Ligne, 15) = dpt
 
        'Date
        'ThisWorkbook.Sheets("Remarks").Cells(Ligne, 15) = Date
 
 
        'Page number
 
        'Page & Line number
 
       i2 = 0
        For i2 = 1 To 200
 
            If oDoc.Comments(n).Scope.Start < TableauParagrapheLigne(i2) Then
               Exit For
            End If
 
            If i2 = 200 Then
                i2 = 1
                Exit For
            End If
 
        Next i2
        ThisWorkbook.Sheets("Remarks").Cells(Ligne, 4) = oComment.Scope.Information(wdActiveEndPageNumber)
        ThisWorkbook.Sheets("Remarks").Cells(Ligne, 5) = oComment.Scope.Information(wdFirstCharacterLineNumber)
 
        ThisWorkbook.Sheets("Remarks").Cells(Ligne, 3) = TableauParagrapheNom(i2 - 1)
 
 
        'Type and text of revision
 
        If InStr(1, oComment.Range.Text, "Maj", vbTextCompare) <> 0 Or InStr(1, oComment.Range.Text, "maj", vbTextCompare) <> 0 Then
            ThisWorkbook.Sheets("Remarks").Cells(Ligne, 8) = "Major"
 
                If InStr(1, oComment.Range.Text, "acc", vbTextCompare) <> 0 Then
                ThisWorkbook.Sheets("Remarks").Cells(Ligne, 7) = "Accuracy"
                ThisWorkbook.Sheets("Remarks").Cells(Ligne, 9) = "[" & oComment.Scope.Text & "]: " & Mid(oComment.Range.Text, 8)
 
 
                ElseIf InStr(1, oComment.Range.Text, "trac", vbTextCompare) <> 0 Then
                ThisWorkbook.Sheets("Remarks").Cells(Ligne, 7) = "Traceability"
                ThisWorkbook.Sheets("Remarks").Cells(Ligne, 9) = "[" & oComment.Scope.Text & "]: " & Mid(oComment.Range.Text, 9)
 
                Else
                ThisWorkbook.Sheets("Remarks").Cells(Ligne, 7) = " "
 
            End If
 
 
                Else
                ThisWorkbook.Sheets("Remarks").Cells(Ligne, 7) = " "
                ThisWorkbook.Sheets("Remarks").Cells(Ligne, 9) = "[" & oComment.Scope.Text & "]: " & Mid(oComment.Range.Text, 3)
                End If
            ThisWorkbook.Sheets("Remarks").Cells(Ligne, 8) = "Not error"
            ThisWorkbook.Sheets("Remarks").Cells(Ligne, 15) = "xxxxxxxxxx"
            ThisWorkbook.Sheets("Remarks").Cells(Ligne, 16) = "xxxxxxxxxxxxxxxxxx"
            ThisWorkbook.Sheets("Remarks").Cells(Ligne, 12) = "xxxxxxxxxxxxxxxx"
            ThisWorkbook.Sheets("Remarks").Cells(Ligne, 13) = "xxxxxxxxxxxxx"
            ThisWorkbook.Sheets("Remarks").Cells(Ligne, 18) = "xxxxxxxxx"
 
        Else
          ThisWorkbook.Sheets("Remarks").Cells(Ligne, 9) = "[" & oComment.Scope.Text & "]: " & oComment.Range.Text
            ThisWorkbook.Sheets("Remarks").Cells(Ligne, 8) = " "
        End If
 
 
 
 
 
 
   ThisWorkbook.Sheets("Report").Cells(7, 14) = oComment.Scope.Information(wdActiveEndPageNumber)
 
 
        'Insert a new line
 
        ThisWorkbook.Sheets("Remarks").Rows(Ligne + 1).Insert Shift:=xlShiftDown, CopyOrigin:=xlFormatFromLeftOrAbove
        'ThisWorkbook.Sheets("Comments").Rows(ligne +1).EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
 
        ThisWorkbook.Sheets("Remarks").Rows(Ligne).Copy
        ThisWorkbook.Sheets("Remarks").Rows(Ligne + 1).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False
 
        n = n + 1
        Ligne = Ligne + 1
        compteur = compteur + 1
 
    Next oComment
 
    'If no Comments/insertions/deletions were found, show message and close oNewDoc
    If n = 0 Then
'        MsgBox "No insertions, deletions or comments were found.", vbOKOnly, Title
        MsgBox "No comments were found.", vbOKOnly, Title
        GoTo ExitHere
    End If
 
    'suppress the last empty row
    ThisWorkbook.Sheets("Remarks").Rows(Ligne).Delete
 
'   Menu Save Document As proposal
 
    Set o = ActiveDocument
    If InStrRev(o.name, ".") <> 0 Then
        nomFichier = Left(o.name, InStrRev(o.name, ".") - 1)
    Else
        nomFichier = o.name
    End If
    extension = ".xlsm"
    FileSaveName = Application.GetSaveAsFilename(InitialFileName:=nomFichier & "_" & fen_initiale & "_Comments_" & Format(Date, "dd") & Format(Date, "mm") & Format(Date, "yy") & extension, FileFilter:="Excel Sheet (*.xlsm), *.xlsm")
      If FileSaveName <> False Then
             ' ThisWorkbook.Application.Dialogs(xlDialogSaveAs).Show repertoire & nomFichier & "_" & fen_initiale & "_Comments_" & Format(Date, "dd") & "" & Format(Date, "mm") & "" & Format(Date, "yy") & extension
              ThisWorkbook.SaveAs Filename:=FileSaveName, CreateBackup:=False
      End If
    On Error GoTo ExitHere
    oDoc.Close
    wddoc.Quit
ExitHere:
  Set wddoc = Nothing
    Set oDoc = Nothing
    Set o = Nothing
    Set dlg = Nothing
 
 End Sub

**Ben_L** · 09/09/2021, 10h43

Bonjour,

Une discussion similaire est disponible ici.
Cdt

**Fionac** · 15/09/2021, 09h38

Merci bcp

macro sans référence VBA Microsoft Office 16.0 Object Librairy

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager