This repository was archived by the owner on Jan 22, 2022. It is now read-only.
-
Notifications
You must be signed in to change notification settings - Fork 4
Expand file tree
/
Copy pathCSS-HTML.BAS
More file actions
183 lines (143 loc) · 5.78 KB
/
CSS-HTML.BAS
File metadata and controls
183 lines (143 loc) · 5.78 KB
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
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
Public Type CSS_Style
sName As String
sStyle As String
End Type
Function cssToString(css As CSS_Style) As String
'Css to string without vbCrLf
'cssToString = "." & css.sName & " {" & css.sStyle & "}"
Dim cssSubParts As String: cssSubParts = Replace(css.sStyle, ";", ";" & vbCrLf)
cssSubParts = Left(cssSubParts, Len(cssSubParts) - Len(vbCrLf))
cssToString = "." & css.sName & "{" & vbCrLf & _
sTabs(cssSubParts, 1) & vbCrLf & _
"}"
End Function
Sub removeCSS(css As CSS_Style, ByVal sName As String)
'Takes some cssString e.g.
' "color:#FFFF00;background-color:#ff0000;float:left;"
'and removes the value named sName. E.G. if sName = "background-color" then
' return "color:#FFFF00;float:left;"
'Might want to loop this in case duplicates in css exist
Dim iStt, iEnd As Integer
iStt = InStr(1, ";" & css.sStyle, ";" & sName & ":") - 1
iEnd = InStr(iStt + 1, css.sStyle, ";")
css.sStyle = Left(css.sStyle, iStt) & Mid(css.sStyle, iEnd + 1)
End Sub
Sub addCSS(css As CSS_Style, ByVal sName As String, ByVal sValue As String)
'sName - the name of the css 'type' that you want to add
'sValue - the value of the css 'type' that you want to set
'e.g:
'background-color:#ff0000
' >>> sName = "background-color" , sValue = "#ff0000"
css.sStyle = sName & ":" & sValue & ";" & css.sStyle
End Sub
Sub replaceCSS(css As CSS_Style, ByVal sName As String, sValue As String)
'combines addCSS and removeCSS to replace existing CSS in a string
removeCSS css, sName
addCSS css, sName, sValue
End Sub
Sub replaceCSSColor(css As CSS_Style, ByVal sName As String, ByVal iColour As Integer)
'Get hexadecimal value of rgb color
Dim rgbHex As String
rgbHex = Hex(iColour)
rgbHex = String(6 - Len(rgbHex), "0") & rgbHex
'Change hexadecimal string (including #)
replaceCSS css, sName, "#" & rgbHex
End Sub
Function newCSSDefault(ByVal sName As String) As CSS_Style
Dim css As CSS_Style
css.sName = sName
css.sStyle = "float:left;clear:both;"
newCSSDefault = css
End Function
'Testing script
Sub test()
'Initialise css
Dim css As CSS_Style
css = newCSSDefault("Error")
'Add CSS
addCSS css, "background-color", "#ff0000"
addCSS css, "color", "#FFFF00"
Debug.Print cssToString(css)
'change html color
replaceCSS css, "background-color", "red"
Debug.Print cssToString(css)
'add rgb color
replaceCSSColor css, "background-color", RGB(255, 0, 0)
Debug.Print cssToString(css)
End Sub
Function wrapInHTMLTag(ByVal toWrap As String, tag As String, Optional tagParams As String = "")
'seperate tagParams from tag if exists
If tagParams <> "" Then tagParams = " " & tagParams
'return wrapped XML
wrapInHTMLTag = "<" & tag & tagParams & ">" & vbCrLf & sTabs(toWrap, 1) & vbCrLf & "</" & tag & ">"
End Function
Function sTabs(ByVal toTab As String, ByVal numTabs As Integer) As String
Dim tabStr As String: tabStr = String(numTabs, vbTab)
sTabs = tabStr & Replace(toTab, vbCrLf, vbCrLf & tabStr)
End Function
Function sHTMLHeader(sTitle As String, sStyles As String, Optional miscTags As String = "")
'create title and add (create?) styles
Dim sInnerHTML As String
sInnerHTML = wrapInHTMLTag(sTitle, "title") & vbCrLf & sStyles
'If miscTags provided, add them to the inner html
If miscTags <> "" Then sInnerHTML = sInnerHTML & vbCrLf & miscTags
'return inner html wrapped in header tags
sHTMLHeader = wrapInHTMLTag(sInnerHTML, "header")
End Function
Function sHtmlStyles(col() As CSS_Style) As String
'Concatenate all CSS into one long string
Dim ret As String, css As CSS_Style
'For Each css In col
' ret = ret & cssToString(css) & vbCrLf
'Next css
For i = LBound(col) To UBound(col)
css = col(i)
ret = ret & cssToString(css) & vbCrLf
Next
'remove trailing vbCrLf
ret = Left(ret, Len(ret) - Len(vbCrLf))
sHtmlStyles = wrapInHTMLTag(ret, "style")
End Function
Sub testCSSStyles()
Dim sErrors As CSS_Style
Dim sWarnings As CSS_Style
Dim sBasic As CSS_Style
sErrors = newCSSDefault("Errors")
addCSS sErrors, "background-color", "#ff0000"
addCSS sErrors, "color", "#ffff00"
sWarnings = newCSSDefault("Warnings")
addCSS sWarnings, "background-color", "#ffff00"
addCSS sWarnings, "color", "#000000"
sBasic = newCSSDefault("Basic")
addCSS sBasic, "color", "#bbbbbb"
Dim CSSStyles(1 To 3) As CSS_Style
CSSStyles(1) = sErrors
CSSStyles(2) = sWarnings
CSSStyles(3) = sBasic
Dim sInnerBody As String
'Demonstrating errors
On Error GoTo ErrorOccurred
Dim j, k As Integer: j = 0: k = 10 / j
GoTo FinishError
ErrorOccurred:
On Error GoTo 0
appendInnerHTML sInnerBody, "Error: 10/" & j & " cannot be evaluated", sErrors
FinishError:
'Demonstrate warnings
If Cells(1, 1) = "" Then
appendInnerHTML sInnerBody, "Warning: Blank cell detected in A1 - This could cause issues", sWarnings
End If
'Demonstrate basic
appendInnerHTML sInnerBody, "Doing stuff", sBasic
appendInnerHTML sInnerBody, "Doing more stuff", sBasic
appendInnerHTML sInnerBody, "Doing other stuff", sBasic
appendInnerHTML sInnerBody, "Finishing stuff", sBasic
Dim sInnerHTML As String
sInnerHTML = sHTMLHeader("Error Log", sHtmlStyles(CSSStyles)) & _
vbCrLf & wrapInHTMLTag(sInnerBody, "body")
Debug.Print wrapInHTMLTag(sInnerHTML, "html")
End Sub
Sub appendInnerHTML(sInnerBody As String, ByVal sText As String, css As CSS_Style)
Dim sep As String: If sInnerBody <> "" Then sep = vbCrLf
sInnerBody = sInnerBody & sep & wrapInHTMLTag(sText, "div", "class=" & css.sName)
End Sub