Visual Basic 6 function "htmlentities"

Go back

Below you'll find the source for the Visual Basic 6 function htmlentities.

Attribute VB_Name = "modHtmlentities"
' These functions are downloaded from:
' http://www.stefanthoolen.nl/archive/vb6-functions/
' 
' You may freely distribute this file but please leave all comments, including this one, in it.
' 
' @Author Stefan Thoolen <mail@stefanthoolen.nl>

Option Explicit

Public Enum ENTITY_TABLE
    tHTML_ENTITIES = 1
    tHTML_SPECIALCHARS = 2
End Enum

Public Enum QUOTE_STYLE
    ENT_COMPAT = 0   ' Default: Will convert double-quotes and leave single-quotes alone.
    ENT_QUOTES = 1   ' Will convert both double and single quotes.
    ENT_NOQUOTES = 2 ' Will leave both double and single quotes unconverted.
End Enum

''
' Returns the translation table used by htmlspecialchars() and htmlentities()
' Same syntax as the PHP function 'get_html_translation_table'
' See also: http://www.php.net/manual/en/function.get-html-translation-table.php
' @param    ENTITY_TABLE table      The table to use, tHTML_ENTITIES or tHTML_SPECIALCHARS
' @param    QUOTE_STYLE quote_style The quote style, ENT_COMPAT, ENT_QUOTES or ENT_NOQUOTES
' @return   Variant                 An array containing the translation table
' @author   Stefan Thoolen <mail@stefanthoolen.nl>
Public Function get_html_translation_table(table As ENTITY_TABLE, Optional quote_style As QUOTE_STYLE) As Variant
    Dim itempart(1 To 2)
    ReDim retval(1 To 1)
    
    If table = tHTML_SPECIALCHARS Then
        itempart(1) = Chr(60): itempart(2) = "&lt;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(62): itempart(2) = "&gt;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(38): itempart(2) = "&amp;": retval(UBound(retval)) = itempart
        If quote_style <> ENT_NOQUOTES Then ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(34): itempart(2) = "&quot;": retval(UBound(retval)) = itempart
        If quote_style = ENT_QUOTES Then ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(39): itempart(2) = "&#39;": retval(UBound(retval)) = itempart
    End If
    If table = tHTML_ENTITIES Then
        itempart(1) = Chr(160): itempart(2) = "&nbsp;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(161): itempart(2) = "&iexcl;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(162): itempart(2) = "&cent;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(163): itempart(2) = "&pound;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(164): itempart(2) = "&curren;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(165): itempart(2) = "&yen;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(166): itempart(2) = "&brvbar;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(167): itempart(2) = "&sect;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(168): itempart(2) = "&uml;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(169): itempart(2) = "&copy;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(170): itempart(2) = "&ordf;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(171): itempart(2) = "&laquo;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(172): itempart(2) = "&not;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(173): itempart(2) = "&shy;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(174): itempart(2) = "&reg;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(175): itempart(2) = "&macr;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(176): itempart(2) = "&deg;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(177): itempart(2) = "&plusmn;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(178): itempart(2) = "&sup2;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(179): itempart(2) = "&sup3;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(180): itempart(2) = "&acute;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(181): itempart(2) = "&micro;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(182): itempart(2) = "&para;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(183): itempart(2) = "&middot;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(184): itempart(2) = "&cedil;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(185): itempart(2) = "&sup1;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(186): itempart(2) = "&ordm;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(187): itempart(2) = "&raquo;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(188): itempart(2) = "&frac14;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(189): itempart(2) = "&frac12;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(190): itempart(2) = "&frac34;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(191): itempart(2) = "&iquest;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(192): itempart(2) = "&Agrave;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(193): itempart(2) = "&Aacute;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(194): itempart(2) = "&Acirc;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(195): itempart(2) = "&Atilde;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(196): itempart(2) = "&Auml;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(197): itempart(2) = "&Aring;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(198): itempart(2) = "&AElig;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(199): itempart(2) = "&Ccedil;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(200): itempart(2) = "&Egrave;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(201): itempart(2) = "&Eacute;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(202): itempart(2) = "&Ecirc;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(203): itempart(2) = "&Euml;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(204): itempart(2) = "&Igrave;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(205): itempart(2) = "&Iacute;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(206): itempart(2) = "&Icirc;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(207): itempart(2) = "&Iuml;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(208): itempart(2) = "&ETH;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(209): itempart(2) = "&Ntilde;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(210): itempart(2) = "&Ograve;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(211): itempart(2) = "&Oacute;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(212): itempart(2) = "&Ocirc;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(213): itempart(2) = "&Otilde;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(214): itempart(2) = "&Ouml;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(215): itempart(2) = "&times;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(216): itempart(2) = "&Oslash;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(217): itempart(2) = "&Ugrave;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(218): itempart(2) = "&Uacute;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(219): itempart(2) = "&Ucirc;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(220): itempart(2) = "&Uuml;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(221): itempart(2) = "&Yacute;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(222): itempart(2) = "&THORN;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(223): itempart(2) = "&szlig;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(224): itempart(2) = "&agrave;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(225): itempart(2) = "&aacute;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(226): itempart(2) = "&acirc;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(227): itempart(2) = "&atilde;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(228): itempart(2) = "&auml;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(229): itempart(2) = "&aring;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(230): itempart(2) = "&aelig;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(231): itempart(2) = "&ccedil;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(232): itempart(2) = "&egrave;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(233): itempart(2) = "&eacute;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(234): itempart(2) = "&ecirc;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(235): itempart(2) = "&euml;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(236): itempart(2) = "&igrave;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(237): itempart(2) = "&iacute;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(238): itempart(2) = "&icirc;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(239): itempart(2) = "&iuml;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(240): itempart(2) = "&eth;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(241): itempart(2) = "&ntilde;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(242): itempart(2) = "&ograve;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(243): itempart(2) = "&oacute;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(244): itempart(2) = "&ocirc;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(245): itempart(2) = "&otilde;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(246): itempart(2) = "&ouml;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(247): itempart(2) = "&divide;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(248): itempart(2) = "&oslash;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(249): itempart(2) = "&ugrave;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(250): itempart(2) = "&uacute;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(251): itempart(2) = "&ucirc;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(252): itempart(2) = "&uuml;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(253): itempart(2) = "&yacute;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(254): itempart(2) = "&thorn;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(255): itempart(2) = "&yuml;": retval(UBound(retval)) = itempart
        If quote_style <> ENT_NOQUOTES Then ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(34): itempart(2) = "&quot;": retval(UBound(retval)) = itempart
        If quote_style = ENT_QUOTES Then ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(39): itempart(2) = "&#39;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(60): itempart(2) = "&lt;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(62): itempart(2) = "&gt;": retval(UBound(retval)) = itempart
        ReDim Preserve retval(1 To UBound(retval) + 1): itempart(1) = Chr(38): itempart(2) = "&amp;": retval(UBound(retval)) = itempart
    End If
    
    get_html_translation_table = retval
End Function

''
' Convert all applicable characters to HTML entities
' Same syntax as the PHP function 'htmlentities'
' See also: http://www.php.net/manual/en/function.htmlentities.php
' Only didn't use the parameter charset, since we have no use for it, I think :-)
' @param    String  tstr            The input string
' @param    QUOTE_STYLE quote_style The quote style, ENT_COMPAT, ENT_QUOTES or ENT_NOQUOTES
' @return                           The entitied string
' @author   Stefan Thoolen <mail@stefanthoolen.nl>
Public Function htmlentities(tstr As String, Optional quote_style As quote_style) As String
    Dim replaces() As Variant, i As Integer, j As Integer, s As String, t As String
    replaces = get_html_translation_table(tHTML_ENTITIES, quote_style)
    Do
        i = i + 1
        For j = LBound(replaces) To UBound(replaces)
            If Mid(tstr, i, Len(replaces(j)(1))) = replaces(j)(1) Then
                s = Left(tstr, i - 1)
                t = Right(tstr, Len(tstr) - i + 1 - Len(replaces(j)(1)))
                tstr = s & replaces(j)(2) & t
                i = i - Len(replaces(j)(1)) + Len(replaces(j)(2)): If i < 1 Then i = 1
            End If
        Next j
    Loop Until i > Len(tstr)
    htmlentities = tstr
End Function