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
|
