Public Sub MajTableDef()
Dim l_as_geoDefsInfos() As String
Dim l_o_dicoTocLinks As Object 'Scripting.Dictionary
Dim l_l_iDef As Long
Dim l_s_subAddress As String
Dim l_o_table As Word.Table
'récupérer la table listant les définitions
Set l_o_table = ThisDocument.Tables(1)
'la vider, sauf la ligne d'entête et la première ligne de données
With l_o_table
Do While .Rows.Count > 2
.Rows(3).Delete
Loop
End With
'extraire les définitions et les liens des tables des matières
l_as_geoDefsInfos = ExtractGeoDefsInfos(ThisDocument)
Set l_o_dicoTocLinks = ExtractTocLinks(ThisDocument)
'boucler sur toutes les définitions trouvées
For l_l_iDef = 1 To UBound(l_as_geoDefsInfos, 1)
'ajouter les données au tableau
With l_o_table.Rows.Add
l_s_subAddress = SearchGeoDefTocLink(l_o_dicoTocLinks, l_as_geoDefsInfos(l_l_iDef, 1))
.Cells(1).Range.Hyperlinks.Add .Cells(1).Range, , l_s_subAddress, , l_as_geoDefsInfos(l_l_iDef, 1)
.Cells(2).Range.Text = l_as_geoDefsInfos(l_l_iDef, 2)
.Cells(3).Range.Text = l_as_geoDefsInfos(l_l_iDef, 3)
End With
Next l_l_iDef
'supprimer la première ligne de données
l_o_table.Rows(2).Delete
End Sub
'Private Function SearchGeoDefTocLink(p_o_dicoTocLinks As Scripting.Dictionary, p_s_geoDef As String) As String
Private Function SearchGeoDefTocLink(p_o_dicoTocLinks As Object, p_s_geoDef As String) As String
Static s_o_dicoTocLinks As Object 'Scripting.Dictionary
Static s_av_dicoKeys() As Variant
Static s_l_nbKeys As Long
Dim l_l_i As Long
If Not s_o_dicoTocLinks Is p_o_dicoTocLinks Then
Set s_o_dicoTocLinks = p_o_dicoTocLinks
s_av_dicoKeys = s_o_dicoTocLinks.Keys()
s_l_nbKeys = s_o_dicoTocLinks.Count
End If
For l_l_i = 0 To s_l_nbKeys - 1
If UCase(s_av_dicoKeys(l_l_i)) Like UCase("*" & p_s_geoDef & "*") Then
SearchGeoDefTocLink = s_o_dicoTocLinks.Item(s_av_dicoKeys(l_l_i))
Exit Function
End If
Next l_l_i
End Function
Private Function ExtractGeoDefsInfos(p_o_doc As Word.Document) As String()
Const c_s_styleT1 As String = "Géo_Titre1"
Const c_s_styleT2 As String = "Géo_Titre2"
Const c_s_styleGeoDef As String = "Géo_Déf T1"
Dim l_s_T1 As String
Dim l_s_T2 As String
Dim l_as_infos() As String
Dim l_as_res() As String
Dim l_l_nbDefs As Long
Dim l_l_nbInfos As Long
Dim l_l_i As Long
Dim l_l_j As Long
Dim l_l_k As Long
Dim l_s_tmp As String
Dim l_o_paragraph As Word.Paragraph
ReDim l_as_infos(1 To 3, 1 To 1)
l_l_nbDefs = 0
'extraire les définitions
For Each l_o_paragraph In p_o_doc.Paragraphs
Select Case l_o_paragraph.Style
Case c_s_styleT1
l_s_T1 = CleanParagraphText(l_o_paragraph.Range.ListFormat.ListString & l_o_paragraph.Range.Text)
Case c_s_styleT2
l_s_T2 = CleanParagraphText(l_o_paragraph.Range.ListFormat.ListString & l_o_paragraph.Range.Text)
Case c_s_styleGeoDef
l_l_nbDefs = l_l_nbDefs + 1
ReDim Preserve l_as_infos(1 To 3, 1 To l_l_nbDefs)
l_as_infos(1, l_l_nbDefs) = CleanParagraphText(l_o_paragraph.Range.Text)
l_as_infos(2, l_l_nbDefs) = l_s_T1
l_as_infos(3, l_l_nbDefs) = l_s_T2
End Select
Next l_o_paragraph
'transposer les définitions
l_l_nbInfos = UBound(l_as_infos, 1)
ReDim l_as_res(1 To l_l_nbDefs, 1 To l_l_nbInfos)
For l_l_i = 1 To l_l_nbDefs: For l_l_j = 1 To l_l_nbInfos
l_as_res(l_l_i, l_l_j) = l_as_infos(l_l_j, l_l_i)
Next l_l_j, l_l_i
'trier les définitions
For l_l_i = 1 To l_l_nbDefs - 1: For l_l_j = l_l_i + 1 To l_l_nbDefs
If UCase(l_as_res(l_l_j, 1)) < UCase(l_as_res(l_l_i, 1)) Then
For l_l_k = 1 To l_l_nbInfos
l_s_tmp = l_as_res(l_l_j, l_l_k)
l_as_res(l_l_j, l_l_k) = l_as_res(l_l_i, l_l_k)
l_as_res(l_l_i, l_l_k) = l_s_tmp
Next l_l_k
End If
Next l_l_j, l_l_i
ExtractGeoDefsInfos = l_as_res
End Function
Private Function CleanParagraphText(p_s_text As String) As String
CleanParagraphText = p_s_text
If CleanParagraphText Like "*" & vbCr Then CleanParagraphText = Left(CleanParagraphText, Len(CleanParagraphText) - 1)
CleanParagraphText = Strings.Trim(CleanParagraphText)
End Function
Private Function ExtractTocLinks(p_o_doc As Word.Document) As Object 'Scripting.Dictionary
Dim l_o_hl As Word.Hyperlink
Dim l_o_toc As Word.TableOfContents
Dim l_s_txt As String
Set ExtractTocLinks = CreateObject("Scripting.Dictionary")
For Each l_o_toc In p_o_doc.TablesOfContents
For Each l_o_hl In l_o_toc.Range.Hyperlinks
l_s_txt = l_o_hl.Range.Text
If Not ExtractTocLinks.Exists(l_s_txt) Then ExtractTocLinks.Add l_s_txt, l_o_hl.SubAddress
Next l_o_hl
Next l_o_toc
End Function
