Source code for Issue Number 58

Copyright 1997-2000 by C&D Programming Corp. All Rights Reserved. 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

Code of the Week Home


Source Code

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