Binaryworld - HTMLDecodeEx - Decodes HTML encoded strings ... [ VB -> Internet ]

' Decodes HTML encoding applied to the specified Text and returns the result
' Optionally specify if we encoded a HREF link and the character
' used for encoding - the default is the standard ampersand

' i.e. Call MsgBox(HTMLDecodeEx("<Sample HTML Decoded Text>"
' & ""))

Public Function HTMLDecodeEx(ByVal Text As String, Optional ByVal vfHREFDecode _
  As Boolean = False, Optional ByVal vstrAmpChar As String = "&") As String

  Dim astrTokens() As String
  Dim lngTotal As Long
  Dim lngCount As Long
  Dim strToken As String
  Dim strCode As String
  Dim lngPos As Long
  Dim astrReturn() As String
  Dim strReturn As String

  strReturn = Text

  If Trim$(strReturn) <> "" Then
    ' tokenize the text
    astrTokens = Split(Text, vstrAmpChar, -1, vbTextCompare)

    lngTotal = UBound(astrTokens)

    ' create enough space for the return
    ReDim astrReturn(lngTotal)

    For lngCount = 0 To lngTotal
      ' look for the end of the token
      strToken = astrTokens(lngCount)
      lngPos = InStr(1, strToken, ";", vbTextCompare)
      If (lngPos = 0) Then
        astrReturn(lngCount) = strToken
      Else
        strCode = Mid$(strToken, 1, lngPos)
        Select Case strCode
          Case "nbsp;"
            astrReturn(lngCount) = " " & Mid$(strToken, lngPos + 1)
          Case "quot;"
            astrReturn(lngCount) = """" & Mid$(strToken, lngPos + 1)
          Case "amp;"
            astrReturn(lngCount) = vstrAmpChar & Mid$(strToken, _
              lngPos + 1)
          Case "lt;"
            astrReturn(lngCount) = "<" & Mid$(strToken, lngPos + 1)
          Case "gt;"
            astrReturn(lngCount) = ">" & Mid$(strToken, lngPos + 1)
          Case Else
            ' see if it's
            If Left$(strToken, 1) = "#" Then
              astrReturn(lngCount) = Chr$(Mid$(strToken, 2, _
                lngPos - 2)) & Mid$(strToken, lngPos + 1)
            Else
              astrReturn(lngCount) = strToken
            End If
        End Select
      End If
    Next ' lngCount

    Erase astrTokens

    strReturn = Join(astrReturn, "")

    Erase astrReturn
  End If

  HTMLDecodeEx = strReturn

End Function