Hàm chuyển mã tiếng Việt, Msgbox tiếng Việt

Một trong những vấn đề được nhiều bạn quan tâm, đó là LÀM SAO ĐỂ HIỆN THÔNG BÁO TIẾNG VIỆT

Hàm chuyển mã từ TCVN 3 sang UNICODE

Tác giả: BinhOverAC Www.GiaiPhapExcel.com

Function TCVN3toUNICODE(vnstr As String) Dim c As String, i As Integer For i = 1 To Len(vnstr) c = Mid(vnstr, i, 1) Select Case c Case "a": c = ChrW$(97) Case "¸": c = ChrW$(225) Case "µ": c = ChrW$(224) Case "¶": c = ChrW$(7843) Case "·": c = ChrW$(227) Case "¹": c = ChrW$(7841) Case "¨": c = ChrW$(259) Case "¾": c = ChrW$(7855) Case "»": c = ChrW$(7857) Case "¼": c = ChrW$(7859) Case "½": c = ChrW$(7861) Case "Æ": c = ChrW$(7863) Case "©": c = ChrW$(226) Case "Ê": c = ChrW$(7845) Case "Ç": c = ChrW$(7847) Case "È": c = ChrW$(7849) Case "É": c = ChrW$(7851) Case "Ë": c = ChrW$(7853) Case "e": c = ChrW$(101) Case "Ð": c = ChrW$(233) Case "Ì": c = ChrW$(232) Case "Î": c = ChrW$(7867) Case "Ï": c = ChrW$(7869) Case "Ñ": c = ChrW$(7865) Case "ª": c = ChrW$(234) Case "Õ": c = ChrW$(7871) Case "Ò": c = ChrW$(7873) Case "Ó": c = ChrW$(7875) Case "Ô": c = ChrW$(7877) Case "Ö": c = ChrW$(7879) Case "o": c = ChrW$(111) Case "ã": c = ChrW$(243) Case "ß": c = ChrW$(242) Case "á": c = ChrW$(7887) Case "â": c = ChrW$(245) Case "ä": c = ChrW$(7885) Case "«": c = ChrW$(244) Case "è": c = ChrW$(7889) Case "å": c = ChrW$(7891) Case "æ": c = ChrW$(7893) Case "ç": c = ChrW$(7895) Case "é": c = ChrW$(7897) Case "¬": c = ChrW$(417) Case "í": c = ChrW$(7899) Case "ê": c = ChrW$(7901) Case "ë": c = ChrW$(7903) Case "ì": c = ChrW$(7905) Case "î": c = ChrW$(7907) Case "i": c = ChrW$(105) Case "Ý": c = ChrW$(237) Case "×": c = ChrW$(236) Case "Ø": c = ChrW$(7881) Case "Ü": c = ChrW$(297) Case "Þ": c = ChrW$(7883) Case "u": c = ChrW$(117) Case "ó": c = ChrW$(250) Case "ï": c = ChrW$(249) Case "ñ": c = ChrW$(7911) Case "ò": c = ChrW$(361) Case "ô": c = ChrW$(7909) Case "­": c = ChrW$(432) Case "ø": c = ChrW$(7913) Case "õ": c = ChrW$(7915) Case "ö": c = ChrW$(7917) Case "÷": c = ChrW$(7919) Case "ù": c = ChrW$(7921) Case "y": c = ChrW$(121) Case "ý": c = ChrW$(253) Case "ú": c = ChrW$(7923) Case "û": c = ChrW$(7927) Case "ü": c = ChrW$(7929) Case "þ": c = ChrW$(7925) Case "®": c = ChrW$(273) Case "A": c = ChrW$(65) Case "¡": c = ChrW$(258) Case "¢": c = ChrW$(194) Case "E": c = ChrW$(69) Case "£": c = ChrW$(202) Case "O": c = ChrW$(79) Case "¤": c = ChrW$(212) Case "¥": c = ChrW$(416) Case "I": c = ChrW$(73) Case "U": c = ChrW$(85) Case "¦": c = ChrW$(431) Case "Y": c = ChrW$(89) Case "§": c = ChrW$(272) End Select TCVN3toUNICODE = TCVN3toUNICODE + c Next i End Function

Hàm chuyển mã từ VNI sang UNICODE[/code]

Tác giả: BinhOverAC Www.GiaiPhapExcel.com

Function VNItoUNICODE(vnstr As String) Dim c As String, i As Integer Dim db As Boolean For i = 1 To Len(vnstr) db = False If i < Len(vnstr) Then c = Mid(vnstr, i + 1, 1) If c = "ù" Or c = "ø" Or c = "û" Or c = "õ" Or c = "ï" Or c = "ê" Or c = "é" Or c = "è" Or c = "ú" Or c = "ü" Or c = "ë" Or c = "â" Or c = "á" Or c = "à" Or c = "å" Or c = "ã" Or c = "ä" Or c = "Ù" Or c = "Ø" Or c = "Û" Or c = "Õ" Or c = "Ï" Or c = "Ê" Or c = "É" Or c = "È" Or c = "Ú" Or c = "Ü" Or c = "Ë" Or c = "Â" End If If db Then c = Mid(vnstr, i, 2) Select Case c Case "aù": c = ChrW$(225) Case "aø": c = ChrW$(224) Case "aû": c = ChrW$(7843) Case "aõ": c = ChrW$(227) Case "aï": c = ChrW$(7841) Case "aê": c = ChrW$(259) Case "aé": c = ChrW$(7855) Case "aè": c = ChrW$(7857) Case "aú": c = ChrW$(7859) Case "aü": c = ChrW$(7861) Case "aë": c = ChrW$(7863) Case "aâ": c = ChrW$(226) Case "aá": c = ChrW$(7845) Case "aà": c = ChrW$(7847) Case "aå": c = ChrW$(7849) Case "aã": c = ChrW$(7851) Case "aä": c = ChrW$(7853) Case "eù": c = ChrW$(233) Case "eø": c = ChrW$(232) Case "eû": c = ChrW$(7867) Case "eõ": c = ChrW$(7869) Case "eï": c = ChrW$(7865) Case "eâ": c = ChrW$(234) Case "eá": c = ChrW$(7871) Case "eà": c = ChrW$(7873) Case "eå": c = ChrW$(7875) Case "eã": c = ChrW$(7877) Case "eä": c = ChrW$(7879) Case "où": c = ChrW$(243) Case "oø": c = ChrW$(242) Case "oû": c = ChrW$(7887) Case "oõ": c = ChrW$(245) Case "oï": c = ChrW$(7885) Case "oâ": c = ChrW$(244) Case "oá": c = ChrW$(7889) Case "oà": c = ChrW$(7891) Case "oå": c = ChrW$(7893) Case "oã": c = ChrW$(7895) Case "oä": c = ChrW$(7897) Case "ôù": c = ChrW$(7899) Case "ôø": c = ChrW$(7901) Case "ôû": c = ChrW$(7903) Case "ôõ": c = ChrW$(7905) Case "ôï": c = ChrW$(7907) Case "uù": c = ChrW$(250) Case "uø": c = ChrW$(249) Case "uû": c = ChrW$(7911) Case "uõ": c = ChrW$(361) Case "uï": c = ChrW$(7909) Case "öù": c = ChrW$(7913) Case "öø": c = ChrW$(7915) Case "öû": c = ChrW$(7917) Case "öõ": c = ChrW$(7919) Case "öï": c = ChrW$(7921) Case "yù": c = ChrW$(253) Case "yø": c = ChrW$(7923) Case "yû": c = ChrW$(7927) Case "yõ": c = ChrW$(7929) Case "AÙ": c = ChrW$(193) Case "AØ": c = ChrW$(192) Case "AÛ": c = ChrW$(7842) Case "AÕ": c = ChrW$(195) Case "AÏ": c = ChrW$(7840) Case "AÊ": c = ChrW$(258) Case "AÉ": c = ChrW$(7854) Case "AÈ": c = ChrW$(7856) Case "AÚ": c = ChrW$(7858) Case "AÜ": c = ChrW$(7860) Case "AË": c = ChrW$(7862) Case "AÂ": c = ChrW$(194) Case "AÁ": c = ChrW$(7844) Case "AÀ": c = ChrW$(7846) Case "AÅ": c = ChrW$(7848) Case "AÃ": c = ChrW$(7850) Case "AÄ": c = ChrW$(7852) Case "EÙ": c = ChrW$(201) Case "EØ": c = ChrW$(200) Case "EÛ": c = ChrW$(7866) Case "EÕ": c = ChrW$(7868) Case "EÏ": c = ChrW$(7864) Case "EÂ": c = ChrW$(202) Case "EÁ": c = ChrW$(7870) Case "EÀ": c = ChrW$(7872) Case "EÅ": c = ChrW$(7874) Case "EÃ": c = ChrW$(7876) Case "EÄ": c = ChrW$(7878) Case "OÙ": c = ChrW$(211) Case "OØ": c = ChrW$(210) Case "OÛ": c = ChrW$(7886) Case "OÕ": c = ChrW$(213) Case "OÏ": c = ChrW$(7884) Case "OÂ": c = ChrW$(212) Case "OÁ": c = ChrW$(7888) Case "OÀ": c = ChrW$(7890) Case "OÅ": c = ChrW$(7892) Case "OÃ": c = ChrW$(7894) Case "OÄ": c = ChrW$(7896) Case "ÔÙ": c = ChrW$(7898) Case "ÔØ": c = ChrW$(7900) Case "ÔÛ": c = ChrW$(7902) Case "ÔÕ": c = ChrW$(7904) Case "ÔÏ": c = ChrW$(7906) Case "UÙ": c = ChrW$(218) Case "UØ": c = ChrW$(217) Case "UÛ": c = ChrW$(7910) Case "UÕ": c = ChrW$(360) Case "UÏ": c = ChrW$(7908) Case "ÖÙ": c = ChrW$(7912) Case "ÖØ": c = ChrW$(7914) Case "ÖÛ": c = ChrW$(7916) Case "ÖÕ": c = ChrW$(7918) Case "ÖÏ": c = ChrW$(7920) Case "YÙ": c = ChrW$(221) Case "YØ": c = ChrW$(7922) Case "YÛ": c = ChrW$(7926) Case "YÕ": c = ChrW$(7928) End Select Else c = Mid(vnstr, i, 1) Select Case c Case "ô": c = ChrW$(417) Case "í": c = ChrW$(237) Case "ì": c = ChrW$(236) Case "æ": c = ChrW$(7881) Case "ó": c = ChrW$(297) Case "ò": c = ChrW$(7883) Case "ö": c = ChrW$(432) Case "î": c = ChrW$(7925) Case "ñ": c = ChrW$(273) Case "Ô": c = ChrW$(416) Case "Í": c = ChrW$(205) Case "Ì": c = ChrW$(204) Case "Æ": c = ChrW$(7880) Case "Ó": c = ChrW$(296) Case "Ò": c = ChrW$(7882) Case "Ö": c = ChrW$(431) Case "Î": c = ChrW$(7924) Case "Ñ": c = ChrW$(272) End Select End If VNItoUNICODE = VNItoUNICODE + c If db Then i = i + 1 Next i End Function

Hàm chuyển từ UNICODE sang VNI

Function UNICODEtoVNI(ByVal vnstr As String) Dim c As String, i As Integer For i = 1 To Len(vnstr) c = Mid(vnstr, i, 1) Select Case c Case ChrW$(97): c = "a" Case ChrW$(225): c = "aù" Case ChrW$(224): c = "aø" Case ChrW$(7843): c = "aû" Case ChrW$(227): c = "aõ" Case ChrW$(7841): c = "aï" Case ChrW$(259): c = "aê" Case ChrW$(7855): c = "aé" Case ChrW$(7857): c = "aè" Case ChrW$(7859): c = "aú" Case ChrW$(7861): c = "aü" Case ChrW$(7863): c = "aë" Case ChrW$(226): c = "aâ" Case ChrW$(7845): c = "aá" Case ChrW$(7847): c = "aà" Case ChrW$(7849): c = "aå" Case ChrW$(7851): c = "aã" Case ChrW$(7853): c = "aä" Case ChrW$(101): c = "e" Case ChrW$(233): c = "eù" Case ChrW$(232): c = "eø" Case ChrW$(7867): c = "eû" Case ChrW$(7869): c = "eõ" Case ChrW$(7865): c = "eï" Case ChrW$(234): c = "eâ" Case ChrW$(7871): c = "eá" Case ChrW$(7873): c = "eà" Case ChrW$(7875): c = "eå" Case ChrW$(7877): c = "eã" Case ChrW$(7879): c = "eä" Case ChrW$(111): c = "o" Case ChrW$(243): c = "où" Case ChrW$(242): c = "oø" Case ChrW$(7887): c = "oû" Case ChrW$(245): c = "oõ" Case ChrW$(7885): c = "oï" Case ChrW$(244): c = "oâ" Case ChrW$(7889): c = "oá" Case ChrW$(7891): c = "oà" Case ChrW$(7893): c = "oå" Case ChrW$(7895): c = "oã" Case ChrW$(7897): c = "oä" Case ChrW$(417): c = "ô" Case ChrW$(7899): c = "ôù" Case ChrW$(7901): c = "ôø" Case ChrW$(7903): c = "ôû" Case ChrW$(7905): c = "ôõ" Case ChrW$(7907): c = "ôï" Case ChrW$(105): c = "i" Case ChrW$(237): c = "í" Case ChrW$(236): c = "ì" Case ChrW$(7881): c = "æ" Case ChrW$(297): c = "ó" Case ChrW$(7883): c = "ò" Case ChrW$(117): c = "u" Case ChrW$(250): c = "uù" Case ChrW$(249): c = "uø" Case ChrW$(7911): c = "uû" Case ChrW$(361): c = "uõ" Case ChrW$(7909): c = "uï" Case ChrW$(432): c = "ö" Case ChrW$(7913): c = "öù" Case ChrW$(7915): c = "uø" Case ChrW$(7917): c = "öû" Case ChrW$(7919): c = "öõ" Case ChrW$(7921): c = "öï" Case ChrW$(121): c = "y" Case ChrW$(253): c = "yù" Case ChrW$(7923): c = "yø" Case ChrW$(7927): c = "yû" Case ChrW$(7929): c = "yõ" Case ChrW$(7925): c = "î" Case ChrW$(273): c = "ñ" Case ChrW$(65): c = "A" Case ChrW$(193): c = "AÙ" Case ChrW$(192): c = "AØ" Case ChrW$(7842): c = "AÛ" Case ChrW$(195): c = "AÕ" Case ChrW$(7840): c = "AÏ" Case ChrW$(258): c = "AÊ" Case ChrW$(7854): c = "AÉ" Case ChrW$(7856): c = "AÈ" Case ChrW$(7858): c = "AÚ" Case ChrW$(7860): c = "AÜ" Case ChrW$(7862): c = "AË" Case ChrW$(194): c = "AÂ" Case ChrW$(7844): c = "AÁ" Case ChrW$(7846): c = "AÀ" Case ChrW$(7848): c = "AÅ" Case ChrW$(7850): c = "AÃ" Case ChrW$(7852): c = "AÄ" Case ChrW$(69): c = "E" Case ChrW$(201): c = "EÙ" Case ChrW$(200): c = "EØ" Case ChrW$(7866): c = "EÛ" Case ChrW$(7868): c = "EÕ" Case ChrW$(7864): c = "EÏ" Case ChrW$(202): c = "EÂ" Case ChrW$(7870): c = "EÁ" Case ChrW$(7872): c = "EÀ" Case ChrW$(7874): c = "EÅ" Case ChrW$(7876): c = "EÃ" Case ChrW$(7878): c = "EÄ" Case ChrW$(79): c = "O" Case ChrW$(211): c = "OÙ" Case ChrW$(210): c = "OØ" Case ChrW$(7886): c = "OÛ" Case ChrW$(213): c = "OÕ" Case ChrW$(7884): c = "OÏ" Case ChrW$(212): c = "OÂ" Case ChrW$(7888): c = "OÁ" Case ChrW$(7890): c = "OÀ" Case ChrW$(7892): c = "OÅ" Case ChrW$(7894): c = "OÃ" Case ChrW$(7896): c = "OÄ" Case ChrW$(416): c = "Ô" Case ChrW$(7898): c = "ÔÙ" Case ChrW$(7900): c = "ÔØ" Case ChrW$(7902): c = "ÔÛ" Case ChrW$(7904): c = "ÔÕ" Case ChrW$(7906): c = "ÔÏ" Case ChrW$(73): c = "I" Case ChrW$(205): c = "Í" Case ChrW$(204): c = "Ì" Case ChrW$(7880): c = "Æ" Case ChrW$(296): c = "Ó" Case ChrW$(7882): c = "Ò" Case ChrW$(85): c = "U" Case ChrW$(218): c = "UÙ" Case ChrW$(217): c = "UØ" Case ChrW$(7910): c = "UÛ" Case ChrW$(360): c = "UÕ" Case ChrW$(7908): c = "UÏ" Case ChrW$(431): c = "Ö" Case ChrW$(7912): c = "ÖÙ" Case ChrW$(7914): c = "ÖØ" Case ChrW$(7916): c = "ÖÛ" Case ChrW$(7918): c = "ÖÕ" Case ChrW$(7920): c = "ÖÏ" Case ChrW$(89): c = "Y" Case ChrW$(221): c = "YÙ" Case ChrW$(7922): c = "YØ" Case ChrW$(7926): c = "YÛ" Case ChrW$(7928): c = "YÕ" Case ChrW$(7924): c = "Î" Case ChrW$(272): c = "Ñ" End Select UNICODEtoVNI = UNICODEtoVNI + c Next i End Function

Để thông báo hiện được tiếng việt chúng ta dùng hai hàm API sau. Đầu tiên chúng ta phải khai báo trong module:

'Khai báo các hàm API trong thư viện User32.DLL

Private Declare Function GetActiveWindow Lib "user32" () As Long Private Declare Function MessageBoxW Lib "user32" (ByVal hwnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As Long) As Long

Sau đó chúng ta viết lại hàm Msgbox để hiện thông báo với chuổi Unicode như sau:

Function MsgBoxUni(ByVal PromptUni As Variant, Optional ByVal Buttons As VbMsgBoxStyle = vbOKOnly, Optional ByVal TitleUni As Variant = vbNullString) As VbMsgBoxResult 'Function MsgBoxUni(ByVal PromptUni As Variant, Optional ByVal Buttons As VbMsgBoxStyle = vbOKOnly, Optional ByVal TitleUni As Variant, Optional HelpFile, Optional Context) As VbMsgBoxResult 'BStrMsg,BStrTitle : La chuoi Unicode Dim BStrMsg, BStrTitle 'Hàm StrConv Chuyen chuoi ve ma Unicode BStrMsg = StrConv(PromptUni, vbUnicode) BStrTitle = StrConv(TitleUni, vbUnicode) MsgBoxUni = MessageBoxW(GetActiveWindow, BStrMsg, BStrTitle, Buttons) End Function

Ở đây các bạn cần chú ý:

Trong màn hình sọan thảo code VBE (Visual Basic Editor) các bạn phải biết chỉnh bộ gõ, trước khi nhập nội dung cho hàm hiển thị.

Ví dụ: tôi muốn hàm hiển thỉ thông báo Bạn đã thành công (font VNI) tôi sẽ thực hiện như sau
Đầu tiên tôi chỉnh bộ gõ theo kiểu gõ là Telex, bảng mã là VNI Windows


Tôi sẽ sử dụng hàm MsgboxUni như sau:

Sub HienThongBaoTV() 'Tôi dùng hàm VNItoUnicode ?e^? chuye^?n mã VNI sang Unicode 'Các ba.n chú ý khi ba('t ?a^`u nha^.p vào no^.i dung thì hãy ba^.t che^' ?o^. gõ tie^'ng vie^.t MsgBoxUni VNI("Coäng hoaø xaõ hoäi chuû nghóa Vieät Nam") End Sub

Trong Visual Basic chúng ta có thể dùng hàm sau, để thay thế hàm Msgbox nhằm thể hiện chuổi Unicode

Function MsgBox(ByVal PromptUni As Variant, Optional ByVal Buttons As VbMsgBoxStyle = vbOKOnly, Optional ByVal TitleUni As Variant = vbNullString) As VbMsgBoxResult Dim BStrMsg, BStrTitle BStrMsg = StrConv(PromptUni, vbUnicode) BStrTitle = StrConv(TitleUni, vbUnicode) MsgBox = MessageBoxW(GetActiveWindow, BStrMsg, BStrTitle, Buttons) End Function

Các bạn có thể tham khảo tại đây:


Vovisoft

Các hàm cho Unicode chữ Việt


Dưới đây là danh sách của một Sub và 13 hàm (Functions) dùng để xử lý Unicode chữ Việt. Ðể hiểu thêm về Unicode và nhất là cách hoán chuyển giữa UTF-16 và UTF-8 xin đọc bài Căn bản Unicode cho VB6 Programers cũng trên trang Vovisoft.

Sub InitUnicode()	Initialise String chứa các Unicode Vowels v đ, Ð
Function IsUniChar(Ch) As Boolean	Kết quả True nếu Ch l Unicode character
Function IsUpperUniChar(Ch) As Boolean	Kết quả True nếu Ch l Unicode character chữ Hoa
Function UpperUniChar(Ch) As String	Biến Unicode character Ch th nh chữ Hoa
Function LowerUniChar(Ch) As String	Biến Unicode character Ch th nh chữ Thường
Function UpperUniStr(IPString) As String	Biến cả Unicode String IPString th nh chữ Hoa
Function LowerUniStr(IPString) As String	Biến cả Unicode String IPString th nh chữ Thường
Function ToUTF8(ByVal UTF16 As Long) As Byte()	Hoán chuyển UTF-16 ra 2 hay 3 bytes UTF-8
Function ToUTF16(BArray) As Long	Hoán chuyển 2 hay 3 bytes UTF-8 ra UTF-16
Function UniStrToUTF8(UniString) As Byte()	Hoán chuyển Unicode String ra UTF-8 bytes
Function UTF8ToUniStr(BArray) As String	Hoán chuyển UTF-8 bytes ra Unicode String
Function HexDisplayOfFile(TFileName) As String	Hiển thị Text của một file trong dạng Hex
Function GetFileEncoding(TFileName) As coEncoding	Lấy loại Encoding của Text file: ANSI, Unicode hay UTF-8
Function ToUniDecimal(UniString As String) As String	Xuất khẩu Unicode String ra dạng ✏ để dùng cho Web

Option Explicit Public UVowels As String ' API to access VB6 String by pointer in order to copy memory Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long) Enum coEncoding coANSI = 0 coUnicode = 1 coUTF8 = 2 End Enum Sub InitUnicode() Dim TStr As String ' Initialise the list of Unicode Vowels, 67 lowerCase followed by 67 Uppercase ' Note that by using the Function chrW, the &HE1 Unicode character is stored internally ' as &HE100 for a String character TStr = TStr & ChrW(&HE1) & ChrW(&HE0) & ChrW(&H1EA3) & ChrW(&HE3) & ChrW(&H1EA1) & ChrW(&H103) & ChrW(&H1EAF) & ChrW(&H1EB1) & ChrW(&H1EB3) & ChrW(&H1EB5) & ChrW(&H1EB7) & ChrW(&HE2) & ChrW(&H1EA5) & ChrW(&H1EA7) & ChrW(&H1EA9) & ChrW(&H1EAB) & ChrW(&H1EAD) & ChrW(&HE9) & ChrW(&HE8) & ChrW(&H1EBB) TStr = TStr & ChrW(&H1EBD) & ChrW(&H1EB9) & ChrW(&HEA) & ChrW(&H1EBF) & ChrW(&H1EC1) & ChrW(&H1EC3) & ChrW(&H1EC5) & ChrW(&H1EC7) & ChrW(&HED) & ChrW(&HEC) & ChrW(&H1EC9) & ChrW(&H129) & ChrW(&H1ECB) & ChrW(&HF3) & ChrW(&HF2) & ChrW(&H1ECF) & ChrW(&HF5) & ChrW(&H1ECD) & ChrW(&HF4) & ChrW(&H1ED1) TStr = TStr & ChrW(&H1ED3) & ChrW(&H1ED5) & ChrW(&H1ED7) & ChrW(&H1ED9) & ChrW(&H1A1) & ChrW(&H1EDB) & ChrW(&H1EDD) & ChrW(&H1EDF) & ChrW(&H1EE1) & ChrW(&H1EE3) & ChrW(&HFA) & ChrW(&HF9) & ChrW(&H1EE7) & ChrW(&H169) & ChrW(&H1EE5) & ChrW(&H1B0) & ChrW(&H1EE9) & ChrW(&H1EEB) & ChrW(&H1EED) & ChrW(&H1EEF) TStr = TStr & ChrW(&H1EF1) & ChrW(&HFD) & ChrW(&H1EF3) & ChrW(&H1EF7) & ChrW(&H1EF9) & ChrW(&H1EF5) & ChrW(&H111) & ChrW(&HC1) & ChrW(&HC0) & ChrW(&H1EA2) & ChrW(&HC3) & ChrW(&H1EA0) & ChrW(&H102) & ChrW(&H1EAE) & ChrW(&H1EB0) & ChrW(&H1EB2) & ChrW(&H1EB4) & ChrW(&H1EB6) & ChrW(&HC2) & ChrW(&H1EA4) TStr = TStr & ChrW(&H1EA6) & ChrW(&H1EA8) & ChrW(&H1EAA) & ChrW(&H1EAC) & ChrW(&HC9) & ChrW(&HC8) & ChrW(&H1EBA) & ChrW(&H1EBC) & ChrW(&H1EB8) & ChrW(&HCA) & ChrW(&H1EBE) & ChrW(&H1EC0) & ChrW(&H1EC2) & ChrW(&H1EC4) & ChrW(&H1EC6) & ChrW(&HCD) & ChrW(&HCC) & ChrW(&H1EC8) & ChrW(&H128) & ChrW(&H1ECA) TStr = TStr & ChrW(&HD3) & ChrW(&HD2) & ChrW(&H1ECE) & ChrW(&HD5) & ChrW(&H1ECC) & ChrW(&HD4) & ChrW(&H1ED0) & ChrW(&H1ED2) & ChrW(&H1ED4) & ChrW(&H1ED6) & ChrW(&H1ED8) & ChrW(&H1A0) & ChrW(&H1EDA) & ChrW(&H1EDC) & ChrW(&H1EDE) & ChrW(&H1EE0) & ChrW(&H1EE2) & ChrW(&HDA) & ChrW(&HD9) & ChrW(&H1EE6) TStr = TStr & ChrW(&H168) & ChrW(&H1EE4) & ChrW(&H1AF) & ChrW(&H1EE8) & ChrW(&H1EEA) & ChrW(&H1EEC) & ChrW(&H1EEE) & ChrW(&H1EF0) & ChrW(&HDD) & ChrW(&H1EF2) & ChrW(&H1EF6) & ChrW(&H1EF8) & ChrW(&H1EF4) & ChrW(&H110) UVowels = TStr ' Assign to the Unicode Vowel list End Sub Function IsUniChar(Ch) As Boolean ' Return True if Ch is a Unicode Vowel or dd, DD IsUniChar = (InStr(UVowels, Ch) > 0) End Function Function IsUpperUniChar(Ch) As Boolean ' Return True if Ch is an Uppercase Unicode Vowel or DD IsUpperUniChar = (InStr(UVowels, Ch) > 67) End Function Function UpperUniChar(Ch) As String ' Return the Uppercase for a given vowel or dd Dim Pos ' Position of character in Unicode vowel list ' Locate the character in list of Unicode vowels Pos = InStr(UVowels, Ch) If (Pos > 67) Then UpperUniChar = Ch ' It's already uppercase - leave it alone ElseIf (Pos > 0) Then ' It's a Lowercase Unicode Vowel - so get the corresponding Uppercase vowel in the list UpperUniChar = Mid(UVowels, Pos + 67, 1) Else ' It's just a normal ANSI character UpperUniChar = UCase(Ch) End If End Function Function LowerUniChar(Ch) As String ' Return the Lowercase for a given vowel or DD Dim Pos ' Position of character in Unicode vowel list ' Locate the character in list of Unicode vowels Pos = InStr(UVowels, Ch) If Pos > 67 Then ' It's an Uppercase Unicode Vowel - so get the corresponding Lowercase vowel in the list LowerUniChar = Mid(UVowels, Pos - 67, 1) ElseIf Pos > 0 Then LowerUniChar = Ch ' It's already Lowercase - leave it alone Else ' It's just a normal ANSI character LowerUniChar = LCase(Ch) End If End Function Function UpperUniStr(IPString) As String ' Convert a Unicode string to UpperCase Dim i, TLen, TStr TStr = "" ' Initialise the resultant string TLen = Len(IPString) ' get length of input Unicode string If TLen > 0 Then ' Iterate through each character of the Unicode string For i = 1 To TLen ' Convert each character to uppercase TStr = TStr & UpperUniChar(Mid(IPString, i, 1)) Next End If UpperUniStr = TStr ' Return the resultant string End Function Function LowerUniStr(IPString) As String ' Convert a Unicode string to LowerCase Dim i, TLen, TStr TStr = "" ' Initialise the resultant string TLen = Len(IPString) ' get length of input Unicode string If TLen > 0 Then ' Iterate through each character of the Unicode string For i = 1 To TLen ' Convert each character to lowercase TStr = TStr & LowerUniChar(Mid(IPString, i, 1)) Next End If LowerUniStr = TStr ' Return the resultant string End Function Function ToUTF8(ByVal UTF16 As Long) As Byte() ' Convert a 16bit UTF-16BE to 2 or 3 UTF-8 bytes Dim BArray() As Byte If UTF16 < &H80 Then ReDim BArray(0) ' one byte UTF-8 BArray(0) = UTF16 ' Use number as is ElseIf UTF16 < &H800 Then ReDim BArray(1) ' two byte UTF-8 BArray(1) = &H80 + (UTF16 And &H3F) ' Least Significant 6 bits UTF16 = UTF16 \ &H40 ' Shift UTF16 number right 6 bits BArray(0) = &HC0 + (UTF16 And &H1F) ' Use 5 remaining bits Else ReDim BArray(2) ' three byte UTF-8 BArray(2) = &H80 + (UTF16 And &H3F) ' Least Significant 6 bits UTF16 = UTF16 \ &H40 ' Shift UTF16 number right 6 bits BArray(1) = &H80 + (UTF16 And &H3F) ' Use next 6 bits UTF16 = UTF16 \ &H40 ' Shift UTF16 number right 6 bits again BArray(0) = &HE0 + (UTF16 And &HF) ' Use 4 remaining bits End If ToUTF8 = BArray ' Return UTF-8 bytes in an array End Function Function ToUTF16(BArray) As Long ' Convert 2 or 3 UTF-8 bytes to a 16bit UTF-16BE Dim IntUB IntUB = UBound(BArray) ' Find out how many bytes UTF-8 takes Select Case IntUB Case 0 ' one byte UTF-8. Note that bArray starts with index=0 ToUTF16 = BArray(0) ' Use number as is Case 1 ' two byte UTF-8 ToUTF16 = (BArray(0) And &H1F) * &H40 + (BArray(1) And &H3F) Case 2 ' three byte UTF-8 ToUTF16 = (BArray(0) And &HF) * &H1000 + (BArray(1) And &H3F) * &H40 + (BArray(2) And &H3F) End Select End Function Function UniStrToUTF8(UniString) As Byte() ' Convert a Unicode string to a byte stream of UTF-8 Dim BArray() As Byte Dim TempB() As Byte Dim i As Long Dim k As Long Dim TLen As Long Dim b1 As Byte Dim b2 As Byte Dim UTF16 As Long Dim j TLen = Len(UniString) ' Obtain length of Unicode input string If TLen = 0 Then Exit Function ' get out if there's nothing to convert k = 0 For i = 1 To TLen ' Work out the UTF16 value of the Unicode character CopyMemory b1, ByVal StrPtr(UniString) + ((i - 1) * 2), 1 CopyMemory b2, ByVal StrPtr(UniString) + ((i - 1) * 2) + 1, 1 ' Combine the 2 bytes into the Unicode UTF-16 UTF16 = b2 ' assign b2 to UTF16 before multiplying by 256 to avoid overflow UTF16 = UTF16 * 256 + b1 ' Convert UTF-16 to 2 or 3 bytes of UTF-8 TempB = ToUTF8(UTF16) ' Copy the resultant bytes to BArray For j = 0 To UBound(TempB) ReDim Preserve BArray(k) BArray(k) = TempB(j): k = k + 1 Next ReDim TempB(0) Next UniStrToUTF8 = BArray ' Return the resultant UTF-8 byte array End Function Function UTF8ToUniStr(BArray) As String ' Convert a byte stream of UTF-8 to Unicode String Dim i As Long Dim TopIndex As Long Dim TwoBytes(1) As Byte Dim ThreeBytes(2) As Byte Dim AByte As Byte Dim TStr As String TopIndex = UBound(BArray) ' Number of bytes equal TopIndex+1 If TopIndex = 0 Then Exit Function ' get out if there's nothing to convert i = 0 ' Initialise pointer ' Iterate through the Byte Array Do While i <= TopIndex AByte = BArray(i) ' fetch a byte If AByte = &HE1 Then ' Start of 3 byte UTF-8 group for a character ' Copy 3 byte to ThreeBytes ThreeBytes(0) = BArray(i): i = i + 1 ThreeBytes(1) = BArray(i): i = i + 1 ThreeBytes(2) = BArray(i): i = i + 1 ' Convert Byte array to UTF-16 then Unicode TStr = TStr & ChrW(ToUTF16(ThreeBytes)) ElseIf (AByte >= &HC3) And (AByte <= &HC6) Then ' Start of 2 byte UTF-8 group for a character TwoBytes(0) = BArray(i): i = i + 1 TwoBytes(1) = BArray(i): i = i + 1 ' Convert Byte array to UTF-16 then Unicode TStr = TStr & ChrW(ToUTF16(TwoBytes)) Else ' Normal ANSI character - use it as is TStr = TStr & Chr(AByte): i = i + 1 ' Increment byte array index End If Loop UTF8ToUniStr = TStr ' Return the resultant string End Function Function HexDisplayOfFile(TFileName) As String ' Display the content of a text file in Hex format like: ' FF FE 54 00 B0 01 DB 1E 63 00 Dim Text1, MyChar, FileNum FileNum = FreeFile ' Obtain a File handle from the OS Open TFileName For Binary As #FileNum ' Open given Text file as binary ' Read all characters in the file. Do While Not EOF(FileNum) MyChar = Input(1, #FileNum) ' Read a character as raw binary If MyChar <> "" Then ' Convert byte to Hex like 0A, 6B etc.. Text1 = Text1 & HexOf(Asc(MyChar)) & " " End If Loop Close #FileNum ' Close file HexDisplayOfFile = Text1 ' Return the Hex display string End Function Function GetFileEncoding(TFileName) As coEncoding ' Return the type of Text file : UTF16LE, UTF-8 or ANSI Dim b1, FileNum On Error Resume Next ' Ignore error FileNum = FreeFile ' Obtain a File handle from the OS Open TFileName For Binary As #FileNum ' Open given Textfile as Binary ' Read all characters in the file. b1 = Input(1, #FileNum) ' Read the first character. If Asc(b1) = &HFF Then GetFileEncoding = coUnicode ' UTF-16LE ElseIf Asc(b1) = &HEF Then GetFileEncoding = coUTF8 ' UTF-8 Else GetFileEncoding = coANSI ' Normal ANSI End If Close #FileNum ' Close the file End Function Function ToUniDecimal(UniString As String) As String ' Return the HTML equivalent string of a Unicode string Dim i As Integer ' Must declare as integer for CopyMemory to work Dim TLen, TStr Dim b1 As Byte Dim b2 As Byte Dim UTF16 As Long TLen = Len(UniString) ' Get Length of input Unicode string If TLen = 0 Then Exit Function ' Get out if null string ' Iterate through each character in the string For i = 1 To TLen If IsUniChar(Mid(UniString, i, 1)) Then ' Cast the String character to 2 bytes CopyMemory b1, ByVal StrPtr(UniString) + ((i - 1) * 2), 1 CopyMemory b2, ByVal StrPtr(UniString) + ((i - 1) * 2) + 1, 1 ' Combine the 2 bytes into the Unicode UTF-16 UTF16 = b2 ' assign b2 to UTF16 before multiplying by 256 to avoid overflow UTF16 = UTF16 * 256 + b1 ' Convert UTF-16 to format ? for HTML TStr = TStr & "&#" & Trim(CStr(UTF16)) & ";" Else ' Get here if it;s an ANSI character TStr = TStr & Mid(UniString, i, 1) End If Next ToUniDecimal = TStr ' Return the HTML string End Function Private Function HexOf(ByVal AscNum As Integer) As String ' Return the 2 character Hex string of AscNum, prefix extra "0" if necessary Dim TStr If AscNum > 255 Then AscNum = AscNum Mod 256 TStr = Hex(AscNum) ' Convert to Hex If Len(TStr) = 1 Then ' Attach "0" on the left TStr = "0" & TStr End If HexOf = TStr ' Return the 2 character Hex string End Function