人民币的大小写转换

Question

Private Function 转换(strx As String, ii As Integer, dot As Integer) As String
Dim str As String
Dim str1 As StringSelect Case strx
       Case "1"
            str = "壹"
       Case "2"
            str = "贰"
       Case "3"
            str = "叁"
       Case "4"
            str = "肆"
       Case "5"
            str = "伍"
       Case "6"
            str = "陆"
       Case "7"
            str = "柒"
       Case "8"
            str = "捌"
       Case "9"
            str = "玖"
       Case "0"
            str = "零"
End Select
Select Case ii
       Case 1
            str1 = "元"
       Case 2
            str1 = "拾"
       Case 3
            str1 = "佰"
       Case 4
            str1 = "仟"
       Case Else
            str1 = ""
       
End Select
Select Case dot
       Case 2
            str1 = "分"
       Case 1
            str1 = "角"
       
End Select
转换 = str & str1
End Function
X = InStr(str, ".")
If X > 0 Then '有小数点
   leftstr = Left(str, X - 1)
   rightstr = Right(str, Len(str) - X)
   n = Len(leftstr)
   For i = 1 To Len(leftstr)
        returnX = returnX & 转换(Mid(leftstr, i, 1), n, 0)
        n = n - 1
   Next i
   
   n = Len(rightstr)
   For i = 1 To Len(rightstr)
        returnX = returnX & 转换(Mid(rightstr, i, 1), 0, i)
        n = n - 1
   Next i
Else '没有小数点
  leftstr = str
  n = Len(leftstr)
  For i = 1 To Len(leftstr)
     returnX = returnX & 转换(Mid(leftstr, i, 1), n, 0)
     
     n = n - 1
  Next i
  returnX = returnX & "整"
End If

Answer 1

Public Function UpCaseRMB(dValue As Double) As String
    Dim I As Integer
    Dim K As Integer
    
    Dim sC1 As String
    Dim sC2 As String
    Dim sC3 As String
    Dim sNC As String
    Dim sNum As String
    
    Dim sXiao As String
    Dim sZheng As String
     
    
    
    sNC = Trim(Format(dValue, "##0.00"))
    sC1 = "仟佰拾万仟佰拾亿仟佰拾万仟佰拾元"
    sC2 = "角分"
    sC3 = "玖捌柒陆伍肆叁贰壹"
    If sNC = 0 Then
        UpCaseRMB = "零元整"
        Exit Function
    End If
    UpCaseRMB = ""
    sZheng = Mid(sNC, 1, (Len(sNC) - 3))
    sXiao = Mid(sNC, (Len(sZheng) + 2))
    If Val(sXiao) <> 0 Then
        For I = Len(sXiao) To 1 Step -1
            sNum = Mid(sXiao, I, 1)
            If sNum <> 0 Then
                UpCaseRMB = Mid(sC2, I, 1) & UpCaseRMB
                UpCaseRMB = Mid(sC3, (Len(sC3) - sNum + 1), 1) & UpCaseRMB
            End If
        Next I
    End If
    
    K = 0
    If Val(sZheng) <> 0 Then
        UpCaseRMB = "元" & UpCaseRMB
        For I = Len(sZheng) To 1 Step -1
            If (Len(sZheng) - I) = 4 Then
                UpCaseRMB = "万" & UpCaseRMB
            ElseIf (Len(sZheng) - I) = 8 Then
                UpCaseRMB = "亿" & UpCaseRMB
            ElseIf (Len(sZheng) - I) = 12 Then
                UpCaseRMB = "万" & UpCaseRMB
            End If
            sNum = Mid(sZheng, I, 1)
            If sNum <> 0 Then
                If I = Len(sZheng) Then
                    UpCaseRMB = Mid(sC3, (Len(sC3) - sNum + 1), 1) & UpCaseRMB
                Else
                    If (Len(sZheng) - I) <> 4 And (Len(sZheng) - I) <> 8 And (Len(sZheng) - I) <> 12 Then
                        UpCaseRMB = Mid(sC1, (Len(sC1) - K), 1) & UpCaseRMB
                    End If
                    UpCaseRMB = Mid(sC3, (Len(sC3) - sNum + 1), 1) & UpCaseRMB
                End If
            Else
                If Mid(UpCaseRMB, 1, 1) <> "元" And Mid(UpCaseRMB, 1, 1) <> "万" And Mid(UpCaseRMB, 1, 1) <> "亿" Then
                    If Mid(UpCaseRMB, 1, 1) <> "零" Then
                        UpCaseRMB = "零" & UpCaseRMB
                    End If
                End If
           End If
            K = K + 1
        Next I
    End If
    If Right(Trim(UpCaseRMB), 1) <> "分" Then
        UpCaseRMB = UpCaseRMB & "整"
    End If
End Function

Answer 2

'支持人民币、外币
'N 是数字金额     CCNO 是货币代号(详见程序)
Function DVC(N As String,CCNO As String) As String
Dim Num As String
Dim Prt As String
Dim L As Integer
Dim B As Integer
Dim C As String
Dim T As Integer
Dim J As Integer
Dim LastCha As String
Dim PrtCha As String
Dim Nums As String
Dim U As Integer
Dim S As String
Dim Cha As String
Dim NumCha As String
CCNO = "01"
Num = Trim$(N)
Prt = Empty
L = Len(Num) - 3
B = L - Int(L / 4) * 4
Nums = Left(Num, L)
LastCha = Empty
PrtCha = Empty
C = Empty
T = 1
J = L
U = B
If B = 0 And L > 4 Or B = 0 And L = 4 Then
U = 4
End If
Do While T < L + 1
S = Mid$(Nums, T, 1)
Select Case S
   Case "1"
   NumCha = "壹"
   Case "2"
   NumCha = "贰"
   Case "3"
   NumCha = "叁"
   Case "4"
   NumCha = "肆"
   Case "5"
   NumCha = "伍"
   Case "6"
   NumCha = "陆"
   Case "7"
   NumCha = "柒"
   Case "8"
   NumCha = "捌"
   Case "9"
   NumCha = "玖"
   Case "0"
   NumCha = ""
End Select
Select Case U
   Case 1
   C = ""
   Case 2
   C = "拾"
   Case 3
   C = "佰"
   Case 4
   C = "仟"
End Select
If S <> "0" And LastCha = "0" Then
   PrtCha = PrtCha + "零"
End If
If S <> "0" Then
   PrtCha = PrtCha + NumCha + C
End IfIf J = 9 Or J = 5 Or J = 1 Then
Select Case J
   Case 9
   Cha = "亿"
   Case 5
   Cha = "万"
End Select
If J = 1 Then
   Select Case CCNO
      Case "01"
      Cha = "元"
      Case "12"
      Cha = "镑"
      Case "13"
      Cha = "元"
      Case "14"
      Cha = "元"
      Case "15"
      Cha = "法郎"
      Case "16"
      Cha = "马克"
      Case "17"
      Cha = "法郎"
      Case "18"
      Cha = "元"
      Case "20"
      Cha = "盾"
      Case "21"
      Cha = "克朗"
      Case "22"
      Cha = "克朗"
      Case "23"
      Cha = "克朗"
      Case "24"
      Cha = "先令"

Answer 3

Case "25"
      Cha = "法郎"
      Case "26"
      Cha = "里拉"
      Case "27"
      Cha = "元"
      Case "28"
      Cha = "元"
      Case "29"
      Cha = "元"
      Case "32"
      Cha = "林吉特"
      Case "42"
      Cha = "马克"
      Case "81"
      Cha = "元"
      Case "82"
      Cha = "比索"
      Case "84"
      Cha = "铢"
    End Select
End If
PrtCha = PrtCha + Cha
End If
J = J - 1
T = T + 1
U = U - 1
If U = 0 Then
 U = 4
End If
LastCha = S
S = "0"
LoopNums = Right$(Num, 2)
T = 1
Do While T < 3 And Nums <> "00"
S = Mid$(Nums, T, 1)
Select Case S
   Case "1"
   NumCha = "壹"
   Case "2"
   NumCha = "贰"
   Case "3"
   NumCha = "叁"
   Case "4"
   NumCha = "肆"
   Case "5"
   NumCha = "伍"
   Case "6"
   NumCha = "陆"
   Case "7"
   NumCha = "柒"
   Case "8"
   NumCha = "捌"
   Case "9"
   NumCha = "玖"
   Case "0"
   NumCha = ""
 End Select
 C = ""
If S <> "0" And CCNO = "01" And T = 1 Then
   C = "角"
PrtCha = PrtCha + NumCha + C
End If
If S <> "0" And CCNO = "13" And T = 1 Then
   C = "仙"
PrtCha = PrtCha + NumCha + C
End If
If S <> "0" And CCNO <> "01" And CCNO <> "13" And T = 1 Then
   C = "拾"
PrtCha = PrtCha + NumCha + C
End IfIf T = 2 And CCNO <> "01" And CCNO <> "13" Then
   Select Case CCNO
      Case "12"
      C = "便士"
      Case "14"
      C = "分"
      Case "15"
      C = "分"
      Case "16"
      C = "芬尼"
      Case "17"
      C = "分"
      Case "18"
      C = "分"
      Case "20"
      C = "分"
      Case "21"
      C = "欧尔"
      Case "22"
      C = "欧尔"
      Case "23"
      C = "欧尔"
      Case "24"
      C = "分"
      Case "25"
      C = "分"
      Case "26"
      C = "分"
      Case "27"
      C = "钱"
      Case "28"
      C = "分"
      Case "29"
      C = "分"
      Case "32"
      C = "分"
      Case "42"
      C = "芬尼"
      Case "81"
      C = "分"
      Case "82"
      C = "分"
      Case "84"
      C = "萨当"
    End Select
PrtCha = PrtCha + NumCha + C
End If
If T = 2 And CCNO = "01" And S <> "0" Then
  PrtCha = PrtCha + NumCha + "分"
End If
If T = 2 And CCNO = "13" And S <> "0" Then
  PrtCha = PrtCha + NumCha + "毫"
End IfT = T + 1
LoopIf Right$(Nums, 1) = "0" Then
 Prt = PrtCha + "整"
 Else
 Prt = PrtCha
End If
DVC = Prt  'Only RMB

Answer 4

可无任何长度限制
Option Explicit
Public Function NtoC(ByVal sNum As String, Optional BITs As String = ",拾,佰,仟", Optional UNITs As String = ",[万],[亿],[兆],[万兆]", Optional ByVal Yuan As String = "美圆", Optional ByVal Jiao As String = "美角", Optional ByVal Fen As String = "美分") As String
If Val(Trim(sNum)) > 0 Then
  Dim sIntD, sDecD As String
  Dim i, iCount, j, iLength As Integer
  Dim lStartPos As Long
  Dim sBIT() As String
  Dim sUNIT() As String
  Dim sCents(2) As String
  sBIT = VBA.Split(BITs, ",")
  sUNIT = VBA.Split(UNITs, ",")
  sCents(0) = Fen
  sCents(1) = Jiao
  Dim temp As String
  If InStr(Trim(sNum), ".") > 0 Then
     temp = Left(Trim(sNum), InStr(Trim(sNum), ".") - 1)
  Else
     temp = Trim(sNum)
  End If
  iCount = IIf(Len(temp) Mod 4, Len(Trim(temp)) \ 4 + 1, Len(Trim(temp)) \ 4)
  lStartPos = 1
  For i = iCount To 1 Step -1
      If i = iCount And Len(Trim(temp)) Mod 4 <> 0 Then
         iLength = Len(Trim(temp)) Mod 4
      Else
         iLength = 4
      End If
      sIntD = Mid(Trim(temp), lStartPos, iLength)
      For j = 1 To Len(Trim(sIntD))
          If Val(Mid(sIntD, j, 1)) <> 0 Then
             NtoC = NtoC & Choose(Val(Mid(sIntD, j, 1)), "壹", "贰", "叁", "肆", "伍", "陆", "柒", "捌", "玖") & sBIT(Len(Trim(sIntD)) - j)
          Else
             If Val(Mid(sIntD, j + 1, 1)) <> 0 Then
                NtoC = NtoC & "零"
             End If
          End If
      Next j
      lStartPos = lStartPos + iLength
      If i < iCount Then
         If (Val(Mid(sIntD, Len(Trim(sIntD)), 1)) <> 0 Or Val(Mid(sIntD, Len(Trim(sIntD)) - 1, 1)) <> 0 Or Val(Mid(sIntD, Len(Trim(sIntD)) - 2, 1)) Or Val(Mid(sIntD, Len(Trim(sIntD)) - 3, 1)) <> 0) Then
            If i < UBound(sUNIT) + 1 Then
               NtoC = NtoC & sUNIT(i - 1)
            'Else
            '   NtoC = NtoC & sUNIT(i - 1)
            End If
         End If
      Else
         'If i < UBound(sUNIT) + 1 Then
            NtoC = NtoC & sUNIT(i - 1)
         'End If
      End If
  Next
  If Len(Trim(NtoC)) > 0 Then
     NtoC = NtoC & Yuan
  End If
  '小数
  If InStr(1, Trim(sNum), ".") <> 0 Then
     sDecD = Right(sNum, Len(Trim(sNum)) - InStr(1, Trim(sNum), "."))
     For i = 1 To Len(Trim(sDecD))
         If Val(Mid(Trim(sDecD), i, 1)) <> 0 Then
            NtoC = NtoC & Choose(Val(Mid(Trim(sDecD), i, 1)), "壹", "贰", "叁", "肆", "伍", "陆", "柒", "捌", "玖")
            NtoC = NtoC & sCents(2 - i)
            If i >= 2 Then
               Exit For
            End If
         Else
            If Len(Trim(NtoC)) > 0 Then
               NtoC = NtoC & "零"
            End If
         End If
     Next i
  Else
     NtoC = NtoC & "整"
  End If
Else
  NtoC = "零" & Yuan
End If
End FunctionPrivate Sub Command1_Click()
VBA.MsgBox NtoC("111111111111111111.97")
End Sub