Option Base 1
'Sub Laurent3()
Function ExtractTelPortLaurent(Chaine As String, chx As Integer) As Variant
' initianlisation des variables
'Dim Chaine As String
'Pitaluga a plusieurs Nº de téléphone : 06 66 99 55 76 & 094 54 20 44 & 099 925 301 & 06 300 200 11
'Chaine = "Pitaluga a plusieurs Nº de téléphone : 06 77 99 55 76 & 06 66 99 55 76 & 094 54 20 44 & 099 925 301 & 06 300 200 11"
' "(([0])([6]\s*)([0-9]{2}\s*){4})" = 06 66 99 55 76
' "(([0])([0-9])([0-9]\s*)([0-9]{2}\s*){3})" = 094 54 20 44
' "(([0])([0-9])([0-9]\s*)([0-9]{3}\s*){2})" = 099 925 301
' "(([0])([6]\s*)([0-9]{3}\s*){2}([0-9]{2}\s*))" =06 300 200 11
TabRch = Array("(([0])([6]\s*)([0-9]{2}\s*){4})", _
"(([0])([0-9])([0-9]\s*)([0-9]{2}\s*){3})", _
"(([0])([0-9])([0-9]\s*)([0-9]{3}\s*){2})", _
"(([0])([6]\s*)([0-9]{3}\s*){2}([0-9]{2}\s*))")
'*** ------------------------------------------------------------------------------
' Tableau d'objet
Dim Tabreg() As Object
ReDim Tabreg(LBound(TabRch) To UBound(TabRch))
Dim TabMatch() As Object
ReDim TabMatch(LBound(TabRch) To UBound(TabRch))
Dim TabMatches() As Object
ReDim TabMatches(LBound(TabRch) To UBound(TabRch))
'*** ------------------------------------------------------------------------------
' Créer un tableau pour stocké les numéros de telephones
Dim x As Variant
Dim TabNum() As Variant
x = 0
ReDim TabNum(0 To x)
Dim y As Variant
Dim TabNumPos() As Variant
y = 0
ReDim TabNumPos(0 To y)
'*** ------------------------------------------------------------------------------
For i = LBound(Tabreg) To UBound(Tabreg)
Set Tabreg(i) = CreateObject("vbscript.regexp")
' ici laissé pour l'ordre !
'Chaine = "Pitaluga a plusieurs Nº de téléphone : 06 66 99 55 76 & 094 54 20 44 & 099 925 301 & 06 300 200 11"
'Le Pattern est le motif que l'on recherche
Tabreg(i).Pattern = TabRch(i)
' Active ou non la recherche sur plusieurs lignes à la fois / La propriété est mise sur False par défaut.
Tabreg(i).MultiLine = False
' Précise si la recherche est sensible ou non à la casse (majuscules/minuscules) / La propriété est mise sur False par défaut.
Tabreg(i).IgnoreCase = True
' Précise si la recherche porte sur la première occurence ou sur toutes / La propriété est mise sur False par défaut.
Tabreg(i).Global = True
'le test renvoie un Boolean (parfait pour notre fonction Booléenne!!!)
'MsgBox Tabreg(i).test(Chaine)
' Cette méthode permet d'explorer les occurences qui vérifient le Pattern.
Set TabMatches(i) = Tabreg(i).Execute(Chaine)
For Each TabMatch(i) In TabMatches(i)
'MsgBox TabMatch(i).Value
TabNum(x) = TabMatch(i).Value
x = x + 1
ReDim Preserve TabNum(0 To x)
'MsgBox TabMatch(i).firstindex
TabNumPos(y) = TabMatch(i).firstindex
y = y + 1
ReDim Preserve TabNumPos(0 To y)
'Debug.Print "source >>", TabMatch(i).Value
'For j = 0 To TabMatch(i).SubMatches.Count - 1
' Debug.Print "[$" & j + 1 & "]", TabMatch(i).SubMatches(j)
'Debug.Print TabRch(i), TabMatch(i).SubMatches(j)
'Next j
Next TabMatch(i)
Next i
'*** ------------------------------------------------------------------------------
' Transfer des deux tableaux une dimension dans le tableau final
Dim TabFinal() As Variant
ReDim TabFinal(LBound(TabNum) To UBound(TabNum) - 1, 0 To 2)
'MsgBox UBound(TabNum) - 1
For i = LBound(TabFinal) To UBound(TabFinal)
' Numéro de telephone
TabFinal(i, 0) = TabNum(i)
' Position dans la chaine
TabFinal(i, 1) = TabNumPos(i)
Next i
' Fuction
' Tri d'un tableau (Array) à 2 dimensions
' ici sur la colonne 1
Tri TabFinal(), 1, LBound(TabFinal, 1), UBound(TabFinal, 1)
'*** ------------------------------------------------------------------------------
' Ordre des numéro de téléphonnes dans la chaine de caractéres
cpt = 1
For i = LBound(TabFinal) To UBound(TabFinal)
' Position dans la chaine
TabFinal(i, 2) = cpt
cpt = cpt + 1
Next i
'*** ------------------------------------------------------------------------------
' Resultat
'MsgBox chx - 1
'MsgBox TabFinal(chx - 1, 0)
'*** ------------------------------------------------------------------------------
'Remplace les espaces doubles (voire davantage) par un seul espace
'Exemple : SingleSpaceBetweenWords("03 55 21 13) ---> 03 55 21 13
' Function de Magic
Do While InStr(1, TabFinal(chx - 1, 0), " ") > 0
TabFinal(chx - 1, 0) = Replace(TabFinal(chx - 1, 0), " ", " ")
Loop
'*** ------------------------------------------------------------------------------
ExtractTelPortLaurent = Trim(TabFinal(chx - 1, 0))
End Function
Sub Tri(a(), ColTri, gauc, droi) ' Quick sort
ref = a((gauc + droi) \ 2, ColTri)
g = gauc: d = droi
Do
Do While a(g, ColTri) < ref: g = g + 1: Loop
Do While ref < a(d, ColTri): d = d - 1: Loop
If g <= d Then
For k = LBound(a, 2) To UBound(a, 2)
temp = a(g, k): a(g, k) = a(d, k): a(d, k) = temp
Next k
g = g + 1: d = d - 1
End If
Loop While g <= d
If g < droi Then Call Tri(a, ColTri, g, droi)
If gauc < d Then Call Tri(a, ColTri, gauc, d)
End Sub
