by John Stalcup (3 Submissions)
Category: Internet/HTML
Compatability: Visual Basic 3.0
Difficulty: Unknown Difficulty
Date Added: Wed 3rd February 2021
Rating: 
(3 Votes)
This code provides 3 convenient ways of formatting html strings.
Inputs
A string of html.
Code Returns
A formatted string of html
API Declarations
VBcodersOption Explicit
Type tag
text As String
start As Double
length As Double
End Type
'*********************************************************************
Public Function SimpleFormat(target As String) As String
SimpleFormat = ReplaceSubString(CompactFormat(target), "><", ">" & vbCrLf & "<")
End Function
'*********************************************************************
Public Function CompactFormat(target As String) As String
Dim a As String
a = ReplaceSubString(target, vbCrLf, "")
a = ReplaceSubString(a, Chr(9), " ")
a = ReplaceSubString(a, " ", " ")
a = ReplaceSubString(a, " ", " ")
a = ReplaceSubString(a, " ", " ")
a = ReplaceSubString(a, " ", " ")
a = Clean(a)
CompactFormat = a
End Function
'*********************************************************************
Public Function HierarchalFormat(target As String) As String
target = ReplaceSubString(target, vbCrLf, "")
target = ReplaceSubString(target, vbTab, "")
target = Eformat(target)
HierarchalFormat = Clean(target)
End Function
'*********************************************************************
'this lines denotes separation from public access and inner workings
'*********************************************************************
Private Function Clean(targ As String) As String
targ = ReplaceSubString(targ, " >", ">")
targ = ReplaceSubString(targ, "< ", "<")
targ = ReplaceSubString(targ, "> <", "><")
Clean = targ
End Function
Public Function ReplaceSubString(str As String, ByVal substr As String, ByVal newsubstr As String)
Dim pos As Double
Dim startPos As Double
Dim new_str As String
startPos = 1
pos = InStr(str, substr)
Do While pos > 0
new_str = new_str & Mid$(str, startPos, pos - startPos) & newsubstr
startPos = pos + Len(substr)
pos = InStr(startPos, str, substr)
Loop
new_str = new_str & Mid$(str, startPos)
ReplaceSubString = new_str
End Function
Private Function Eformat(str As String) As String
On Error Resume Next
Dim startPos As Double
Dim endPos As Double
Dim indentationLevel As Double
Dim new_str As String
indentationLevel = 0
startPos = 0
endPos = 0
If (Mid$(str, 1, 1) <> "<") Then
Dim tempEnd As Double
tempEnd = InStr(1, str, "<")
If tempEnd = 0 Then
tempEnd = Len(str)
End If
new_str = Mid$(str, 1, tempEnd)
End If
Do
DoEvents
If InStr(startPos + 1, str, " 0 And InStr(startPos + 1, str, "
startPos = InStr(startPos + 1, str, " endPos = InStr(startPos + 1, str, "<")
If endPos = 0 Then
endPos = Len(str) + 1
End If
indentationLevel = indentationLevel - 1
new_str = new_str & vbCrLf & String(indentationLevel, vbTab) & Mid$(str, startPos, endPos - startPos)
Else
startPos = InStr(startPos + 1, str, "<")
endPos = InStr(startPos + 1, str, "<")
If endPos = 0 Then
endPos = Len(str) + 1
End If
new_str = new_str & vbCrLf & String(indentationLevel, vbTab) & Mid$(str, startPos, endPos - startPos)
Dim tagName As String
tagName = LCase(returnNameOfTag(returnNextTag(str, startPos)))
If tagName <> "br" And tagName <> "hr" And tagName <> "img" And tagName <> "meta" And tagName <> "applet" And tagName <> "p" And tagName <> "!--" And tagName <> "input" And tagName <> "!doctype" And tagName <> "area" Then
indentationLevel = indentationLevel + 1
End If
End If
Loop While startPos > 0
Eformat = new_str
End Function
Public Function returnNextTag(ByRef str As String, ByVal start As Double) As tag
On Error Resume Next
Dim endPos As Double
start = InStr(start + 1, str, "<")
endPos = InStr(start + 1, str, ">")
returnNextTag.text = Mid$(str, start, endPos - start + 1)
returnNextTag.start = start
returnNextTag.length = endPos - start
End Function
Public Function returnNameOfTag(ByRef str As tag) As String
On Error Resume Next
Dim endPos As Double
Dim start As Double
start = 2
endPos = InStr(1, str.text, " ")
If Mid$(str.text, 2, 3) = "!--" Then
endPos = 5
ElseIf endPos = 0 Then
endPos = InStr(1, str.text, ">")
End If
returnNameOfTag = Mid$(str.text, start, endPos - start)
End Function
