Modifier une macro pour rajouter un test supplémentaire sur le résultat

Bonjour,

j'ai une macro qui me permet en chargeant un dictionnaire en mémoire, de définir si un texte est écrit en anglais ou en français.
Le test donne vrai si français et faux si anglais.

j'aurai besoin de votre aide car je souhaiterai rajouter dans cette macro un test supplémentaire : si faux alors vérifier dans le texte "faux" la présence des mots bonjour et/ou merci et/ou cordialement.
Si au moins un des trois mots est présent alors faux devient vrai

merci pour votre aide

ci-dessous la macro :

Code:

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
Public Function CheckFrench(ByVal pTexte As String) As Boolean
Dim lTexte As String
Dim lTempWord As String
Dim i As Long
Dim lCountFrench As Long
Dim TabWord
 
On Error GoTo err_check
 
'Remplit le dictionnaire des mots francais
Call Fill_French_Dictionnary
 
lTexte = LCase(pTexte)
'Remplace par des espaces
lTexte = Replace(lTexte, ",", " ")
lTexte = Replace(lTexte, ".", " ")
lTexte = Replace(lTexte, "-", " ")
lTexte = Replace(lTexte, "_", " ")
lTexte = Replace(lTexte, "?", " ")
lTexte = Replace(lTexte, "!", " ")
lTexte = Replace(lTexte, "(", " ")
lTexte = Replace(lTexte, ")", " ")
lTexte = Replace(lTexte, ":", " ")
lTexte = Replace(lTexte, ";", " ")
 
 
'Enleve
lTexte = Replace(lTexte, "=", "")
lTexte = Replace(lTexte, "#", "")
lTexte = Replace(lTexte, "*", "")
lTexte = Replace(lTexte, "@", "")
 
'On enleve les chiffres
lTexte = Replace(lTexte, "0", "")
lTexte = Replace(lTexte, "1", "")
lTexte = Replace(lTexte, "2", "")
lTexte = Replace(lTexte, "3", "")
lTexte = Replace(lTexte, "4", "")
lTexte = Replace(lTexte, "5", "")
lTexte = Replace(lTexte, "6", "")
lTexte = Replace(lTexte, "7", "")
lTexte = Replace(lTexte, "8", "")
lTexte = Replace(lTexte, "9", "")
lTexte = Replace(lTexte, "/", "")
lTexte = Replace(lTexte, "\", "")
 
'Remplace les doubles/triples/quadriples espaces par des simples
lTexte = Replace(lTexte, " ", " ")
lTexte = Replace(lTexte, " ", " ")
lTexte = Replace(lTexte, " ", " ")
 
 
'On utilise les espaces comme separation entre les mots (creation du tableau des mots)
TabWord = Split(lTexte, " ")
'Boucle sur les mots
For i = 0 To UBound(TabWord)
If m_DictFrench.Exists(Replace(TabWord(i), " ", "")) = True Then
lCountFrench = lCountFrench + 1
End If
Next
 
If UBound(TabWord) <> 0 Then
'Degre de confiance de 0.4 (40% des mots trouve sont des mots francais)
If lCountFrench / UBound(TabWord) > 0.4 Then
CheckFrench = True
Else
CheckFrench = False
End If
End If
 
Exit Function
err_check:
 
End Function

Code:

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
Private Sub Fill_French_Dictionnary()
Dim MyWord As String
 
On Error GoTo err_dict
 
If Not m_DictFrench Is Nothing Then
Exit Sub
Else
Set m_DictFrench = New Scripting.Dictionary
'
'Open m_DictFrenchLocation For Input As #1 ' Open file for input.
 
'Do While Not EOF(1) ' Loop until end of file.
' Input #1, MyWord ' Read data into two variables.
' Debug.Print MyWord ' Print data to the Immediate window.
'Loop
'Close #1 ' Close file.
 
Dim oFSO As New FileSystemObject
Dim oFS
 
Set oFS = oFSO.OpenTextFile(m_DictFrenchLocation)
 
Do Until oFS.AtEndOfStream
MyWord = oFS.ReadLine
'Debug.Print MyWord
m_DictFrench.Add MyWord, ""
Loop
End If
 
Exit Sub
err_dict:
MsgBox "Erreur lors de la lecture/remplissage du dictionnaire francais"
End Sub