类模块：
Private mTenMode, mCaseMode, mZeroMode
Private c0, c1, c2, c3, c4, c5, c6, c7, c8, c9, c00
Private d1, d2, d3, d4, d5, d6
Private Sub ToUCase()
If mZeroMode Then
c0 = "〇"
c00 = "〇〇"
Else
c0 = "零"
c00 = "零零"
End If
c1 = "壹"
c2 = "贰"
c3 = "叁"
c4 = "肆"
c5 = "伍"
c6 = "陆"
c7 = "柒"
c8 = "捌"
c9 = "玖"
d1 = "拾"
d2 = "佰"
d3 = "仟"
d4 = "万"
d5 = "亿"
d6 = "兆"
End Sub
Private Sub ToLCase()
If mZeroMode Then
c0 = "〇"
c00 = "〇〇"
Else
c0 = "零"
c00 = "零零"
End If
c1 = "一"
c2 = "二"
c3 = "三"
c4 = "四"
c5 = "五"
c6 = "六"
c7 = "七"
c8 = "八"
c9 = "九"
d1 = "十"
d2 = "百"
d3 = "千"
d4 = "万"
d5 = "亿"
d6 = "兆"
End Sub
Public Function NumberToWord(number)
'-------------------------------------------------------------------
'目的:转换一串阿拉伯数字为中文数字
'参数:一串阿拉伯数字
'返回值:转换后的一串中文数字
'---------------------------------------------------------------------------------------------------------------------------------
'注: 此一 Function 必须包含以下三个 Function
'1.mapword:转换单一数字为国数字(0123456789->零壹贰参肆伍陆柒捌玖)
'2.StringCleaner:清除字串中不要的字元
'3.convtoword:将传入的四个数字转成中文数字字串(1234->壹仟贰佰参拾肆)
'---------------------------------------------------------------------------------------------------------------------------------
Dim wlength '数字字串总长度
wlength = CInt("0")
Dim wsection '归属的段落 (0:万以下/1:万/2:亿/3:兆)
wsection = CInt("0")
Dim wcount '剩余的数字字串长度
wcount = CInt("0")
Dim wstr '暂存字串
Dim wstr1 '暂存字串-兆
Dim wstr2 '暂存字串-亿
Dim wstr3 '暂存字串-万
Dim wstr4 '暂存字串-万以下
'未输入或0不做
'-----------------------------------------------
If Trim(number) = "" Or Trim(number) = "0" Then
NumberToWord = c0
Exit Function
End If
'-----------------------------------------------
wlength = Len(number)
wsection = wlength \ 4
wcount = wlength Mod 4
'-----------------------------------------------
'每四位一组, 分段 (兆/亿/万/万以下)
If wcount = 0 Then
wcount = 4
wsection = wsection - 1
End If
'----------------------------------------------
'大于兆的四位数转换
If wsection = 3 Then
'抓出大于兆的四位数
wstr = Left(FormatNumber(number, "0000000000000000"), 4)
'转换
wstr1 = convtoword(wstr)
If wstr1 <> c0 Then wstr1 = wstr1 & d6
End If
'----------------------------------------------
'大于亿的四位数转换
If wsection >= 2 Then
'抓出大于亿的四位数
If Len(number) > 12 Then
wstr = Left(Right(number, 12), 4)
Else
wstr = Left(FormatNumber(number, "000000000000"), 4)
End If
'转换
wstr2 = convtoword(wstr)
If wstr2 <> c0 Then wstr2 = wstr2 & d5
End If
'----------------------------------------------
'大于万的四位数转换
If wsection >= 1 Then
'抓出大于万的四位数
If Len(number) > 8 Then
wstr = Left(Right(number, 8), 4)
Else
wstr = Left(FormatNumber(number, "00000000"), 4)
End If
'转换
wstr3 = convtoword(wstr)
If wstr3 <> c0 Then wstr3 = wstr3 & d4
End If
'----------------------------------------------
'万以下的四位数转换
'抓出万以下的四位数
If Len(number) > 4 Then
wstr = Right(number, 4)
Else
wstr = FormatNumber(number, "0000")
End If
'转换
wstr4 = convtoword(wstr)
'----------------------------------------------
'组合最多四组字串(兆/亿/万/万以下)
NumberToWord = wstr1 & wstr2 & wstr3 & wstr4
'去除重复的零 ('零零'-->'零')
Do While InStr(1, NumberToWord, c00)
NumberToWord = StringCleaner(NumberToWord, c00)
Loop
'----------------------------------------------
'去除最左边的零
If Left(NumberToWord, 1) = c0 Then
NumberToWord = Mid(NumberToWord, 2)
End If
'----------------------------------------------
'去除最右边的零
If Right(NumberToWord, 1) = c0 Then
NumberToWord = Mid(NumberToWord, 1, Len(NumberToWord) - 1)
End If
End Function
Private Function mapword(no)
'-----------------------------------------------------------
'目的:转换单一数字为国数字(0123456789->零壹贰参肆伍陆柒捌玖)
'参数:数字(0123456789)
'返回值:国数字(零壹贰参肆伍陆柒捌玖)
'-----------------------------------------------------------
Select Case no
Case "0"
mapword = c0
Case "1"
mapword = c1
Case "2"
mapword = c2
Case "3"
mapword = c3
Case "4"
mapword = c4
Case "5"
mapword = c5
Case "6"
mapword = c6
Case "7"
mapword = c7
Case "8"
mapword = c8
Case "9"
mapword = c9
End Select
End Function
Private Function StringCleaner(ByVal s, ByVal Search)
'-----------------------------------------------------------
'目的:清除字串中不要的字元
'参数:1.完整字串. 2.要清除的字元(可含多字元)
'返回值:清除后的字串
'''此段之主要目的在去除重复的 '零' ('零零'-->'零')
'-----------------------------------------------------------
Dim i, res
res = s
Do While InStr(res, Search)
i = InStr(res, Search)
res = Left(res, i - 1) & Mid(res, i + 1)
Loop
StringCleaner = res
End Function
Private Function convtoword(ByVal wstr)
'-----------------------------------------------------------
'目的:将传入的四个数字转成中文数字字串(1234->壹仟贰佰参拾肆)
'参数:4位数的数字 (前面空白补0)
'返回值:转换后的中文数字字串
'-----------------------------------------------------------
Dim tempword
'仟位数
tempword = mapword(Mid(wstr, 1, 1))
If tempword <> c0 Then tempword = tempword & d3
convtoword = convtoword & tempword
'佰位数
tempword = mapword(Mid(wstr, 2, 1))
If tempword <> c0 Then tempword = tempword & d2
convtoword = convtoword & tempword
'拾位数
tempword = mapword(Mid(wstr, 3, 1))
If tempword <> c0 And tempword <> c1 Then tempword = tempword & d1
If mTenMode Then
If convtoword = c00 And tempword = c1 Then tempword = tempword & d1
Else
If convtoword = c00 And tempword = c1 Then tempword = d1
End If
If convtoword <> c00 And tempword = c1 Then tempword = tempword & d1
convtoword = convtoword & tempword
'个位数
tempword = mapword(Mid(wstr, 4, 1))
convtoword = convtoword & tempword
'去除最右边的零
Do While Right(convtoword, 1) = c0 And Len(convtoword) > 1
convtoword = Mid(convtoword, 1, Len(convtoword) - 1)
Loop
End Function
Public Property Get TenMode()
TenMode = mTenMode
End Property
Public Property Let TenMode(ByVal vNewValue)
mTenMode = vNewValue
End Property
Public Property Get CaseMode()
CaseMode = mCaseMode
End Property
Public Property Let CaseMode(ByVal vNewValue)
mCaseMode = vNewValue
If mCaseMode Then
ToUCase
Else
ToLCase
End If
End Property
Public Property Get ZeroMode()
ZeroMode = mZeroMode
End Property
Public Property Let ZeroMode(ByVal vNewValue)
mZeroMode = vNewValue
If mCaseMode Then
ToUCase
Else
ToLCase
End If
End Property
Private Sub Class_Initialize()
mTenMode = False
mCaseMode = False
mZeroMode = False
ToLCase
End Sub
Private Function FormatNumber(num, fa)
Dim lm, lf
lf = Len(fa)
lm = Len(num)
If lm < lf Then
FormatNumber = String(lf - lm, "0") & Trim(CStr(num))
Else
FormatNumber = Trim(CStr(num))
End If
End Function
模块：
Function Num2Chs(num, ten, cas, zero)
Dim c As cNumToChs
Set c = New cNumToChs
c.TenMode = ten
c.CaseMode = cas
c.ZeroMode = zero
Num2Chs = c.NumberToWord(num)
Set c = Nothing
End Function
'主要调用函数，将输入的货币格式的数值转化为中文大写
Public Function CChinese(Pr As Double) As String
Dim sp, sp0 As String, sp1 As String, u As Integer
Dim jiao As Integer, feng As Integer
Dim r As String
Dim chap(10) As String
chap(0) = "零"
chap(1) = "壹"
chap(2) = "贰"
chap(3) = "叁"
chap(4) = "肆"
chap(5) = "伍"
chap(6) = "陆"
chap(7) = "柒"
chap(8) = "捌"
chap(9) = "玖"
sp = Split(CStr(Pr), ".", 2)
If IsArray(sp) Then
u = UBound(sp)
If u = 0 Then
sp0 = sp(0)
r = Num2Chs(sp0, 1, 1, 0)
r = r & "元整"
Else
sp0 = sp(0)
sp1 = Left(sp(1), 2)
r = Num2Chs(sp0, 1, 1, 0)
If Len(sp1) = 2 Then
jiao = Val(Left(sp1, 1))
feng = Val(Right(sp1, 1))
If jiao = 0 Then
r = r & "元零"
Else
r = r & "元" & chap(jiao) & "角"
End If
r = r & chap(feng) & "分"
Else
jiao = Val(Left(sp1, 1))
feng = 0
If jiao = 0 Then
r = r & "元整"
Else
r = r & "元" & chap(jiao) & "角"
End If
End If
End If
Else
sp0 = CStr(Pr)
r = Num2Chs(sp0, 1, 1, 0)
r = r & "元整"
End If
CChinese = r
End Function
'外部调用函数，将输入的日期（年或月或日）转化为中文大写
Public Function BigCovert(sData$, Optional IsLink As Boolean) As String
Dim i%, r$, s$
If IsLink Then
For i = 1 To Len(sData)
If Mid(sData, 1, 1) = 0 Then
r = "零" & r & BigWord(Mid(sData, 2, 1))
Exit For
End If
If Len(r) = 1 Then r = r & "拾"
s = Mid(sData, i, 1)
If s <> "0" Then
r = r & BigWord(s)
End If
Next
Else
For i = 1 To Len(sData)
r = r & BigWord(Mid(sData, i, 1))
Next
End If
BigCovert = r
End Function
Private Function BigWord(s$) As String
Dim r$
Select Case s
Case "0"
r = "零"
Case "1"
r = "壹"
Case "2"
r = "贰"
Case "3"
r = "叁"
Case "4"
r = "肆"
Case "5"
r = "伍"
Case "6"
r = "陆"
Case "7"
r = "柒"
Case "8"
r = "捌"
Case "9"
r = "玖"
End Select
BigWord = r
End Function