将阿拉伯数字转换为汉字数字,支持到百万亿(比如大写金额)

'例子:
Debug.Print UpNumber(-612325646566.46,0,True )
负陆仟壹佰贰拾叁亿贰仟伍佰陆拾肆万陆仟伍佰陆拾陆圆肆角陆分
Debug.Print UpNumber(-125646566.46,1,True )
负一亿二千五百六十四万六千五百六十六元四角六分
Debug.Print UpNumber(-125646566.46,1,flase )
负一亿二千五百六十四万六千五百六十六点四六

Public Function UpNumber(ByVal Number As Double, Optional ByVal Typ As Long, Optional ByVal IsMoney As Boolean) As String
'********************************************************************************
'--------------------------------------------------------------------------------
'将阿拉伯数字转换为大写字符串
'Version 1.0    2002-02-06
'Version 1.1    2002-04-05  修改到支持到千亿
'Version 1.2    2004-08-14  修改为支持 Typ,IsMoney 参数,转换结果可以不是金额,支持到百万亿
'Version 1.21   2004-08-15  修正 Typ=1 时,不能显示负数的疏忽.
'Roadbeg
'--------------------------------------------------------------------------------
'
'--------------------------------------------------------------------------------
'参数说明:
'Number         待转换的数字,可以是小数.
'Typ            转换类型,可选值 0,1
'0              转换为 零,壹,贰 等
'1              转换为 一,二,三 等
'IsMoney        是否是金额,如果是,则转换为多少元,小数后转换为多少角,分,反之则转换为类似于"二点三"这种形式
'--------------------------------------------------------------------------------
'
'--------------------------------------------------------------------------------
'返回值说明:
'如果成功,返回转换后的字符串
'如果失败,返回空字符串
'--------------------------------------------------------------------------------
'
'--------------------------------------------------------------------------------
'注意,由于 Double 类型数值范围的原因,此函数最大只支持到百万亿
'没有对 Typ 的值进行检查,如果 Typ 不为 0,1 之一,将会引发错误.
'另,由于 Double 类型数值范围的原因,超过百万亿,将不能显示小数,同样的超过十万亿只能显示一个小数,以此类推.
'--------------------------------------------------------------------------------
'********************************************************************************

On Error GoTo Doerr

    Dim Result As String                        '返回值
    Dim strNumber As String                     '文本型的 Number
    Dim lngNumberLen As Long                    '文本型的 Number 的 Len
   
    Dim strTmp As String
    Dim strFirst As String, strEnd As String
    Dim lngI As Long, lngJ As Long, lngTmp As Long

    Dim strNum(10) As String                    '大写数字
    Dim strUnit(16) As String                   '单位,比如 十,拾,万等
    Dim strUnitB(2) As String                   '小数后的单位
   
    '初始化
    Select Case Typ
        Case 0
            strNum(0) = "零":   strNum(1) = "壹":   strNum(2) = "贰":   strNum(3) = "叁"
            strNum(4) = "肆":   strNum(5) = "伍":   strNum(6) = "陆":   strNum(7) = "柒"
            strNum(8) = "捌":   strNum(9) = "玖"
           
            If IsMoney Then
                strUnit(0) = "圆"
                strUnitB(0) = "角": strUnitB(1) = "分"
            Else
                strUnit(0) = "点"
            End If
           
            strUnit(1) = "拾":  strUnit(2) = "佰":  strUnit(3) = "仟":  strUnit(4) = "万"
            strUnit(5) = "拾":  strUnit(6) = "佰":  strUnit(7) = "仟":  strUnit(8) = "亿"
            strUnit(9) = "拾":  strUnit(10) = "佰": strUnit(11) = "仟": strUnit(12) = "万"
            strUnit(13) = "拾": strUnit(14) = "佰": strUnit(15) = "仟"
           
        Case 1
            strNum(0) = "零":   strNum(1) = "一":   strNum(2) = "二":   strNum(3) = "三"
            strNum(4) = "四":   strNum(5) = "五":   strNum(6) = "六":   strNum(7) = "七"
            strNum(8) = "八":   strNum(9) = "九"
           
            If IsMoney Then
                strUnit(0) = "元"
                strUnitB(0) = "角": strUnitB(1) = "分"
            Else
                strUnit(0) = "点"
            End If
           
            strUnit(1) = "十":  strUnit(2) = "百":  strUnit(3) = "千":  strUnit(4) = "万"
            strUnit(5) = "十":  strUnit(6) = "百":  strUnit(7) = "千":  strUnit(8) = "亿"
            strUnit(9) = "十":  strUnit(10) = "百": strUnit(11) = "千": strUnit(12) = "万"
            strUnit(13) = "十": strUnit(14) = "百": strUnit(15) = "千"
           
        Case Else
            '参数错误
            GoTo Errexit
    End Select
   
    Result = ""
    If Number = 0 Then
        If IsMoney Then
            Result = strNum(0) & strUnit(0) & "整"
        Else
            Result = strNum(0)
        End If
    Else
        If IsMoney Then
            strNumber = Trim(str(FormatCurrency(Number, 2, vbTrue, vbFalse, vbFalse)))       '保留两位小数
        Else
            strNumber = Trim(str(Number))                                                    '简单的转换为字符串型
        End If
        lngNumberLen = Len(strNumber)
       
        If Left(strNumber, 1) = "-" Then                    '处理负数
            strFirst = "负"
            strNumber = Right(strNumber, lngNumberLen - 1)
            lngNumberLen = lngNumberLen - 1
        Else
            strFirst = ""                                   '通常不需要 =""
        End If
       
        lngI = InStrRev(strNumber, ".")
        If lngI Then
            strTmp = Right(strNumber, lngNumberLen - lngI)
            If IsMoney Then
                strTmp = strTmp & "00"
                strEnd = ""                                 '通常不需要 =""
               
                For lngJ = 1 To 2
                    Result = Result & strNum(CLng(Mid$(strTmp, lngJ, 1))) & strUnitB(lngJ - 1)
                Next
            Else
                strTmp = Right(strNumber, lngNumberLen - lngI)
                For lngJ = 1 To lngNumberLen - lngI
                    Result = Result & strNum(CLng(Mid$(strTmp, lngJ, 1)))
                Next
            End If
           
            strNumber = Left(strNumber, lngI - 1)           '去除小数部分
            lngNumberLen = Len(strNumber)                   '新的字符串长度
        Else
            If IsMoney Then
                strEnd = "整"
            Else
                strEnd = ""
            End If
        End If
       
        '以下为主循环部分
        lngI = 0
        For lngJ = lngNumberLen To 1 Step -1
            lngTmp = CLng(Mid$(strNumber, lngJ, 1))
           
            If lngTmp Then
                Result = strNum(lngTmp) & strUnit(lngI) & Result
            Else
                If lngI = 0 Or lngI = 4 Or lngI = 8 Or lngI = 12 Then           '超过 16 位不支持
                    Result = strNum(lngTmp) & strUnit(lngI) & Result
                Else
                    Result = strNum(lngTmp) & Result
                End If
            End If
           
            lngI = lngI + 1
        Next
       
        Result = Replace(Result, strNum(0) & strNum(0), strNum(0))              '零零", "零
        Result = Replace(Result, strNum(0) & strNum(0), strNum(0))              '零零", "零
       
        '亿零万零圆", "亿圆"
        Result = Replace(Result, strUnit(8) & strNum(0) & strUnit(4) & strNum(0) & strUnit(0), strUnit(8) & strUnit(0))
       
        Result = Replace(Result, strUnit(8) & strNum(0) & strUnit(4), strUnit(8) & strNum(0))       '亿零万, "亿零"
        Result = Replace(Result, strUnit(4) & strNum(0) & strUnit(0), strUnit(4) & strUnit(0))      '亿零万", "亿零
       
        Result = Replace(Result, strNum(0) & strUnit(8), strUnit(8))            '零亿
        Result = Replace(Result, strNum(0) & strUnit(4), strUnit(4))            '零万
        Result = Replace(Result, strNum(0) & strUnit(0), strUnit(0))            '零圆
       
        Result = Replace(Result, strNum(0) & strNum(0), strNum(0))              '零零", "零
        Result = Replace(Result, strNum(0) & strNum(0), strNum(0))              '零零", "零
       
        If IsMoney Then
            Result = strFirst & Result & strEnd
        Else
            Result = strFirst & Result
            If Right(Result, 1) = strUnit(0) Then Result = Left(Result, Len(Result) - 1)            '去除最后一个 "点"
        End If
    End If

Complete:
    GoTo Quit
Doerr:
Errexit:
    Result = ""
Quit:
    UpNumber = Result
End Function