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 |
