Bonjour,

J'ai une macro me permettant d'extraire (depuis un format fdf) les commentaires de documents PDF à partir d'un bouton. A chaque fois que je clique sur le bouton les extractions des essaies précédents sont supprimées. Je voudrais que les commentaires de chaque extraction soient conservées. Pouvez-vous m'aider?

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
Dim Initials As String
Dim nom As String
Dim dpt As String
Sub PDF_Parse(Filename As String)
    On Error Resume Next
 
    Dim Ligne As String
    Dim num As Long
    I = 0
    debut = 26
 
    'ouvre le fichier en lecture
    num = FreeFile
    Open Filename For Input As #num
 
    'boucle tant que l'on n'a pas atteint la fin du fichier
    lin = 1
    While Not EOF(num)
 
        Line Input #num, UneLigne
        Obj = Right(UneLigne, 4)
        If Obj = " obj" Then
            Ligne = ""
            Do While Not EOF(num)
                Line Input #num, UneLigne
                Ligne = Ligne + UneLigne
                If UneLigne = "endobj" Then
                    Exit Do
                End If
            Loop
 
            idebContent = InStr(Ligne, "/Contents(")
            ifinContent = WorksheetFunction.Max(InStr(WorksheetFunction.Max(idebContent, 1), Ligne, ")/F"), idebContent)
            ifinContent = InStr(WorksheetFunction.Max(idebContent, 1), Ligne, ")/F")
 
 
            idebPage = InStr(WorksheetFunction.Max(ifinContent, 1), Ligne, "/Page")
            ifinPage = WorksheetFunction.Max(InStr(WorksheetFunction.Max(idebPage, 1) + 2, Ligne, "/"), idebPage)
            sContent = ""
            If (idebContent) Then
                sContent = Mid(Ligne, idebContent + 10, ifinContent - idebContent - 10)
                sContent = Replace(sContent, "\r", Chr(10))
            End If
            sPage = ""
            Dim iPage As Integer
            If (idebPage) Then
                iPage = Mid(Ligne, idebPage + 2 + 4, ifinPage - idebPage - 2 - 4) + 1
                sPage = "Page " & iPage
            End If
            If (idebContent) Then
                ThisWorkbook.Sheets("Remarks").Cells(I + debut, 1) = I + 1
 
        ThisWorkbook.Sheets("Remarks").Cells(I + debut, 14) = Date
        ThisWorkbook.Sheets("Remarks").Cells(I + debut, 13) = nom
        ThisWorkbook.Sheets("Remarks").Cells(I + debut, 15) = dpt
                ThisWorkbook.Sheets("Remarks").Cells(I + debut, 3) = sPage
ThisWorkbook.Sheets("Report").Cells(7, 14) = iPage
 
'Type and text of revision
 
If (LCase(Left(sContent, 6)) = "major ") Or (LCase(Left(sContent, 6)) = "Major ") Or (LCase(Left(sContent, 4)) = "Maj ") Or (LCase(Left(sContent, 4)) = "maj ") Then
                    ThisWorkbook.Sheets("Remarks").Cells(I + debut, 9) = "Major"
                    ThisWorkbook.Sheets("Remarks").Cells(I + debut, 5) = Mid(sContent, 1)
                ElseIf (LCase(Left(sContent, 6)) = "minor ") Or (LCase(Left(sContent, 6)) = "Minor ") Or (LCase(Left(sContent, 4)) = "Min ") Or (LCase(Left(sContent, 4)) = "min ") Then
                    ThisWorkbook.Sheets("Remarks").Cells(I + debut, 9) = "Minor"
                    ThisWorkbook.Sheets("Remarks").Cells(I + debut, 5) = Mid(sContent, 1)
                ElseIf (LCase(Left(sContent, 8)) = "blocked ") Or (LCase(Left(sContent, 8)) = "Blocked ") Or (LCase(Left(sContent, 6)) = "block ") Or (LCase(Left(sContent, 6)) = "Block ") Then
                    ThisWorkbook.Sheets("Remarks").Cells(I + debut, 9) = "Blocked"
                    ThisWorkbook.Sheets("Remarks").Cells(I + debut, 5) = Mid(sContent, 1)
                ElseIf (LCase(Left(sContent, 10)) = "not error ") Or (LCase(Left(sContent, 10)) = "Not error ") Or (LCase(Left(sContent, 3)) = "NE ") Or (LCase(Left(sContent, 3)) = "ne ") Then
                    ThisWorkbook.Sheets("Remarks").Cells(I + debut, 9) = "Not error"
                    ThisWorkbook.Sheets("Remarks").Cells(I + debut, 5) = Mid(sContent, 1)
                Else
                    ThisWorkbook.Sheets("Remarks").Cells(I + debut, 9) = " "
                    ThisWorkbook.Sheets("Remarks").Cells(I + debut, 5) = Mid(sContent, 1)
        End If
 
 
        'Defect class
 
    If InStr(1, sContent, "Accuracy", vbTextCompare) <> 0 Or InStr(1, sContent, "accuracy", vbTextCompare) <> 0 Or InStr(1, sContent, "Acc", vbTextCompare) <> 0 Or InStr(1, sContent, "acc", vbTextCompare) <> 0 Then
             ThisWorkbook.Sheets("Remarks").Cells(I + debut, 8) = "Accuracy"
 
        ElseIf InStr(1, sContent, "Clarity", vbTextCompare) <> 0 Or InStr(1, sContent, "clarity", vbTextCompare) <> 0 Or InStr(1, sContent, "Cla", vbTextCompare) <> 0 Or InStr(1, sContent, "cla", vbTextCompare) <> 0 Then
            ThisWorkbook.Sheets("Remarks").Cells(I + debut, 8) = "Clarity"
 
        ElseIf InStr(1, sContent, "Completness", vbTextCompare) <> 0 Or InStr(1, sContent, "completness", vbTextCompare) <> 0 Or InStr(1, sContent, "Complet", vbTextCompare) <> 0 Or InStr(1, sContent, "complet", vbTextCompare) <> 0 Then
             ThisWorkbook.Sheets("Remarks").Cells(I + debut, 8) = "Completeness"
 
        ElseIf InStr(1, sContent, "Compliance", vbTextCompare) <> 0 Or InStr(1, sContent, "compliance", vbTextCompare) <> 0 Or InStr(1, sContent, "Compli", vbTextCompare) <> 0 Or InStr(1, sContent, "compli", vbTextCompare) <> 0 Then
           ThisWorkbook.Sheets("Remarks").Cells(I + debut, 8) = "Compliance"
 
        ElseIf InStr(1, sContent, "Consistency", vbTextCompare) <> 0 Or InStr(1, sContent, "consistency", vbTextCompare) <> 0 Or InStr(1, sContent, "Cons", vbTextCompare) <> 0 Or InStr(1, sContent, "cons", vbTextCompare) <> 0 Then
           ThisWorkbook.Sheets("Remarks").Cells(I + debut, 8) = "Consistency"
 
        ElseIf InStr(1, sContent, "Correctness", vbTextCompare) <> 0 Or InStr(1, sContent, "correctness", vbTextCompare) <> 0 Or InStr(1, sContent, "Corr", vbTextCompare) <> 0 Or InStr(1, sContent, "corr", vbTextCompare) <> 0 Then
           ThisWorkbook.Sheets("Remarks").Cells(I + debut, 8) = "Correctness"
 
        ElseIf InStr(1, sContent, "Drafting", vbTextCompare) <> 0 Or InStr(1, sContent, "drafting", vbTextCompare) <> 0 Or InStr(1, sContent, "Dra", vbTextCompare) <> 0 Or InStr(1, sContent, "dra", vbTextCompare) <> 0 Then
            ThisWorkbook.Sheets("Remarks").Cells(I + debut, 8) = "Drafting"
 
         ElseIf InStr(1, sContent, "Formalism", vbTextCompare) <> 0 Or InStr(1, sContent, "formalism", vbTextCompare) <> 0 Or InStr(1, sContent, "Form", vbTextCompare) <> 0 Or InStr(1, sContent, "form", vbTextCompare) <> 0 Then
           ThisWorkbook.Sheets("Remarks").Cells(I + debut, 8) = "Formalism"
 
         ElseIf InStr(1, sContent, "Legibility", vbTextCompare) <> 0 Or InStr(1, sContent, "legibility", vbTextCompare) <> 0 Or InStr(1, sContent, "Legi", vbTextCompare) <> 0 Or InStr(1, sContent, "legi", vbTextCompare) <> 0 Then
           ThisWorkbook.Sheets("Remarks").Cells(I + debut, 8) = "Legibility"
 
        ElseIf InStr(1, sContent, "Missing", vbTextCompare) <> 0 Or InStr(1, sContent, "missing", vbTextCompare) <> 0 Or InStr(1, sContent, "Miss", vbTextCompare) <> 0 Or InStr(1, sContent, "miss", vbTextCompare) <> 0 Then
           ThisWorkbook.Sheets("Remarks").Cells(I + debut, 8) = "Missing"
 
        ElseIf InStr(1, sContent, "Maintainability", vbTextCompare) <> 0 Or InStr(1, sContent, "maintainability", vbTextCompare) <> 0 Or InStr(1, sContent, "Maint", vbTextCompare) <> 0 Or InStr(1, sContent, "maint", vbTextCompare) <> 0 Then
            ThisWorkbook.Sheets("Remarks").Cells(I + debut, 8) = "Maintainability"
 
            ElseIf InStr(1, sContent, "Testability", vbTextCompare) <> 0 Or InStr(1, sContent, "testability", vbTextCompare) <> 0 Or InStr(1, sContent, "Test", vbTextCompare) <> 0 Or InStr(1, sContent, "test", vbTextCompare) <> 0 Then
            ThisWorkbook.Sheets("Remarks").Cells(I + debut, 8) = "Testability"
 
            ElseIf InStr(1, sContent, "Traceability", vbTextCompare) <> 0 Or InStr(1, sContent, "traceability", vbTextCompare) <> 0 Or InStr(1, sContent, "Trac", vbTextCompare) <> 0 Or InStr(1, sContent, "trac", vbTextCompare) <> 0 Then
            ThisWorkbook.Sheets("Remarks").Cells(I + debut, 8) = "Traceability"
 
        Else
            ThisWorkbook.Sheets("Remarks").Cells(I + debut, 8) = " "
 
        End If
 
                I = I + 1
            End If
 
            lin = lin + 1
        End If
 
    Wend
    Close #num 'fermeture
 
End Sub
 
 
Sub PDF_Choose()
 
Dim STRArray() As String
 
 
    On Error Resume Next
    ' Selection du document
    ChDrive ActiveWorkbook.Path
    ChDir ActiveWorkbook.Path
    DocName = Application.GetOpenFilename(Title:="Choisir le fichier de commentaires exporté", FileFilter:="Fichiers commentaires fdf *.fdf (*.fdf),")
    If DocName = False Then Exit Sub
 
    Application.ScreenUpdating = False
 
    Load ProofReader
    ProofReader.Show
 
'boucle for por report
 
    ThisWorkbook.Sheets("Report").Cells(22, 1) = ProofReader.nom & " " & ProofReader.prenom
    nom = ProofReader.nom
    ThisWorkbook.Sheets("Report").Cells(22, 6) = ProofReader.dpt
  dpt = ProofReader.dpt
 
   Unload ProofReader
 
    ' Recovery
    PDF_Parse (DocName)
 
    STRArray = Split(DocName, ".")
 
    extension = ".xlsx"
    FileSaveName = Application.GetSaveAsFilename(InitialFileName:=STRArray(0) & "_" & Initials & "_Comments_" & Format(Date, "dd") & Format(Date, "mm") & Format(Date, "yy") & extension, FileFilter:="Excel Sheet (*.xlsx), *.xlsx")
      If FileSaveName <> False Then
            ThisWorkbook.SaveAs Filename:=FileSaveName, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
      End If
End Sub