VNiTelex v1.21 - Hàm mã hóa giải mã chuỗi Unicode và Tiếng Việt cho mã VBA (1 người xem)

HeSanbi · 5/7/23

Bài viết không đủ trình độ chia sẻ trợ giúp trên diễn đàn, bài viết đã được xóa.

HeSanbi · 24/7/23

***** Cập nhật v1.2 *****

Nếu không muốn mã hóa một đoạn trong chuỗi hãy sử dụng Đóng mở chuỗi như sau:

Hãy thêm khối mở {/ và đóng /} vào chuỗi nhập:

Ví dụ: VNiTelex("Xin chào cả {/gia đình/}") Thì chuỗi "gia đình" sẽ được loại trừ.

Ví dụ: VNiTelexDecode("{/Xin chao.f/} ca.r gia ddinh.f") Thì chuỗi "Xin chao.f" sẽ được loại trừ.

HeSanbi · 30/7/24

Cập nhật mã: Loại bỏ các hàm Replace của VBA trong mã thành phương thức Replace của thư viện Regular Expression cải thiện hiệu xuất.

HeSanbi · 31/8/24

***** Cập nhật v1.21 *****
Sửa một sai sót khi dịch ngược ký tự .
Thêm phương thức: VNiTelexMultiDecode Để dịch ngược tổng thể để quá trình dịch ngược nhanh hơn.

Ví dụ:

JavaScript:

Sub Test1()
  Dim a1$, a2$, a3$
  a1= "xin chao.f"
  a2= "Viet.ej Nam"
  a3= "Lap.aj trinh.f VBA"
  VNiTelexMultiDecode a1, a2, a3
End Sub

Văn Toàn 1996 · 31/8/24

Tinh chỉnh lại code cho mượt hơn

Mã:

Function VNiTelex(ByVal text As String, Optional oregex___ As Object, Optional odi___ As Object, Optional ByVal floor___ As Long = 0) As String
    Dim l As Long: l = Len(text): If l = 0 Then Exit Function
    Dim di2, m, ms, m0, m1, m2, m3, aF, iba As Long, re As Object, v As String, z As String
    Set re = CreateObject("VBScript.RegExp")
    With re
        .Global = True: .IgnoreCase = False: .MultiLine = True
        .Pattern = "\u0110": text = .Replace(text, "Dd")
        .Pattern = "\u0111": text = .Replace(text, "dd")
        .IgnoreCase = True
        .Pattern = "(^|[^\\]?)\{/([^\u0008]*?)/\}"
    End With

    ' Initialize dictionary if it's not passed
    If odi___ Is Nothing Then
        Set odi___ = CreateObject("Scripting.Dictionary")
        odi___.CompareMode = 0
        
        ' Initialize phonetic patterns
        Dim pat1, pat2, ba1, angg As Variant
        pat1 = Array("a", "a", "a", "e", "e", "i", "o", "o", "o", "u", "u", "y")
        pat2 = Array("", "w", "a", "", "e", "", "", "o", "w", "", "w", "")
        ba1 = Array( _
            Array(0, 259, 226, 0, 234, 0, 0, 244, 417, 0, 432, 0), _
            Array(225, 7855, 7845, 233, 7871, 237, 243, 7889, 7899, 250, 7913, 253), _
            Array(224, 7857, 7847, 232, 7873, 236, 242, 7891, 7901, 249, 7915, 7923), _
            Array(7843, 7859, 7849, 7867, 7875, 7881, 7887, 7893, 7903, 7911, 7917, 7927), _
            Array(227, 7861, 7851, 7869, 7877, 297, 245, 7895, 7905, 361, 7919, 7929), _
            Array(7841, 7863, 7853, 7865, 7879, 7883, 7885, 7897, 7907, 7909, 7921, 7925))
        
        ' Build phonetic dictionary
        For iba = 0 To 5
            angg = ba1(iba)
            For m = LBound(angg) To UBound(angg)
                If angg(m) > 0 Then
                    m0 = ChrW$(angg(m))
                    odi___.Add m0, Array(pat1(m), pat2(m))
                    odi___.Add UCase$(m0), Array(UCase$(pat1(m)), pat2(m))
                End If
            Next
        Next
        odi___.Add "scrt", CreateObject("Scripting.Dictionary")
    End If

    Dim ms2 As Object
    Set ms2 = re.Execute(text)
    re.IgnoreCase = False

    If ms2.Count > 0 Then
        Dim i1 As Long: i1 = 1
        For Each m In ms2
            v = m.SubMatches(0)
            Dim i2 As Long: i2 = IIf(v = Empty, 1, 2)
            Dim i3 As Long: i3 = m.FirstIndex + i2
            
            If i3 > i1 Then
                v = Mid$(text, i1, i3 - i1)
                GoSub r
                z = z & VNiEscape(v) & m.SubMatches(1)
            Else
                z = z & m.SubMatches(1)
            End If
            
            i1 = m.FirstIndex + m.Length + 1
        Next
        If i1 <= l Then
            v = Mid$(text, i1)
            GoSub r
            z = z & VNiEscape(v)
        End If
    Else
        v = text
        GoSub r
        z = VNiEscape(v)
    End If
    
    VNiTelex = z
    Exit Function

r:
    If di2.Count Then di2.RemoveAll
    Set ms = oregex___Execute(v)
    If ms.Count = 0 Then Return
    
    iba = 2
l:
    For Each m1 In ms
        If Not di2.Exists(m1) Then
            m3 = m1.SubMatches(2)
            If Len(m3) = iba Then
                di2.Add m1, ""
                m2 = m1.SubMatches(1)
                m0 = IIf(Len(m2) = 2, odi___(Left$(m2, 1))(0), "")
                aF = odi___(Right$(m2, 1))
                re.Pattern = m1
                v = re.Replace(v, m0 & aF(0) & m3 & "." & aF(1))
            End If
        End If
    Next
    If iba > 0 Then iba = iba - 1: GoTo l
Return

End Function

Sub VNiTelexMultiDecode(ParamArray text())
    Dim i As Long, s As String, p, v As String
    v = vbBack & vbBack & "\" & vbBack
    p = Join(text, v)
    p = Split(VNiTelexDecode(s), v)
    For i = 0 To UBound(text)
        text(i) = p(i)
    Next
End Sub

Function VNiTelexDecode(ByVal text As String, Optional oregex___ As Object, Optional odi___ As Object) As String
    Dim l As Long: l = Len(text): If l = 0 Then Exit Function
    Dim di2 As Object, v As String, z As String
    Set di2 = CreateObject("Scripting.Dictionary")
    di2.CompareMode = 0
    Dim re As Object, ms As Object
    Set re = CreateObject("VBScript.RegExp")
    
    With re
        .Global = True: .IgnoreCase = True: .MultiLine = True
        .Pattern = "(^|[^\\]?)\{/([^\u0008]*?)/\}"
    End With
    
    ' Additional configuration omitted for brevity...
    
    Set ms2 = re.Execute(text)
    If ms2.Count > 0 Then
        Dim i1 As Long: i1 = 1
        For Each m In ms2
            v = m.SubMatches(0)
            Dim i2 As Long: i2 = IIf(v = Empty, 1, 2)
            Dim i3 As Long: i3 = m.FirstIndex + i2
            
            If i3 > i1 Then
                v = Mid$(text, i1, i3 - i1)
                GoSub r
                z = z & v & m.SubMatches(1)
            Else
                z = z & m.SubMatches(1)
            End If
            
            i1 = m.FirstIndex + m.Length + 1
        Next
        
        If i1 <= l Then
            v = Mid$(text, i1)
            GoSub r
            z = z & v
        End If
    Else
        v = text
        GoSub r
        z = v
    End If
    
    VNiTelexDecode = z
    Exit Function

r:
    If di2.Count Then di2.RemoveAll
    v = VNiUnescape(v)
    
    With re
        .IgnoreCase = False
        .Pattern = "D[Dd]": v = .Replace(v, ChrW$(272))
        .Pattern = "d[Dd]": v = .Replace(v, ChrW$(273))
        .IgnoreCase = True
    End With

    Set ms = oregex___.Execute(v)
    If ms.Count = 0 Then Return

    iba = 2
l:
    For Each m In ms
        ' Processing logic...
    Next
    If iba > 0 Then iba = iba - 1: GoTo l
Return
End Function

htin1997 · 5/9/24

Cách dùng đơn giản hơn, em từng sưu tầm được trên GPE

Mã:

Function T_Uni(MyStr As String) As String
'Ham thay doi TV qua uni code
  Application.Volatile
Dim str As String, CStart As Integer, CCount As Integer, Status As Boolean
str = "-7842-7843-7841-259-7855-7857-7859-7861-7863-7845-7847-7849-7851-7853-273-7867-7869-7865-7871-7873-7875-7877-7879-7881-297-7883-7887-7885-7889-7891-7893-7895-7897-417-7899-7901-7903-7905-7907-7911-361-7909-432-7913-7915-7917-7919-7921-7923-7927-7929-7925-7840-258-7854-7856-7858-7860-7862-7844-7846-7848-7850-7852-272-7866-7868-7864-7870-7872-7874-7876-7878-7880-296-7882-7886-7884-7888-7890-7892-7894-7896-416-7898-7900-7902-7904-7906-7910-360-7908-431-7912-7914-7916-7918-7920-7922-7926-7928-7924-10-"
For i = 1 To Len(MyStr)
If InStr(str, "-" & AscW(Mid(MyStr, i, 1)) & "-") = 0 Then
    If Not Status Then
        CStart = i:        Status = True
    End If
    CCount = CCount + 1
Else
    If Status Then T_Uni = T_Uni & IIf(T_Uni = "", "", " & ") & """" & Mid(MyStr, CStart, CCount) & """"
    Status = False
    CCount = 0
    T_Uni = T_Uni & IIf(T_Uni = "", "", " & ") & "ChrW(" & AscW(Mid(MyStr, i, 1)) & ")"
End If
Next
If Status Then T_Uni = T_Uni & IIf(T_Uni = "", "", " & ") & """" & Mid(MyStr, CStart, CCount) & """"
End Function

HeSanbi · 5/9/24

htin1997 đã viết:
Cách dùng đơn giản hơn, em từng sưu tầm được trên GPE

Bạn nên biết sâu hơn về ký tự thì mới biết mình đang học hỏi đúng hay sai.
Ký tự "á" và "à" trong mã đó khi ghi vào code VBA thì nó không phải là ký tự "á" và "à" Unicode.
Mã của bạn đề xuất không có khả năng mã hóa các ký tự khác ngoài tiếng Việt.
Dịch mã sang hàm ChrW là tốn kém và khó đọc.

htin1997 · 5/9/24

HeSanbi đã viết:
Bạn nên biết sâu hơn

Vâng, em thật sự chưa biết sâu hơn thật, em thấy đáp ứng đúng cái em cần nên chia sẻ lại mang tính tham khảo cho những anh/chị đang đi tìm giải pháp, không có ý phản bác hay dẫn dắt đi xa code của anh, anh thông cảm. Cảm ơn anh đã giải thích.

VNiTelex v1.21 - Hàm mã hóa giải mã chuỗi Unicode và Tiếng Việt cho mã VBA (1 người xem)

Người dùng đang xem chủ đề này

HeSanbi

Thành viên gắn bó

HeSanbi

HeSanbi

Thành viên gắn bó

HeSanbi

Thành viên gắn bó

HeSanbi

Thành viên gắn bó

Văn Toàn 1996

Thành viên bị đình chỉ hoạt động

htin1997

Dậm chân tại chỗ là đi lùi.

HeSanbi

Thành viên gắn bó

htin1997

Dậm chân tại chỗ là đi lùi.

Bài viết mới nhất

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Thời gian đếm ngược.