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
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
| Option Explicit
Private Declare Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long) As Long
Dim varColorText, varColorTag, varColorProp, varColorPropVal, varColorComment As OLE_COLOR
Dim regex1 As RegExp, regex2 As RegExp, regex3 As RegExp, regex4 As RegExp ' regex for highlighting
Dim matches As MatchCollection
Dim match As match
Dim cAppendStr As cAppendString
Dim rtfheader As String
Public Function Colorize(rtfTarget As RichTextBox)
' LockWindowUpdate rtfTarget.hWnd
Initialize
rtfTarget.TextRTF = colorhtml(rtfTarget.Text)
' LockWindowUpdate False
End Function
Private Function fcnGetRTFColor(ByVal Color As Variant) As String
'*** this function accepts a VB color (long)
'*** or a HTML color (string) and
'*** returns a RTF color table def.
Const sHEX = "0123456789ABCDEF"
Dim lngRed As Long, lngGreen As Long, lngBlue As Long
If VarType(Color) = vbLong Then
lngRed = Color Mod 256&
lngGreen = (Color Mod 65536) \ 256&
lngBlue = Color \ 65536
ElseIf VarType(Color) = vbString Then
'*** the string should be something like this: #D0D5DF
'*** strip of the right 6 chars
Color = Right$(Color, 6)
'*** find the position for each char in sHEX. Position is the value
lngRed = 16& * (InStr(1, sHEX, Mid$(Color, 1, 1), vbTextCompare) - 1) + _
1& * (InStr(1, sHEX, Mid$(Color, 2, 1), vbTextCompare) - 1)
lngGreen = 16& * (InStr(1, sHEX, Mid$(Color, 3, 1), vbTextCompare) - 1) + _
1& * (InStr(1, sHEX, Mid$(Color, 4, 1), vbTextCompare) - 1)
lngBlue = 16& * (InStr(1, sHEX, Mid$(Color, 5, 1), vbTextCompare) - 1) + _
1& * (InStr(1, sHEX, Mid$(Color, 6, 1), vbTextCompare) - 1)
Else
'*** this function accepts a VB color (long)
'*** or a HTML color (string) only.
Stop
End If
fcnGetRTFColor = "\red" & CStr(lngRed) & "\green" & CStr(lngGreen) & "\blue" & CStr(lngBlue) & ";"
End Function
Private Function Initialize()
'create regular expresions
'Regx to remove RTF meta characters
Set regex1 = New VBScript_RegExp_55.RegExp
regex1.Pattern = "([{}\\])"
regex1.IgnoreCase = False
regex1.Global = True
' Regx to remove RTF new lines
Set regex2 = New RegExp
regex2.Pattern = "(\r)"
regex2.IgnoreCase = False
regex2.Global = True
' Regx to get text/comments/tags
' This grabs all the text as seperate peices so we can use the very fast
' C append sting module to rebuild the rtf text.
Set regex3 = New RegExp
regex3.Pattern = "([^<]*)((<!-[\w\W]*?->)*)((<[^>]*>*)*)"
regex3.IgnoreCase = False
regex3.Global = True
' Regx to get properties/value pairs
Set regex4 = New RegExp
regex4.Pattern = "(\s\w[\w\d\s:_\-\.]*\s*=\s*)(""[^""]+""|'[^']+'|\d+)"
regex4.IgnoreCase = False
regex4.Global = True
Dim colortbl As String
' define fonts/ colors and create rtf header
varColorText = vbBlack
varColorTag = &HC00000
varColorProp = &HC000C0
varColorPropVal = &HC000&
varColorComment = &H808080
Dim rtfcolor(4) As String
rtfcolor(0) = fcnGetRTFColor(varColorText)
rtfcolor(1) = fcnGetRTFColor(varColorTag)
rtfcolor(2) = fcnGetRTFColor(varColorProp)
rtfcolor(3) = fcnGetRTFColor(varColorPropVal)
rtfcolor(4) = fcnGetRTFColor(varColorComment)
colortbl = Join(rtfcolor, "")
'add font header
rtfheader = "{\rtf1\ansi\ansicpg1252\deff0\deftab720{\fonttbl{\f0\fswiss MS Sans Serif;}{\f1\froman\fcharset2 Symbol;}{\f2\fswiss MS Sans Serif;}}" & vbCrLf
'add color header
rtfheader = rtfheader & "{\colortbl" & colortbl & "}" & vbCrLf
'add end header
'rtfheader = rtfheader & "\deflang1033\pard"
End Function
Private Function colorhtml(htmltext As String) As String
'lets time it
Set cAppendStr = New cAppendString
cAppendStr.Append rtfheader
'Escape Meta RTF chars using Regular expression
htmltext = regex1.Replace(htmltext, "\$1")
htmltext = regex2.Replace(htmltext, "\par \r")
' color text using regular expressions
Set matches = regex3.Execute(htmltext) ' Execute search.
For Each match In matches ' Iterate Matches collection.
cAppendStr.Append "\plain\f2\fs17\cf0 " & match.SubMatches(0) & "\plain\f2\fs17\cf4 " & match.SubMatches(1) & "\plain\f2\fs17\cf1"
cAppendStr.Append regex4.Replace(match.SubMatches(3), "\plain\f2\fs17\cf2 $1\plain\f2\fs17\cf3 $2\plain\f2\fs17\cf1 ")
Next
'add footer
cAppendStr.Append "}"
colorhtml = cAppendStr.Value
cAppendStr.Clear
End Function |
/u/2046/pooh2.png?f=community)
. (De maker weet helaas niet hoe hij fatsoenlijk moet coden, wat een zooi 
... maar dat is wel op te schonen)
. 
