• Hàm chuyển tiền thành chữ Unicode (một hàm duy nhất) không lỗi Font
  • Hàm chuyển tiền thành chữ Unicode (một hàm duy nhất) không lỗi Font

    tranthanhan1962 > 18-02-17, 07:00 PM

    Ngồi vọc lại mấy chương trình cổ thấy hàm đọc số excel của một cao thủ đời 80 thấy hay quá. Function này cũng xài tốt cho access. Có điều font VNI thì được còn Unicode bị lỗi font. Thử gõ lại phần tiếng Việt bằng bộ gõ Windows, không ngờ lại OK.
    Mã:
    Public Function VND(BaoNhieu)
    Dim KetQua, SOTIEN, Nhom, Chu, Dich, S1, S2, S3 As String
    Dim i, j, Vitri As Byte, S As Double
    Dim HANG, Doc, Dem, l
    If BaoNhieu = 0 Then
       KetQua = "Không đồng"
    Else
       If Abs(BaoNhieu) >= 1E+15 Then '1E+15 tức 1.000.000.000.000.000 tức 1 triệu tỷ
           KetQua = "Số quá lớn"
       Else
           If BaoNhieu < 0 Then
               KetQua = "Âm" & Space(1)
           Else
               KetQua = Space(0)
               End If
               SOTIEN = Format(Abs(BaoNhieu), "##############0.00")
               SOTIEN = Right(Space(15) & SOTIEN, 18)
               HANG = Array("None", "trăm", "mươi", "gì đó")
               Doc = Array("Nonne", "nghìn tỷ", "tỷ", "triệu", "nghìn", "đồng", "xu")
               Dem = Array("None", "một", "hai", "ba", "bốn", "năm", "sáu", "bảy", "tám", "chín")
               For i = 1 To 6
                   Nhom = Mid(SOTIEN, i * 3 - 2, 3)
                   If Nhom <> Space(3) Then
                       Select Case Nhom
                           Case "000"
                               If i = 5 Then
                                   Chu = "đồng" & Space(1)
                               Else
                                   Chu = Space(0)
                               End If
                           Case ",00"
                           Chu = "chẵn"
                           Case "0.00"
                           Chu = " chẵn"
                           Case Else
                               S1 = Left(Nhom, 1)
                               S2 = Mid(Nhom, 2, 1)
                               S3 = Right(Nhom, 1)
                               Chu = Space(0)
                               HANG(3) = Doc(i)
                               For j = 1 To 3
                                   Dich = Space(0)
                                   S = Val(Mid(Nhom, j, 1))
                                   If S > 0 Then
                                       Dich = Dem(S) & Space(1) & HANG(j) & Space(1)
                                   End If
                                   Select Case j
                                       Case 2 And S = 1
                                           Dich = "mười" & Space(1)
                                       Case 3 And S = 0 And Nhom <> Space(2) & "0"
                                           Dich = HANG(j) & Space(1)
                                   Case 3 And S = 5 And S2 <> Space(1) And S2 <> "0"
                                           Dich = "l" & Mid(Dich, 2) 'ký tự l
                                       Case 2 And S = 0 And S3 <> "0"
                                           If (S1 >= "1" And S1 <= "9") Or (S1 = "0" And l = 4) Then
                                               Dich = "lẻ" & Space(1)
                                           End If
                                       End Select
                                       Chu = Chu & Dich
                                   Next j
                               End Select
                               Vitri = InStr(1, Chu, "mươi một", 1)
                               If Vitri > 0 Then Mid(Chu, Vitri, 9) = "mươi mốt"
                               KetQua = KetQua & Chu
                           End If
                       Next i
                   End If
               End If
               VND = UCase(Left(KetQua, 1)) & Mid(KetQua, 2)
       End Function

    Các bạn muốn sử dụng phải tắt bộ gõ tiếng Việt và thiết đặt Vietnamesse keyboard trước khi copy và dán vào module thì mới không bị lỗi. Sau khi dán vào module mà font chữ tiếng Việt vẫn giữ nguyên thì đã thành công.
  • RE: Hàm chuyển tiền thành chữ Unicode (một hàm duy nhất) không lỗi Font

    vuthaiha90 > 20-02-17, 05:19 PM

    (18-02-17, 07:00 PM)tranthanhan1962 Đã viết: Ngồi vọc lại mấy chương trình cổ thấy hàm đọc số excel của một cao thủ đời 80 thấy hay quá. Function này cũng xài tốt cho access. Có điều font VNI thì được còn Unicode bị lỗi font. Thử gõ lại phần tiếng Việt bằng bộ gõ Windows, không ngờ lại OK.
    Mã:
    Public Function VND(BaoNhieu)
    Dim KetQua, SOTIEN, Nhom, Chu, Dich, S1, S2, S3 As String
    Dim i, j, Vitri As Byte, S As Double
    Dim HANG, Doc, Dem, l
    If BaoNhieu = 0 Then
       KetQua = "Không đồng"
    Else
       If Abs(BaoNhieu) >= 1E+15 Then '1E+15 tức 1.000.000.000.000.000 tức 1 triệu tỷ
           KetQua = "Số quá lớn"
       Else
           If BaoNhieu < 0 Then
               KetQua = "Âm" & Space(1)
           Else
               KetQua = Space(0)
               End If
               SOTIEN = Format(Abs(BaoNhieu), "##############0.00")
               SOTIEN = Right(Space(15) & SOTIEN, 18)
               HANG = Array("None", "trăm", "mươi", "gì đó")
               Doc = Array("Nonne", "nghìn tỷ", "tỷ", "triệu", "nghìn", "đồng", "xu")
               Dem = Array("None", "một", "hai", "ba", "bốn", "năm", "sáu", "bảy", "tám", "chín")
               For i = 1 To 6
                   Nhom = Mid(SOTIEN, i * 3 - 2, 3)
                   If Nhom <> Space(3) Then
                       Select Case Nhom
                           Case "000"
                               If i = 5 Then
                                   Chu = "đồng" & Space(1)
                               Else
                                   Chu = Space(0)
                               End If
                           Case ",00"
                           Chu = "chẵn"
                           Case "0.00"
                           Chu = " chẵn"
                           Case Else
                               S1 = Left(Nhom, 1)
                               S2 = Mid(Nhom, 2, 1)
                               S3 = Right(Nhom, 1)
                               Chu = Space(0)
                               HANG(3) = Doc(i)
                               For j = 1 To 3
                                   Dich = Space(0)
                                   S = Val(Mid(Nhom, j, 1))
                                   If S > 0 Then
                                       Dich = Dem(S) & Space(1) & HANG(j) & Space(1)
                                   End If
                                   Select Case j
                                       Case 2 And S = 1
                                           Dich = "mười" & Space(1)
                                       Case 3 And S = 0 And Nhom <> Space(2) & "0"
                                           Dich = HANG(j) & Space(1)
                                   Case 3 And S = 5 And S2 <> Space(1) And S2 <> "0"
                                           Dich = "l" & Mid(Dich, 2) 'ký tự l
                                       Case 2 And S = 0 And S3 <> "0"
                                           If (S1 >= "1" And S1 <= "9") Or (S1 = "0" And l = 4) Then
                                               Dich = "lẻ" & Space(1)
                                           End If
                                       End Select
                                       Chu = Chu & Dich
                                   Next j
                               End Select
                               Vitri = InStr(1, Chu, "mươi một", 1)
                               If Vitri > 0 Then Mid(Chu, Vitri, 9) = "mươi mốt"
                               KetQua = KetQua & Chu
                           End If
                       Next i
                   End If
               End If
               VND = UCase(Left(KetQua, 1)) & Mid(KetQua, 2)
       End Function

    Các bạn muốn sử dụng phải tắt bộ gõ tiếng Việt và thiết đặt Vietnamesse keyboard trước khi copy và dán vào module thì mới không bị lỗi. Sau khi dán vào module mà font chữ tiếng Việt vẫn giữ nguyên thì đã thành công.

    Em thì dùng cái này để đọc số tiền:
    Mã:
    Option Compare Database
    Function DocSo(ByVal Number, Optional ByVal Font = 1) As String
    Dim MyArray
    Dim Str
    Str = Format(Abs(Number), "000000000000000000")
    Select Case Font
    Case 1
    MyArray = Array("không ", "m" & ChrW(7897) & "t ", "hai ", "ba ", "b" & ChrW(7889) & "n ", "n" & ChrW(259) & "m ", "sáu ", "b" & ChrW(7843) & "y ", "tám ", "chín ", "tri" & ChrW(7879) & "u ", "ngàn ", "t" & ChrW(7927) & " ", "tri" & ChrW(7879) & "u ", "ngàn ", "", "tr" & ChrW(259) & "m ", "m" & ChrW(432) & ChrW(417) & "i ", "không " & "m" & ChrW(432) & ChrW(417) & "i" & " không ", "không " & "m" & ChrW(432) & ChrW(417) & "i", "l" & ChrW(7867), "m" & ChrW(432) & ChrW(417) & "i" & " không", "m" & ChrW(432) & ChrW(417) & "i", "m" & ChrW(432) & ChrW(417) & "i" & " n" & ChrW(259) & "m", "m" & ChrW(432) & ChrW(417) & "i" & " l" & ChrW(259) & "m", "m" & ChrW(7897) & "t " & "m" & ChrW(432) & ChrW(417) & "i", "m" & ChrW(432) & ChrW(7901) & "i", "m" & ChrW(432) & ChrW(417) & "i" & " m" & ChrW(7897) & "t", "m" & ChrW(432) & ChrW(417) & "i" & " m" & ChrW(7889) & "t", "Âm ")
    Case 2
    MyArray = Array("khoâng ", "moät ", "hai ", "ba ", "boán ", "naêm ", "saùu ", "baûy ", "taùm ", "chín ", "trieäu, ", "ngaøn, ", "tyû, ", "trieäu, ", "ngaøn, ", "", "traêm ", "möôi ", "khoâng möôi khoâng ", "khoâng möôi", "leû", "möôi khoâng", "möôi", "möôi naêm", "möôi laêm", "moät möôi", "möôøi", "möôi moät", "möôi moát", "AÂm ")
    Case 3
    MyArray = Array("kh«ng ", "mét ", "hai ", "ba ", "bèn ", "n¨m ", "s¸u ", "b¶y ", "t¸m ", "chÝn ", "triÖu, ", "ngµn, ", "tû, ", "triÖu, ", "ngµn, ", "", "tr¨m ", "m­¬i ", "kh«ng m­¬i kh«ng ", "kh«ng m­¬i", "lÎ", "m­¬i kh«ng", "m­¬i", "m­¬i n¨m", "m­¬i l¨m", "mét m­¬i", "m­êi", "m­¬i mét", "m­¬i mèt", "©m ")
    End Select
    If Str = "000000000000000000" Then
       DocSo = UCase(Left(MyArray(0), 1)) & Trim(Mid(MyArray(0), 2)) & ChrW$(273) & ChrW$(7891) & "ng" '"."
       Exit Function
    End If
    For i = 1 To Len(Str)
    If Left(Str, i) <> 0 And Mid(Str, (Int((i + 2) / 3) - 1) * 3 + 1, 3) <> 0 Then
       DocSo = DocSo & MyArray(Mid(Str, i, 1)) & MyArray(-(9 + i / 3) * (i Mod 3 = 0) - (15 + i Mod 3) * (i Mod 3 <> 0))
    ElseIf i = 9 And Mid(Str, 7, 3) = 0 And Left(Str, 6) <> 0 Then
       DocSo = DocSo & MyArray(12)
    End If
    Next
    DocSo = Trim(Replace(Replace(Replace(Replace(Replace(Replace(DocSo, MyArray(18), MyArray(15)), MyArray(19), MyArray(20)), MyArray(21), MyArray(22)), MyArray(23), MyArray(24)), MyArray(25), MyArray(26)), MyArray(27), MyArray(28)))
    If Number < 0 Then
    DocSo = MyArray(29) & DocSo
    End If
    DocSo = Replace(UCase(Left(DocSo, 1)) & Mid(DocSo, 2) & " " & ChrW$(273) & ChrW$(7891) & "ng", ",.", " " & ChrW$(273) & ChrW$(7891) & "ng") '".")
    End Function