• Tùy chọn
• Đăng nhập
• Đăng ký
• Xem như trên Máy tính
• Accelerated Mobile Pages Theme

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

• Trang chủ

  • Thủ Thuật Access
  • Access Nâng Cao
  • Thư Viện Hàm
  • 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

• 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
• Bài trước Bài tiếp