看到前面的金额转换，一时兴起也动手写了一个，写的匆忙支持的位数不多，有错误的地方还请多多指教。入口：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
文章来源于领测软件测试网 https://www.ltesting.net/
