Just paste this source code into a module called basHTMLParsing and include it in your project.
'----------------------------------------------------------------------
'
' Module Name: basHTMLParsing
' Written By: C&D Programming Corp.
' Create Date: 10/98
' Copyright: Copyright 1998 by C&D Programming Corp. Source
' code may not be reproduced except for use in a
' compiled executable. All rights reserved. If
' you would like to reprint any or all of this
' code please email us at info@codeoftheweek.com
'----------------------------------------------------------------------
Option Explicit
Const TAG_START_DELIM = "<"
Const TAG_END_DELIM = ">"
'
' In the future we might want to convert the following
' tags into symbols.
' to spaces
' © to copyright symbol
' & to ampersand
' · to center dot
' ® to registered trademark
'
Public Function StripAllTags(sSourceData As String) As String
Dim sTemp As String
Dim lTextPos As Long
Dim lStartPos As Long
Dim lEndPos As Long
lTextPos = 1
' find first starting delimiter.
lStartPos = InStr(lTextPos, sSourceData, TAG_START_DELIM)
' if we do not find one, return the entire string
If lStartPos = 0 Then
StripAllTags = sSourceData
Else
' otherwise, let's start processing the text.
sTemp = ""
' while we still have starting delimiter, continue loop
While lStartPos <> 0
' find the ending delimiter position. If we can't find it,
' assume the delimiters are unmatched and take the rest of the
' string.g
lEndPos = InStr(lStartPos, sSourceData, TAG_END_DELIM)
If lEndPos = 0 Then
sTemp = sTemp & Mid(sSourceData, lStartPos)
lStartPos = 0 ' force loop to exit
Else
' move text position counter to one position after the
' ending delimiter.
lTextPos = lEndPos + 1
' the only special case is if there are two tags back to
' back as in . So, we check the first position
' after the last ending delimiter found.
If Mid(sSourceData, lTextPos, 1) = TAG_START_DELIM Then
' If it equal to a starting delimiter, let's just
' force the lStartPos to point to the next start delimiter
lStartPos = lTextPos
Else
' If it is not equal to a starting delimiter then we
' found some text so parse it out and save it to our
' temporary string. If we can't find another starting
' delimiter, grab the rest of the string otherwise
' just grab what is between this delimiter and the
' next one.
lStartPos = InStr(lTextPos, sSourceData, TAG_START_DELIM)
If lStartPos = 0 Then
sTemp = sTemp & Mid(sSourceData, lTextPos)
Else
sTemp = sTemp & Mid(sSourceData, lTextPos, lStartPos - lTextPos)
End If
End If
End If
Wend
' save temporary string to function name for returning to caller
StripAllTags = sTemp
End If
End Function
Public Function StripAllTagsFromFile(sFilename As String) As String
Dim sData As String
On Error GoTo Handler
' read file into string
sData = GetTextFile(sFilename)
' strip tags from file and return stripped string
StripAllTagsFromFile = StripAllTags(sData)
Exit Function
Handler:
Err.Raise Err.Number, Err.Source, Err.Description
End Function
'----------------------------------------------------------------------
'
' Written By: C&D Programming Corp.
' Martin Cordova
' Create Date: 10/97
'
' The following code appeared in Issue #26.
'----------------------------------------------------------------------
Public Function FixUpFilename(sFile As String) As String
Dim sPath As String
On Error GoTo Handler
'---file includes path?
If InStr(sFile, "\") = 0 Then
'---assume App.Path
sPath = App.Path
If Right(sPath, 1) <> "\" Then
FixUpFilename = sPath & "\" & sFile
Else
FixUpFilename = sPath & sFile
End If
Else
FixUpFilename = sFile
End If
Exit Function
Handler:
Err.Raise Err.Number
End Function
'---read a text file with one line of code
'---file: file name with or without path
'---if path not included assumes App.Path
Public Function GetTextFile(ByVal sFile As String) As String
Dim iFnum As Integer
On Error GoTo ErrorHandler
sFile = FixUpFilename(sFile)
'---read file into buffer
iFnum = FreeFile
Open sFile For Input As #iFnum
GetTextFile = Input(LOF(iFnum), iFnum)
Close iFnum
Exit Function
ErrorHandler:
Err.Raise Err.Number
End Function