Convert text with unicode to HTML entities - vba

Question

In VBA, how do you convert text containing Unicode to HTML entities?
Eg. Test chars: èéâ👍 would be converted to Test chars: èéâ👍

Answer 1

In Excel, characters are stored using Unicode UTF-16. The "Thumbs up" character (👍) corresponds to the Unicode character U+1F44D, encoded as follows:
in UTF-16 (hex) : 0xD83D 0xDC4D (d83ddc4d)
in UTF-16 (decimal) : 55357 , 56397
The following function (and test procedure) should convert as expected:
Sub test()
txt = String2Html("Test chars: èéâ" & ChrW(&HD83D) & ChrW(&HDC4D))
debug.print txt ' -> Test chars: èéâ👍
End Sub
Function String2Html(strText As String) As String
Dim i As Integer
Dim strOut As String
Dim char As String
Dim char2 As String
Dim intCharCode As Integer
Dim intChar2Code As Integer
Dim unicode_cp As Long
For i = 1 To Len(strText)
char = Mid(strText, i, 1)
intCharCode = AscW(char)
If (intCharCode And &HD800) = &HD800 Then
i = i + 1
char2 = Mid(strText, i, 1)
intChar2Code = AscW(char2)
unicode_cp = (intCharCode And &H3FF) * (2 ^ 10) + (intChar2Code And &H3FF)
strOut = strOut & "&#x" & CStr((intCharCode And &H3C0) + 1) & Hex(unicode_cp) & ";"
ElseIf intCharCode > 127 Then
strOut = strOut & "&#x" & Hex(intCharCode) & ";"
ElseIf intCharCode < 0 Then
strOut = strOut & "&#x" & Hex(65536 + intCharCode) & ";"
Else
strOut = strOut & char
End If
Next
String2Html = strOut
End Function

Answer 2

To convert Unicode to Asci (eg:  æ  to   æ)
Public Function UnicodeToAscii(sText As String) As String
Dim x As Long, sAscii As String, ascval As Long
If Len(sText) = 0 Then
Exit Function
End If
sAscii = ""
For x = 1 To Len(sText)
ascval = AscW(Mid(sText, x, 1))
If (ascval < 0) Then
ascval = 65536 + ascval ' http://support.microsoft.com/kb/272138
End If
sAscii = sAscii & "&#" & ascval & ";"
Next
UnicodeToAscii = sAscii
End Function
To convert Asci to Unicode (eg:  æ  to   æ)
Public Function AsciiToUnicode(sText As String) As String
Dim saText() As String, sChar As String
Dim sFinal As String, saFinal() As String
Dim x As Long, lPos As Long
If Len(sText) = 0 Then
Exit Function
End If
saText = Split(sText, ";") 'Unicode Chars are semicolon separated
If UBound(saText) = 0 And InStr(1, sText, "&#") = 0 Then
AsciiToUnicode = sText
Exit Function
End If
ReDim saFinal(UBound(saText))
For x = 0 To UBound(saText)
lPos = InStr(1, saText(x), "&#", vbTextCompare)
If lPos > 0 Then
sChar = Mid$(saText(x), lPos + 2, Len(saText(x)) - (lPos + 1))
If IsNumeric(sChar) Then
If CLng(sChar) > 255 Then
sChar = ChrW$(sChar)
Else
sChar = Chr$(sChar)
End If
End If
saFinal(x) = Left$(saText(x), lPos - 1) & sChar
ElseIf x < UBound(saText) Then
saFinal(x) = saText(x) & ";" 'This Semicolon wasn't a Unicode Character
Else
saFinal(x) = saText(x)
End If
Next
sFinal = Join(saFinal, "")
AsciiToUnicode = sFinal
Erase saText
Erase saFinal
End Function
I hope this would be help someone,
I got this code from here