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
| Function txtColorTohtml(ByVal msg As String)
Dim MyChar As String = ""
Dim MyChar2 As String = ""
Dim Couleur As String = "1"
Dim CouleurArr As String = "0"
Dim Co As String = ""
Dim gras As Boolean = False
Dim result As String = ""
Dim pattern As String = Chr(3) & "[0-9]{1,2},[0-9]{1,2}|" & Chr(3) & "[0-9]{1,2}|" & Chr(2) & "|" & Chr(3) & "|" & Chr(15)
Dim replacement As String = ""
Dim rgx As New Regex(pattern)
Dim msgPropre As String = rgx.Replace(msg, replacement)
Dim longueur As Integer = Len(msg)
For X As Integer = 1 To longueur
'Traitement des émoticons
MyChar2 = Mid(msgPropre, X, 2)
Select Case MyChar2
Case ":("
result &= "<img src='" & My.Computer.FileSystem.CurrentDirectory & "\Emoticons\triste.png' >"
Case ":)"
result &= "<img src='" & My.Computer.FileSystem.CurrentDirectory & "\Emoticons\smile.png' >"
Case "(L)"
result &= "<img src='" & My.Computer.FileSystem.CurrentDirectory & "\Emoticons\coeur.gif' >"
End Select
'Traitement de chaque caractère
MyChar = Mid(msg, X, 1)
Select Case MyChar
Case Chr(3)
Do While IsNumeric(Mid(msg, X, 1)) Or Mid(msg, X, 1) = "," Or Mid(msg, X, 1) = Chr(3)
Co = Co & Mid(msg, X, 1)
X = X + 1
Loop
Couleur = Replace(Co, Chr(3), "")
If InStr(Couleur, ",") <> 0 Then
CouleurArr = Mid(Couleur, InStr(Couleur, ",") + 1, Len(Couleur))
Couleur = Mid(Couleur, 1, InStr(Couleur, ",", CompareMethod.Text) - 1)
End If
If Len(Couleur) > 2 Then
Couleur = Mid(Couleur, 1, 2)
X = X - 1
End If
If Len(CouleurArr) > 2 Then
CouleurArr = Mid(CouleurArr, 1, 2)
X = X - 1
End If
X = X - 1
Co = ""
Case Chr(2)
gras = IIf(gras = False, True, False)
Case Else
If MyChar = Chr(1) Or MyChar = Chr(15) Or MyChar = Chr(31) Or MyChar = Chr(3) Or MyChar = Chr(2) Then MyChar = ""
If Couleur = "" Then Couleur = "1"
If CType(Couleur, Integer) > 15 Then Couleur = "1"
If CouleurArr = "" Then CouleurArr = "0"
If CType(CouleurArr, Integer) > 15 Then CouleurArr = "0"
If gras = True Then
result &= "<font color='" & coul(Couleur) & "' style='background-color:" & coul(CouleurArr) & ";' ><b>" & MyChar & "</b></font>"
Else
'result = msgPropre
result &= "<font color='" & coul(Couleur) & "' style='background-color:" & coul(CouleurArr) & ";' >" & MyChar & "</font>"
End If
End Select
Next
Return "<font size='1' face='Arial'>" & result & "</font>"
End Function
Private Function coul(ByVal num As Integer) As String
Select Case num
Case 0 : coul = "white"
Case 1 : coul = "black"
Case 2 : coul = "#00007f"
Case 3 : coul = "#009300"
Case 4 : coul = "#ff0000"
Case 5 : coul = "#7f0000"
Case 6 : coul = "#9c009c"
Case 7 : coul = "#fc7f00"
Case 8 : coul = "#ffff00"
Case 9 : coul = "#00fc00"
Case 10 : coul = "#009393"
Case 11 : coul = "#00ffff"
Case 12 : coul = "#0000fc"
Case 13 : coul = "#ff00ff"
Case 14 : coul = "#7f7f7f"
Case 15 : coul = "#d2d2d2"
Case Else : coul = "black"
End Select
End Function |
