用vb如何写一个转换数字为人民币的函数

Question

在pb中hugao(糊搞)用pb写过,在此用vb改写，希望对你有所帮助Public Function GetrmbDx(rmbXx As Double) As String
  'rmbdx 将要返回的人民币大写,zs 整数部分,xs 小数部分
  Dim rmbDx As String, Zs As String, Xs As String
  rmbDx = "": Zs = "": Xs = ""
  
  Dim Dw(3) As String  '单位大写
  Dw(0) = "": Dw(1) = "拾": Dw(2) = "佰": Dw(3) = "仟"
  
  Dim Dxsz(9) As String '数值大写
  Dxsz(0) = "零": Dxsz(1) = "壹": Dxsz(2) = "贰": Dxsz(3) = "叁": Dxsz(4) = "肆"
  Dxsz(5) = "伍": Dxsz(6) = "陆": Dxsz(7) = "柒": Dxsz(8) = "捌": Dxsz(9) = "玖"
  
  'wwflag 为万位标志,ywflag 为亿位标志 flag 为有无小数部分标志,zeroflag 为零位标志
  Dim n As Integer, zeroFlag As Integer, Flag As Integer, wwFlag As Integer
  Dim ywFlag As Integer
  zeroFlag = 0: Flag = 0: wwFlag = 0: ywFlag = 0
  
  If rmbXx >= 10000000000000# Then
    MsgBox "数值太大，无法转换"
    Exit Function
  End If
  
  If rmbXx = 0 Then
    GetrmbDx = "零元整"
    Exit Function
  End If
  
  rmbXx = Format(rmbXx, "0.##")
  rmbDx = CStr(rmbXx)
  For n = 1 To Len(rmbDx)
    If (Mid(rmbDx, n, 1)) = "." Then
      n = n + 1
      Flag = 1                       '判断有无小数部分
      Exit For
    Else
      Zs = Zs + Mid(rmbDx, n, 1)     '取整数部分
    End If
  Next n
  
  If Flag = 1 Then
    Xs = Mid(rmbDx, n, 2)            '取小数部分
  End If
  
  rmbDx = ""
  
  If Zs <> "0" Then                   '如zs=0则一定是整数没有而小数部分有值
    rmbDx = rmbDx + "元"
    For n = Len(Zs) To 1 Step -1
      If Mid(Zs, n, 1) <> "0" Then    '如果当前处理的位不为'0'时
        If (Len(Zs) - n + 1) > 4 And Len(Zs) - n + 1 < 9 And wwFlag = 0 Then '处理单位"万"
          rmbDx = "万" + rmbDx
          wwFlag = 1
        End If
        
        If (Len(Zs) - n + 1) > 8 And ywFlag = 0 Then  '处理单位"亿"
          rmbDx = "亿" + rmbDx
          ywFlag = 1
        End If
        rmbDx = Dxsz(CInt(Mid(Zs, n, 1))) + Dw((Len(Zs) - n) Mod 4) + rmbDx '转换相应位置的数的人民币大写字串
        zeroFlag = 1
      Else
        If zeroFlag = 1 And n <> Len(Zs) Then
          rmbDx = "零" + rmbDx
        End If
        zeroFlag = 0
      End If
    Next n
  End If
  
  If Xs <> "" Then    '当有小数位时
    If Len(Xs) = 1 Then      '当小数位只有一位时
        rmbDx = rmbDx + Dxsz(CInt(Mid(Xs, 1, 1))) + "角整"
    Else                '当小数位有两位时
        If Mid(Xs, 1, 1) <> "0" Then  '处理角
            rmbDx = rmbDx + Dxsz(CInt(Mid(Xs, 1, 1))) + "角"
        Else
            If Zs <> "0" Then
                rmbDx = rmbDx + "零"
            End If
        End If
        rmbDx = rmbDx + Dxsz(CInt(Mid(Xs, 2, 1))) + "分" '处理分
    End If
  Else        '当没有分时加上'整'字
    rmbDx = rmbDx + "整"
  End If
  
  GetrmbDx = rmbDx
End Function

Answer 1

经过测试发现刚才所写的函数中有两个错误：
1 If rmbXx >= 10000000000000# Then   改为 If rmbXx >= 1000000000000# Then
2 If Zs <> "0" Then                  '如zs=0则一定是整数没有而小数部分有值
 改为
  If Zs <> "" Then                  '如zs=""则一定是整数没有而小数部分有值

Answer 2

Public Function ConvertNum2RMB(Num) As String
    
    Dim money1 As String
    Dim tn As Long
    Dim k1 As String
    Dim k2 As String
    Dim k3 As String
    Dim ST1 As String
    Dim T1 As String    If Num = 0 Then
        ConvertNum2RMB = "零圆"
        Exit Function
    End If
    
    If Num < 0 Then
        ConvertNum2RMB = "负" + ConvertNum2RMB(Abs(Num))
        Exit Function
    End If
    
    money1 = Trim(Str(Num))
    tn = InStr(money1, ".")  '小数位置
    k1 = ""
    If tn <> 0 Then
        ST1 = Right(money1, Len(money1) - tn)
        If ST1 <> "" Then
            T1 = Left(ST1, 1)
            ST1 = Right(ST1, Len(ST1) - 1)
            If T1 <> "0" Then
                k1 = k1 + ChangNum(val(T1)) + "角"
            End If
            If ST1 <> "" Then
                T1 = Left(ST1, 1)
                k1 = k1 + ChangNum(val(T1)) + "分"
            End If
        End If
        ST1 = Left(money1, tn - 1)
    Else
        ST1 = money1
    End If    k2 = ""
    If ST1 <> "" Then
        T1 = Right(ST1, 1)
        ST1 = Left(ST1, Len(ST1) - 1)
        k2 = ChangNum(val(T1)) + k2
    End If    If ST1 <> "" Then
        T1 = Right(ST1, 1)
        ST1 = Left(ST1, Len(ST1) - 1)
        If T1 <> "0" Then
            k2 = ChangNum(val(T1)) + "拾" + k2
        Else
            If Left(k2, 1) <> "零" Then k2 = "零" + k2
        End If
    End If    If ST1 <> "" Then
        T1 = Right(ST1, 1)
        ST1 = Left(ST1, Len(ST1) - 1)
        If T1 <> "0" Then
            k2 = ChangNum(val(T1)) + "佰" + k2
        Else
            If Left(k2, 1) <> "零" Then k2 = "零" + k2
        End If
    End If    If ST1 <> "" Then
        T1 = Right(ST1, 1)
        ST1 = Left(ST1, Len(ST1) - 1)
        If T1 <> "0" Then
            k2 = ChangNum(val(T1)) + "仟" + k2
        Else
            If Left(k2, 1) <> "零" Then k2 = "零" + k2
        End If
    End If    k3 = ""
    If ST1 <> "" Then
        T1 = Right(ST1, 1)
        ST1 = Left(ST1, Len(ST1) - 1)
        k3 = ChangNum(val(T1)) + k3
    End If
    If ST1 <> "" Then
        T1 = Right(ST1, 1)
        ST1 = Left(ST1, Len(ST1) - 1)
        If T1 <> "0" Then
            k3 = ChangNum(val(T1)) + "拾" + k3
        Else
            If Left(k3, 1) <> "零" Then k3 = "零" + k3
        End If
    End If    If ST1 <> "" Then
        T1 = Right(ST1, 1)
        ST1 = Left(ST1, Len(ST1) - 1)
        If T1 <> "0" Then
            k3 = ChangNum(val(T1)) + "佰" + k3
        Else
            If Left(k3, 1) <> "零" Then k3 = "零" + k3
        End If
    End If    If ST1 <> "" Then
        T1 = Right(ST1, 1)
        ST1 = Left(ST1, Len(ST1) - 1)
        If T1 <> "0" Then
            k3 = ChangNum(val(T1)) + "仟" + k3
        End If
    End If
    If Right(k2, 1) = "零" Then k2 = Left(k2, Len(k2) - 1)
    If Len(k3) > 0 Then
        If Right(k3, 1) = "零" Then k3 = Left(k3, Len(k3) - 1)
        k3 = k3 & "万"
    End If    ConvertNum2RMB = IIf(k3 & k2 = "", k1, k3 & k2 & "元" & k1)
    
End FunctionPrivate Function ChangNum(Num As Integer) As String
    
    Select Case Num
        Case 0
            ChangNum = "零"
        Case 1
            ChangNum = "壹"
        Case 2
            ChangNum = "贰"
        Case 3
            ChangNum = "叁"
        Case 4
            ChangNum = "肆"
        Case 5
            ChangNum = "伍"
        Case 6
            ChangNum = "陆"
        Case 7
            ChangNum = "柒"
        Case 8
            ChangNum = "捌"
        Case 9
            ChangNum = "玖"
    End SelectEnd Function

Answer 3

'[email protected]
' 本模块生成汉字大写的金额' 名称： CCh
'        得到一位数字 N1 的汉字大写
'        0 返回 ""
Private Function CCh(N1) As String
Select Case N1
  Case 0
    CCh = "零"
  Case 1
    CCh = "壹"
  Case 2
    CCh = "贰"
  Case 3
    CCh = "叁"
  Case 4
    CCh = "肆"
  Case 5
    CCh = "伍"
  Case 6
    CCh = "陆"
  Case 7
    CCh = "柒"
  Case 8
    CCh = "捌"
  Case 9
    CCh = "玖"
End Select
End Function
'名称： ChMoney
'       得到数字 N1 的汉字大写
'       最大为 千万位
'       O 返回 ""
Public Function ChMoney(N1) As String
Dim tMoney As String
Dim lMoney As String
Dim tn '小数位置
Dim s1 As String '临时STRING 小数部分
Dim s2 As String '1000 以内
Dim s3 As String '10000If N1 = 0 Then
  ChMoney = "零元零分"
  Exit Function
End If
If N1 < 0 Then
  ChMoney = "负" + ChMoney(Abs(N1))
  Exit Function
End If
tMoney = Trim(Str(N1))
tn = InStr(tMoney, ".")  '小数位置
s1 = ""If tn <> 0 Then
  ST1 = Right(tMoney, Len(tMoney) - tn)
  If ST1 <> "" Then
    t1 = Left(ST1, 1)
    ST1 = Right(ST1, Len(ST1) - 1)
    If t1 <> "0" Then
      s1 = s1 + CCh(Val(t1)) + "角"
    End If
    If ST1 <> "" Then
     t1 = Left(ST1, 1)
     s1 = s1 + CCh(Val(t1)) + "分"
    End If
  End If
  ST1 = Left(tMoney, tn - 1)
Else
  ST1 = tMoney
End If
s2 = ""
If ST1 <> "" Then
  t1 = Right(ST1, 1)
  ST1 = Left(ST1, Len(ST1) - 1)
  s2 = CCh(Val(t1)) + s2
End IfIf ST1 <> "" Then
  t1 = Right(ST1, 1)
  ST1 = Left(ST1, Len(ST1) - 1)
  If t1 <> "0" Then
    s2 = CCh(Val(t1)) + "拾" + s2
  Else
    If Left(s2, 1) <> "零" Then s2 = "零" + s2
  End If
End IfIf ST1 <> "" Then
  t1 = Right(ST1, 1)
  ST1 = Left(ST1, Len(ST1) - 1)
  If t1 <> "0" Then
    s2 = CCh(Val(t1)) + "佰" + s2
  Else
    If Left(s2, 1) <> "零" Then s2 = "零" + s2
  End If
End IfIf ST1 <> "" Then
  t1 = Right(ST1, 1)
  ST1 = Left(ST1, Len(ST1) - 1)
  If t1 <> "0" Then
  s2 = CCh(Val(t1)) + "仟" + s2
  Else
    If Left(s2, 1) <> "零" Then s2 = "零" + s2
  End If
End Ifs3 = ""
If ST1 <> "" Then
  t1 = Right(ST1, 1)
  ST1 = Left(ST1, Len(ST1) - 1)
  s3 = CCh(Val(t1)) + s3
End If
If ST1 <> "" Then
  t1 = Right(ST1, 1)
  ST1 = Left(ST1, Len(ST1) - 1)
  If t1 <> "0" Then
  s3 = CCh(Val(t1)) + "拾" + s3
  Else
    If Left(s3, 1) <> "零" Then s3 = "零" + s3
  End If
End IfIf ST1 <> "" Then
  t1 = Right(ST1, 1)
  ST1 = Left(ST1, Len(ST1) - 1)
  If t1 <> "0" Then
  s3 = CCh(Val(t1)) + "佰" + s3
  Else
   If Left(s3, 1) <> "零" Then s3 = "零" + s3
  End If
End IfIf ST1 <> "" Then
  t1 = Right(ST1, 1)
  ST1 = Left(ST1, Len(ST1) - 1)
  If t1 <> "0" Then
  s3 = CCh(Val(t1)) + "仟" + s3
  End If
End If
If Right(s2, 1) = "零" Then s2 = Left(s2, Len(s2) - 1)
If Len(s3) > 0 Then
  If Right(s3, 1) = "零" Then s3 = Left(s3, Len(s3) - 1)
  s3 = s3 & "万"
End IfChMoney = IIf(s3 & s2 = "", s1, s3 & s2 & "元" & s1)End Function

Answer 4

这个是别人的
本系统在VB6下开发
由于我是在D:\cmis写的程序，请保持你的拷贝在D盘，如果你要修改路径，请打开SALE.INI文件自行修改。相信该例子对您绝对有利。
您必须要安装ACTIVEREPORT报表系统才能正常运行！运行程序后在窗体任一处点击即出现例程。每一条新记录必须在“客户”处输入。而该栏输入的是所谓的“助记词”即该客户的拼音组合，比如“无锡市商业大厦”的助记词为“SYDA”如此类推。
欢迎讨论：[email protected]