金额大写转换

看到前面的金额转换，一时兴起也动手写了一个，写的匆忙支持的位数不多，有错误的地方还请多多指教。入口：getChangedVal

Option Explicit
´总体思路：
´对数字进行分级处理，级长为4
´对分级后的每级分别处理，处理后得到字符串相连
´如：123456=12|3456
´第二级：12=壹拾贰 + “万”
´第一级：3456 =叁千肆百伍拾陆 + “”

Private Const PrvStrNum = "壹贰叁肆伍陆柒捌玖零"
Private Const PrvStrUnit = "万千百拾个"
Private Const PrvStrGradeUnit = "千万亿兆" ´"兆亿万千"
Private Const PrvGrade = 4

Public Function getChangedVal(ByVal StrVal As String) As String
    Dim StrDotUnit As String
    Dim StrIntUnit As String
   
   
    StrDotUnit = getDotUnit(StrVal) ´取小数位
    StrIntUnit = getIntUnit(StrVal) ´取整数位
   
    StrIntUnit = getIntUpper(StrIntUnit) ´整数位转换大写
    StrDotUnit = getDotUpper(StrIntUnit) ´小数位转换大写
   
    getChangedVal = StrIntUnit & StrDotUnit
End Function

Private Function getDotUnit(ByVal StrVal As String) As String
    ´得到小数点后的数字
    Dim StrRet As String
    Dim IntBegin As Integer
    Dim IntLen As Integer
   
    IntBegin = InStr(1, StrVal, ".") + 1
    IntLen = Len(StrVal) + 1
    StrRet = Mid(StrVal, IntBegin, IntLen - IntBegin)
   
    If IntBegin > 1 Then
        getDotUnit = StrRet
    End If
End Function
Private Function getIntUnit(ByVal StrVal As String) As String
    ´得到整数数字
    Dim StrRet As String
    Dim IntBegin As Integer
    Dim IntLen As Integer
   
    ´取得小数数位的长度
    IntBegin = Len(getDotUnit(StrVal))
    IntLen = Len(StrVal)
   
    StrRet = Mid(StrVal, 1, IntLen - IntBegin) ´总字串长度-小数数位长度=整数数位长度
   
    If Mid(StrRet, Len(StrRet), 1) = "." Then ´去除末位小数点
        StrRet = Mid(StrRet, 1, Len(StrRet) - 1)
    End If
    getIntUnit = StrRet
End Function

Private Function getIntUpper(ByVal StrVal As String) As String
    ´得到转换后的大写（整数部分）
    Dim IntGrade As Integer ´级次
    Dim StrRet As String
    Dim StrTmp As String
   
    ´得到当前级次，
    IntGrade = Fix(Len(StrVal) / PrvGrade)
    ´调整级次长度
    If (Len(StrVal) Mod PrvGrade) <> 0 Then
        IntGrade = IntGrade + 1
    End If
   
    ´MsgBox Mid(PrvStrGradeUnit, IntGrade, 1)
   
    Dim i As Integer
   
    ´对每级数字处理
    For i = IntGrade To 1 Step -1
        StrTmp = getNowGradeVal(StrVal, i) ´取得当前级次数字
        StrRet = StrRet & getSubUnit(StrTmp) ´转换大写
        StrRet = dropZero(StrRet) ´除零
        ´加级次单位
        If i > 1 Then ´末位不加单位
            ´单位不能相连续
            ´??????????????????????????????????
            ´
           
            StrRet = StrRet & Mid(PrvStrGradeUnit, i, 1)
        End If
       
    Next
    getIntUpper = StrRet
End Function

Private Function getDotUpper(ByVal StrVal As String) As String
    ´得到转换后的大写（小数部分）
End Function
Private Function dropZero(ByVal StrVal As String) As String
    ´去除连继的“零”
    Dim StrRet As String
    Dim StrBefore As String ´前一位置字符
    Dim StrNow As String    ´现在位置字符
    Dim i As Integer
   
   
    StrBefore = Mid(StrVal, 1, 1)
    StrRet = StrBefore
   
    For i = 2 To Len(StrVal)
        StrNow = Mid(StrVal, i, 1)
           
        If StrNow = "零" And StrBefore = "零" Then
            ´同时为零
        Else
            StrRet = StrRet & StrNow
        End If
        StrBefore = StrNow
    Next
   
    ´末位去零
    Dim IntLocate As Integer
   
    IntLocate = Len(StrRet)
    ´IntLocate = IIf(IntLocate = 0, 1, IntLocate)
   
    If Mid(StrRet, IntLocate, 1) = "零" Then
        StrRet = Left(StrRet, Len(StrRet) - 1)
    End If
    dropZero = StrRet
End Function
Private Function getSubUnit(ByVal StrVal As String) As String
    ´数值转换
    Debug.Print StrVal
   
    Dim IntLen As Integer
    Dim i As Integer
    Dim StrKey As String
    Dim StrRet As String
    Dim IntKey As Integer
   
    IntLen = Len(StrVal)
   
    For i = 1 To IntLen
        StrKey = Mid(StrVal, i, 1)
        IntKey = Val(StrKey)
       
        If IntKey = 0 Then
            ´“零”作特殊处理
            If i <> IntLen Then ´转换后数末位不能为零
                StrRet = StrRet & "零"
            End If
        Else
            ´If IntKey = 1 And i = 2 Then
                ´“壹拾”作特殊处理
                ´“壹拾”合理
            ´Else
                StrRet = StrRet & Mid(PrvStrNum, Val(StrKey), 1)
            ´End If
            ´追加单位
            If i <> IntLen Then ´个位不加单位
                StrRet = StrRet & Mid(PrvStrUnit, Len(PrvStrUnit) - IntLen + i, 1)
            End If
        End If
    Next
   
   
    getSubUnit = StrRet
End Function
Private Function getNowGradeVal(ByVal StrVal As String, ByVal IntGrade As Integer) As String
    ´得到当前级次的串
    Dim IntGradeLen As Integer
    Dim IntLen As Integer
    Dim StrRet As String
   
    IntGradeLen = IntGrade * PrvGrade
    IntLen = Len(StrVal)
   
   
    If IntLen >= IntGradeLen Then
        StrRet = Mid(StrVal, IntLen - IntGradeLen + 1, PrvGrade)
    Else
        StrRet = Mid(StrVal, 1, IntLen - (IntGrade - 1) * PrvGrade)
    End If
    ´MsgBox StrRet
    getNowGradeVal = StrRet
   
End Function

原文转自：http://www.ltesting.net