Created
October 5, 2018 22:18
-
-
Save Mandorlo/a3978b77545763e80b3558b31b2c28f0 to your computer and use it in GitHub Desktop.
Librairie pour extraire des informations depuis des documents Office TODO nettoyer car il y a des fonctions qui ne servent à rien
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Const sep_postproc = ";" | |
| ' récupère une information d'un doc Word | |
| Function getObjectListDOC(ByVal fichier As String, ByVal myrules) | |
| ' on ouvre Word et le fichier | |
| Dim oWord As Word.Application | |
| Dim oDoc As Document | |
| Set oWord = New Word.Application | |
| If Mid(fichier, 2, 1) <> ":" Then | |
| fichier = ActiveWorkbook.path & "\" & fichier | |
| End If | |
| Set oDoc = oWord.Documents.Open(fichier, , True) | |
| ' pour chaque règle, on la parse | |
| Dim resultats As New Collection | |
| status_base = Application.StatusBar | |
| For Each Rule In myrules | |
| If Rule <> "" Then | |
| Application.StatusBar = status_base & " - extracting " & Rule | |
| el = getObjectDOC(oWord, oDoc, Rule) | |
| Else | |
| el = "" | |
| End If | |
| resultats.Add el | |
| Next Rule | |
| Application.StatusBar = status_base | |
| Set getObjectListDOC = resultats | |
| ' on ferme Word et le fichier | |
| oDoc.Close False | |
| oWord.Application.Quit | |
| Set oWord = Nothing | |
| End Function | |
| Function getObjectDOC(oWord As Word.Application, oDoc As Document, ByVal s_rule As String) | |
| Rule = parseRule(s_rule) | |
| Dim myObj As Variant | |
| If UBound(Rule) >= 1 Then | |
| ' on récupère les infos du paragraphe à chercher | |
| monpar = Rule(0) | |
| monstyle = Rule(1) | |
| ' on récupère le bon paragraphe | |
| Dim r As Object | |
| Set r = getRangeWORD(oWord, oDoc, monpar, monstyle) | |
| If Not r Is Nothing Then | |
| ' par défaut on se prépare pour renvoyer le texte brut du paragraphe r | |
| myObj = Right(r.Text, Len(r.Text) - Len(monpar)) | |
| ' on fait éventuellement du post-processing sur le paragraphe r qu'on a récupéré | |
| debut = True | |
| For i = 2 To UBound(Rule) | |
| If debut Then | |
| myObj = postProcessing(r, Rule(i), "object") | |
| debut = False | |
| Else | |
| myObj = postProcessing(myObj, Rule(i)) | |
| End If | |
| Next i | |
| getObjectDOC = myObj | |
| Else | |
| Debug.Print "Impossible de trouver le paragraphe " & monpar & " de style " & monstyle | |
| getObjectDOC = "" | |
| End If | |
| Else | |
| Debug.Print "La règle " & myrule & " est mal formée" | |
| End If | |
| End Function | |
| ' effectue du postprocessing défini par p sur le range r | |
| Function postProcessing(ByVal r, ByVal p As String, Optional ByVal mytype As String = "variant") As Variant | |
| p_arr = Split(p, sep_postproc) | |
| If UBound(p_arr) >= 0 Then | |
| ' extraire un tableau simple | |
| If p_arr(0) = "tab" And UBound(p_arr) > 0 And Not mytype = "variant" Then | |
| num_tab = CInt(p_arr(1)) | |
| If r.Tables.Count >= num_tab Then | |
| Set mytab = r.Tables(num_tab) | |
| postProcessing = wordtab2variant(mytab) | |
| End If | |
| ' extraire une liste à puces | |
| ElseIf p_arr(0) = "bullet" And Not mytype = "variant" Then | |
| postProcessing = wordbullet2variant(r) | |
| ' extraire les indices d'un tableau | |
| ElseIf p_arr(0) = "index" And UBound(p_arr) > 1 And mytype = "variant" And isArray(r) = 2 Then | |
| postProcessing = extractIndex(r, p_arr) | |
| ' faire une recherche sioux dans le tableau | |
| ElseIf p_arr(0) = "find" And UBound(p_arr) > 2 And mytype = "variant" And isArray(r) = 2 Then | |
| postProcessing = findTab(r, p_arr) | |
| ' nettoyer l'output avec une regex | |
| ElseIf p_arr(0) = "match" And UBound(p_arr) > 1 And mytype = "variant" Then | |
| s = join2D(r, p_arr(2)) | |
| postProcessing = RegexMatch(p_arr(1), s) | |
| If postProcessing = "" Then postProcessing = r | |
| ' todo | |
| Else | |
| Debug.Print "Invalid post-proc : " & p | |
| End If | |
| End If | |
| End Function | |
| ' [regex à trouver];[offset ligne];[offset colonne] | |
| ' offset ligne et colonne peuvent utiliser le ":" | |
| Function findTab(ByVal t As Variant, ByVal p_arr As Variant) As Variant | |
| arr = indexFind(t, p_arr(1)) | |
| If arr(0) > -1 And arr(1) > -1 Then | |
| filtre_lig = getFiltreIndex(p_arr(2), UBound(t, 1), CInt(arr(0))) | |
| filtre_col = getFiltreIndex(p_arr(3), UBound(t, 2), CInt(arr(1))) | |
| ' on extrait | |
| findTab = extractFiltreTab(t, filtre_lig, filtre_col) | |
| End If | |
| End Function | |
| ' renvoie le premier indice (l,c) dans t où la regex re est matchée | |
| Function indexFind(ByVal t As Variant, ByVal re As String) As Variant | |
| indexFind = Array(-1, -1) | |
| For i = 0 To UBound(t, 1) | |
| For j = 0 To UBound(t, 2) | |
| If re = t(i, j) Or RegexMatch(re, t(i, j)) <> "" Then | |
| indexFind = Array(i, j) | |
| Exit Function | |
| End If | |
| Next j | |
| Next i | |
| End Function | |
| ' extrait de manière intelligente des éléments de l'array 2D t | |
| Function extractIndex(ByVal t As Variant, ByVal p_arr As Variant) As Variant | |
| ligne = p_arr(1) | |
| col = p_arr(2) | |
| filtre_ligne = getFiltreIndex(ligne, UBound(t, 1)) | |
| filtre_col = getFiltreIndex(col, UBound(t, 2)) | |
| ' on extrait | |
| res = extractFiltreTab(t, filtre_ligne, filtre_col) | |
| extractIndex = res | |
| End Function | |
| ' extrait une partie de t en respectant le filtre | |
| Function extractFiltreTab(ByVal t As Variant, ByVal filtre_ligne As String, ByVal filtre_col) As Variant | |
| Dim res As Variant | |
| ReDim res(0) | |
| debut = True | |
| For i = 0 To UBound(t, 1) | |
| For j = 0 To UBound(t, 2) | |
| If InStr(filtre_ligne, "," & i & ",") > 0 And InStr(filtre_col, "," & j & ",") Then | |
| If debut Then | |
| res(0) = t(i, j) | |
| debut = False | |
| Else | |
| ReDim Preserve res(UBound(res) + 1) | |
| res(UBound(res)) = t(i, j) | |
| End If | |
| End If | |
| Next j | |
| Next i | |
| extractFiltreTab = res | |
| End Function | |
| ' pour nmax = 8, transforme qqc comme 1,3,5: en ,1,3,5,6,7,8, ou 0:-5 en ,0,1,2,3, | |
| Function getFiltreIndex(ByVal s As String, ByVal nmax As Integer, Optional ByVal off As Integer = 0) As String | |
| filtre = "," | |
| ' on crée les filtres lignes et col | |
| arr = Split(s, ",") | |
| For i = 0 To UBound(arr) | |
| arr2 = Split(arr(i), ":") | |
| dep = CInt(arr2(0)) + off | |
| If dep - off < 0 Then dep = nmax + dep + 1 - off | |
| If UBound(arr2) > 0 Then | |
| If arr2(1) = "" Then | |
| fin = nmax | |
| Else | |
| fin = CInt(arr2(1)) + off | |
| If fin - off < 0 Then fin = nmax + fin + 1 - off | |
| End If | |
| Else | |
| fin = dep | |
| End If | |
| For j = dep To fin | |
| filtre = filtre & j & "," | |
| Next j | |
| Next i | |
| getFiltreIndex = filtre | |
| End Function | |
| ' transforme une liste bullet points en variant (max 2 niveaux d'indentation) | |
| Function wordbullet2variant(word_bullet) As Variant | |
| ' on récupère le nombre de lignes et de colonnes | |
| Dim arr_bullet As Variant | |
| ReDim arr_bullet(word_bullet.ListParagraphs.Count - 2) | |
| For i = 0 To UBound(arr_bullet) | |
| If word_bullet.ListParagraphs(i + 2).Range.ListParagraphs.Count > 0 Then | |
| s = word_bullet.ListParagraphs(i + 2).Range.ListParagraphs(1).Range.Text | |
| For j = 2 To word_bullet.ListParagraphs(i + 2).Range.ListParagraphs.Count | |
| s = s & ";;" & word_bullet.ListParagraphs(i + 2).Range.ListParagraphs(j).Range.Text | |
| Next j | |
| arr_bullet(i) = s | |
| Else | |
| arr_bullet(i) = word_bullet.ListParagraphs(i + 2).Range.Text | |
| End If | |
| Next i | |
| wordbullet2variant = arr_bullet | |
| End Function | |
| ' transforme un tableau word en variant | |
| Function wordtab2variant(word_table) As Variant | |
| Dim arr_tab As Variant | |
| ReDim arr_tab(word_table.Rows.Count - 1, word_table.Columns.Count - 1) | |
| For i = 1 To word_table.Range.Cells.Count | |
| ligne = word_table.Range.Cells(i).RowIndex | |
| col = word_table.Range.Cells(i).ColumnIndex | |
| ' les 2 lignes suivantes permettent d'enlever les caractères spéciaux moches | |
| s = word_table.Range.Cells(i).Range.Text | |
| If Len(s) > 1 Then s = Left(s, Len(s) - 2) | |
| arr_tab(ligne - 1, col - 1) = s | |
| Next i | |
| wordtab2variant = arr_tab | |
| End Function | |
| ' parse une règle sous forme de string en objet définissant une règle | |
| Function parseRule(ByVal r As String) As Variant | |
| parseRule = Split(r, "@") | |
| End Function | |
| Function getObjectDOC2(ByVal fichier As String, ByVal masection As String, ByVal element As String) As Variant | |
| tmparr = Split(element, "@") | |
| Dim tabWord As New Collection | |
| If UBound(tmparr) >= 1 Then | |
| ' on ouvre le fichier word | |
| Dim oWord As Word.Application | |
| Dim oDoc As Document | |
| Set oWord = New Word.Application | |
| Set oDoc = oWord.Documents.Open(fichier, , True) | |
| ' on récupère les infos du paragraphe à chercher | |
| monpar = tmparr(0) | |
| monstyle = tmparr(1) | |
| ' on récupère le bon paragraphe | |
| Set r = getRangeWORD(oWord, oDoc, monpar, monstyle) | |
| If Not r Is Nothing Then | |
| If UBound(tmparr) >= 2 Then | |
| ' on extrait le tableau avec choix par croix | |
| If Left(LCase(tmparr(2)), 4) = "tabx" Then | |
| num_tab = extractInt(tmparr(2)) | |
| Set mytab = r.Tables(num_tab) | |
| For i = 1 To mytab.Range.Cells.Count | |
| t = mytab.Range.Cells(i).Range.Text | |
| If RegexMatch("\[\s?x\s?\]", LCase(t)) <> "" And Len(t) < 7 Then | |
| GoTo breakfori | |
| End If | |
| Next i | |
| breakfori: | |
| j = i + 1 | |
| If j <= mytab.Range.Cells.Count Then t = mytab.Range.Cells(j).Range.Text | |
| While j <= mytab.Range.Cells.Count And Not (Len(t) < 7 And RegexMatch("\[\s?\]", t) <> "") | |
| tabWord.Add Left(t, Len(t) - 1) | |
| j = j + 1 | |
| If j <= mytab.Range.Cells.Count Then t = mytab.Range.Cells(j).Range.Text Else t = "[ ]" | |
| Wend | |
| If tabWord.Count > 0 Then | |
| getObjectDOC = coll2arr(tabWord) | |
| getObjectDOC = Join(getObjectDOC, ";;") | |
| End If | |
| ' ici on traite les tabx mais des anciens DAT donc avec de vraies cases à cocher (pas des X) | |
| ElseIf Left(LCase(tmparr(2)), 4) = "taby" Then | |
| On Error GoTo breakfori2 | |
| num_tab = extractInt(tmparr(2)) | |
| Set mytab = r.Tables(num_tab) | |
| For i = 1 To mytab.Range.Cells.Count | |
| Set coco = mytab.Range.Cells(i).Range.FormFields | |
| If coco.Count = 1 Then | |
| If coco(1).CheckBox.Default Then | |
| getObjectDOC = mytab.Range.Cells(i + 1).Range.Text | |
| GoTo breakfori2 | |
| End If | |
| End If | |
| Next i | |
| breakfori2: | |
| ' on extrait un tableau avec n colonnes (tab1C5 = premier tableau qui a 5 colonnes) | |
| ' on peut ajouter un offset : tab1C5off-1 | |
| ElseIf RegexMatch("tab[1-9]C[1-9]", LCase(tmparr(2))) <> "" Then | |
| num_tab = Int(RegexMatch("tab([1-9])C[1-9]", LCase(tmparr(2)))) | |
| If num_tab <= r.Tables.Count Then | |
| Set mytab = r.Tables(num_tab) | |
| nbcols = Int(RegexMatch("tab[1-9]c([0-9]{1,2})", LCase(tmparr(2)))) | |
| myoffset = RegexMatch("tab[1-9]c[0-9]{1,2}off(-?[1-9])", LCase(tmparr(2))) | |
| If myoffset = "" Then myoffset = 0 Else myoffset = Int(myoffset) | |
| ' on ignore la première ligne d'en-tête (donc on commence à la cellule nbcols+1) | |
| Dim ligne As Variant | |
| ReDim ligne(nbcols - 1) | |
| k = 1 ' car on ignore la ligne d'en-tête | |
| tabcroix = False | |
| While (k + 1) * nbcols <= mytab.Range.Cells.Count | |
| sauver = False | |
| For i = 0 To nbcols - 1 | |
| tmptext = mytab.Range.Cells(k * nbcols + i + 1 + myoffset).Range.Text | |
| If RegexMatch("\[[\sxX]\]", tmptext) <> "" Then tabcroix = True | |
| If RegexMatch("\[[xX]\]", tmptext) <> "" Then | |
| sauver = True | |
| 'on enlève les éventuels choix inutiles | |
| tmparr = Split(tmptext, vbCr) | |
| If UBound(tmparr) < 0 Then tmparr = Split(tmptext, vbCrLf) | |
| montexte = "" | |
| For j = 0 To UBound(tmparr) - 1 | |
| res = RegexMatch("(\[[xX]\]\s?)", tmparr(j)) | |
| If res <> "" Then | |
| ind = InStr(tmparr(j), res) | |
| If ind > 0 Then | |
| montexte = montexte & Right(tmparr(j), Len(tmparr(j)) - ind - Len(res) + 1) | |
| Else | |
| montexte = montexte & tmparr(j) & vbCr | |
| End If | |
| End If | |
| Next j | |
| If RegexMatch("\[\s\]", tmparr(UBound(tmparr))) = "" Then montexte = montexte & Left(tmparr(UBound(tmparr)), Len(tmparr(UBound(tmparr))) - 1) | |
| ligne(i) = montexte | |
| Else | |
| ligne(i) = Left(tmptext, Len(tmptext) - 1) | |
| End If | |
| Next i | |
| If sauver Or Not tabcroix Then | |
| tabWord.Add Join(ligne, "@@") | |
| End If | |
| k = k + 1 | |
| Wend | |
| If tabWord.Count > 0 Then | |
| getObjectDOC = coll2arr(tabWord) | |
| getObjectDOC = Join(getObjectDOC, ";;") | |
| End If | |
| End If | |
| ' on extrait une liste de choix par "[X]" | |
| ElseIf Left(LCase(tmparr(2)), 5) = "listx" Then | |
| texte = Right(r.Text, Len(r.Text) - Len(monpar)) | |
| textsplit = Split(texte, vbCr) | |
| getObjectDOC = "" | |
| For i = 0 To UBound(textsplit) | |
| m = RegexMatch("\[\s?[xX]\s?\] (.*)", textsplit(i)) | |
| If m <> "" Then | |
| getObjectDOC = getObjectDOC & m & ";;" | |
| End If | |
| Next i | |
| getObjectDOC = Left(getObjectDOC, maxint(Len(getObjectDOC) - 2, 0)) | |
| ' si ça marche pas, c'est que le modèle est peut-être un peu vieux, donc on essaie les checkbox | |
| If getObjectDOC = "" Then | |
| Set mycheckboxes = r.FormFields | |
| For i = 1 To mycheckboxes.Count | |
| If mycheckboxes(i).CheckBox.Default Then | |
| mycheckboxes(i).Select | |
| oWord.Selection.StartOf Unit:=wdParagraph | |
| oWord.Selection.MoveEnd Unit:=wdParagraph | |
| montexte = oWord.Selection.Text | |
| getObjectDOC = getObjectDOC & Right(montexte, Len(montexte) - 2) | |
| End If | |
| Next i | |
| End If | |
| ' on extrait une regex | |
| ElseIf Left(LCase(tmparr(2)), 5) = "regex" Then | |
| reg = Right(tmparr(2), Len(tmparr(2)) - 5) | |
| texte = Right(r.Text, Len(r.Text) - Len(monpar)) | |
| getObjectDOC = RegexMatch(reg, texte, ";;") | |
| ' on extrait une image | |
| ElseIf RegexMatch("img[1-9]#", LCase(tmparr(2))) <> "" Then | |
| num_img = Int(RegexMatch("img([1-9])#", LCase(tmparr(2)))) | |
| nom_image = Split(tmparr(2), "#")(1) | |
| If num_img <= r.InlineShapes.Count Then | |
| On Error Resume Next | |
| r.InlineShapes(num_img).Range.CopyAsPicture | |
| If Err Then r.InlineShapes(num_img + 1).Range.CopyAsPicture | |
| On Error GoTo cestlafin | |
| da = dossier_images | |
| rndname = Str(Int(Math.Rnd() * 10000000000#)) | |
| path = da & "\" & nom_image & "_" & rndname & ".png" | |
| compteur = 0 | |
| While fileExists(path) And compteur < 1000 | |
| rndname = Str(Int(Math.Rnd() * 10000000000#)) | |
| path = da & "\" & nom_image & "_" & rndname & ".png" | |
| compteur = compteur + 1 | |
| Wend | |
| If compteur >= 1000 Then | |
| Debug.Print "SAVE IMAGE ERROR from " & fichier | |
| Else | |
| SaveClipBoardImage path | |
| getObjectDOC = path | |
| End If | |
| End If | |
| Else | |
| getObjectDOC = Right(r.Text, Len(r.Text) - Len(monpar)) | |
| End If | |
| ' on post-processe la chaîne | |
| For i = 2 To UBound(tmparr) | |
| getObjectDOC = Trim(postProc(getObjectDOC, tmparr(i))) | |
| Next i | |
| ' on extrait simplement le texte du paragraphe | |
| Else | |
| getObjectDOC = Right(r.Text, Len(r.Text) - Len(monpar)) | |
| End If | |
| Else | |
| 'MsgBox "Paragraphe introuvable :(" | |
| getObjectDOC = "" | |
| End If | |
| ' on ferme le document word | |
| cestlafin: | |
| oDoc.Close False | |
| oWord.Application.Quit | |
| Set oWord = Nothing | |
| On Error GoTo 0 | |
| End If | |
| End Function | |
| ' récupère un objet excel | |
| Function getObjectXLS(ByVal fichier As String, ByVal element As String) As String | |
| Dim arr As Variant | |
| tmp_element = Split(element, "--") | |
| If UBound(tmp_element) = 2 Then | |
| ' on détecte le format du fichier | |
| maversion = getTDSVersion(fichier) | |
| fr = getFeuillePlage(maversion, tmp_element) | |
| feuille = fr(0) | |
| plage = fr(1) | |
| If feuille = "" Or plage = "" Then Exit Function | |
| ' on extrait l'élément | |
| If InStr(plage, ";") > 0 Then | |
| plages = Split(plage, ";") | |
| If UBound(plages) < 0 Then Exit Function | |
| getObjectXLS = arr2str(getRangeXLS(fichier, feuille, plages(i))) | |
| For i = 1 To UBound(plages) | |
| arr = getRangeXLS(fichier, feuille, plages(i)) | |
| getObjectXLS = getObjectXLS & sep_array_lig & arr2str(arr) | |
| Next i | |
| Else | |
| arr = getRangeXLS(fichier, feuille, plage) | |
| getObjectXLS = arr2str(arr) | |
| End If | |
| End If | |
| End Function | |
| '===================================================== NIV 2 ================================================================= | |
| Function getFeuillePlage(ByVal maversion As String, ByVal tmp_element As Variant) As Variant | |
| If maversion = "2015" Then | |
| If Left(tmp_element(0), 4) = "VAL_" Then | |
| feuille = "Accueil" | |
| plage = tmp_element(0) | |
| Else | |
| feuille = "Architecture" | |
| plage = "TAB_SERVEURS[" & tmp_element(0) & "]" | |
| End If | |
| ElseIf maversion = "2014" Then | |
| tmp_fr = Split(tmp_element(1), "@") | |
| If UBound(tmp_fr) = 1 Then | |
| feuille = tmp_fr(0) | |
| plage = tmp_fr(1) | |
| Else | |
| addErrParse "SYNTAX ERROR in " & element | |
| End If | |
| ElseIf maversion = "2013" Then | |
| tmp_fr = Split(tmp_element(2), "@") | |
| If UBound(tmp_fr) = 1 Then | |
| feuille = tmp_fr(0) | |
| plage = tmp_fr(1) | |
| Else | |
| addErrParse "SYNTAX ERROR in " & element | |
| End If | |
| End If | |
| getFeuillePlage = Array(feuille, plage) | |
| End Function | |
| ' renvoie la version du TDS fourni en entrée : 2013, 2014, 2015 ou inconnu | |
| Function getTDSVersion(ByVal fichier As String) As String | |
| getTDSVersion = "inconnu" | |
| Dim oExcel As Excel.Application | |
| Dim oWB As Workbook | |
| initialisation | |
| On Error GoTo openexcelerr | |
| If fileExists(fichier) Then | |
| Set oExcel = New Excel.Application | |
| Set oWB = oExcel.Workbooks.Open(fichier) | |
| If sheetExists(oWB, "Architecture") Then | |
| getTDSVersion = "2015" | |
| ElseIf sheetExists(oWB, "Niveaux de services") Then | |
| getTDSVersion = "2013" | |
| ElseIf sheetExists(oWB, "Synthèse serveurs logiques") Then | |
| getTDSVersion = "2014" | |
| End If | |
| oWB.Close False | |
| oExcel.Application.Quit | |
| Set oExcel = Nothing | |
| End If | |
| openexcelerr: | |
| If Err <> 0 Then | |
| On Error Resume Next | |
| 'oWB.Close False | |
| 'oExcel.Application.Quit | |
| Set oExcel = Nothing | |
| Debug.Print "Erreur lors de l'ouverture de " & fichier & vbCr & vbCr & Err.Description | |
| On Error GoTo 0 | |
| End If | |
| End Function | |
| ' récupère une plage Excel | |
| Function getRangeXLS(ByVal fichier As String, ByVal feuille As String, ByVal plage As String) As Variant | |
| Dim oExcel As Excel.Application | |
| Dim oWB As Workbook | |
| If Not is_init Then initialisation | |
| On Error GoTo openexcelerr | |
| Set oExcel = New Excel.Application | |
| Set oWB = oExcel.Workbooks.Open(fichier) | |
| ' on gère le cas de plages variables | |
| If InStr(plage, "*") > 0 Then | |
| tmparr = Split(plage, ":") | |
| lastrow = oWB.Sheets(feuille).Range(tmparr(0)).End(xlDown).Row | |
| If lastrow - extractInt(tmparr(0)) > 70 Then | |
| lastrow = smartLastRow(oWB, feuille, tmparr(0)) | |
| End If | |
| plage = Replace(plage, "*", lastrow) | |
| End If | |
| ' on récupère la plage | |
| getRangeXLS = oWB.Sheets(feuille).Range(plage) | |
| oWB.Close False | |
| oExcel.Application.Quit | |
| Set oExcel = Nothing | |
| openexcelerr: | |
| If Err <> 0 Then | |
| Debug.Print "Erreur lors de l'ouverture de " & fichier & vbCr & vbCr & Err.Description | |
| End If | |
| End Function | |
| ' renvoie le range word correspondant au paragraphe spécifié | |
| ' il faut donner en entrée le paragraphe à chercher et son style | |
| Function getRangeWORD(ByVal oWord, ByVal oDoc As Document, ByVal monpar As String, Optional ByVal monstyle As String = "") | |
| Set getRangeWORD = Nothing | |
| On Error GoTo fin | |
| If monpar = "" Then | |
| Set getRangeWORD = oDoc.Range | |
| Exit Function | |
| End If | |
| ' on cherche le premier heading | |
| oWord.Selection.HomeKey Unit:=wdStory | |
| With oWord.Selection.Find | |
| .ClearFormatting 'Always clear find formatting | |
| .Style = oDoc.Styles(monstyle) | |
| .Text = monpar | |
| .Replacement.Text = "" 'We are not replacing the text | |
| .Forward = True 'Move forward so we can each consecutive heading | |
| .Wrap = wdFindContinue 'Continue to the next find | |
| .Format = True | |
| .MatchCase = True | |
| .MatchWholeWord = False | |
| .MatchWildcards = False | |
| .MatchSoundsLike = False | |
| .MatchAllWordForms = False | |
| .Execute | |
| compt = 0 | |
| oWord.Selection.StartOf Unit:=wdParagraph | |
| oWord.Selection.MoveEnd Unit:=wdParagraph | |
| While (InStr(normaliser(monpar), normaliser(oWord.Selection.Text)) <= 0 Or Len(normaliser(oWord.Selection.Text)) = 0) And compt < 10 | |
| For i = 0 To compt | |
| .Execute | |
| Next i | |
| oWord.Selection.StartOf Unit:=wdParagraph | |
| oWord.Selection.MoveEnd Unit:=wdParagraph | |
| compt = compt + 1 | |
| Wend | |
| End With | |
| fin: | |
| ' on cherche le heading d'après | |
| On Error GoTo termine | |
| If compt < 10 Then | |
| debut = oWord.Selection.Range.Start | |
| Set r = oDoc.Range(Start:=oWord.Selection.Range.End) | |
| sautepremier = False | |
| For Each p In r.Paragraphs | |
| aaa = p.Range.Text | |
| If Not p.Range.Style Is Nothing And sautepremier Then | |
| If Left(p.Range.Style, 3) = "Tit" Or Left(p.Range.Style, 3) = "Edf" Then | |
| 'truc = (normaliser(Left(p.Range.Text, Len(p.Range.Text) - 1)) = normaliser(monpar)) | |
| If (p.Range.Style = monstyle Or monstyle = "" Or Left(p.Range.Style, 5) = "Titre") Then | |
| fin = p.Range.Start | |
| Set getRangeWORD = oDoc.Range(Start:=debut, End:=fin) | |
| Exit Function | |
| End If | |
| End If | |
| End If | |
| sautepremier = True | |
| Next p | |
| Set getRangeWORD = Nothing | |
| End If | |
| termine: | |
| Set getRangeWORD = Nothing | |
| End Function | |
| ' post-processe la chaîne "s" selon le mode "pp" | |
| ' pp = extractint | ifreg[reg]#[val_si_oui]#[val_si_non] | |
| Function postProc(ByVal s As String, ByVal pp As String) As String | |
| If Left(LCase(pp), 10) = "extractint" Then ' EXTRACTINT | |
| n = extractInt(pp) | |
| If n = 0 Then n = 1 | |
| postProc = extractInt(s, n) | |
| ElseIf Left(LCase(pp), 5) = "ifreg" Then ' IFREG | |
| brut = Right(pp, Len(pp) - 5) | |
| splitbrut = Split(brut, "#") | |
| If UBound(splitbrut) = 2 Then | |
| myreg = splitbrut(0) | |
| m = RegexMatch(myreg, s) | |
| If m <> "" Then | |
| postProc = splitbrut(1) | |
| Else | |
| postProc = splitbrut(2) | |
| End If | |
| If postProc = "$" Then postProc = m | |
| If postProc = "" Then postProc = s | |
| Else | |
| postProc = s | |
| End If | |
| Else | |
| postProc = s | |
| End If | |
| End Function | |
| ' renvoie "###" si l'objet n'existe pas, ou sa valeur s'il est calculé | |
| Function objectExists(ByVal obj_name As String) As String | |
| Dim plage, evalplage As Range | |
| Set plage = ActiveWorkbook.Sheets("Objets").Range("tab_objets[Objet]") | |
| Set evalplage = ActiveWorkbook.Sheets("Objets").Range("tab_objets[GetObject]") | |
| objectExists = "###" | |
| For i = 1 To plage.Rows.Count | |
| If plage.Rows(i).Value = obj_name Then | |
| objectExists = evalplage.Rows(i).Value | |
| Exit Function | |
| End If | |
| Next i | |
| End Function | |
| ' renvoie le numéro de la dernière ligne non vide du tableau dans lequel se trouve la cellule "plage" | |
| Function smartLastRow(ByVal wb As Workbook, ByVal feuille As String, ByVal plage As String) As Integer | |
| Dim source As Range | |
| Set source = wb.Sheets(feuille).Range(plage) | |
| maxi = 300 | |
| smartLastRow = source.End(xlDown).Row | |
| For c = 0 To 5 | |
| i = 1 | |
| While source.Offset(i, c).Value <> "" And i < maxi | |
| i = i + 1 | |
| Wend | |
| If (i + source.Row > smartLastRow And i < 80) Or (i + source.Row < smartLastRow And i > 1) Then | |
| smartLastRow = i + source.Row | |
| End If | |
| Next c | |
| End Function | |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment