7,762
社区成员
发帖
与我相关
我的任务
分享项目时间紧迫，求一现成的函数：票据打印时要根据金额打印出大写金额的函数
相信做过票据打印的xdjm们都用过的，只是时间紧迫，来不及做了，如果哪位大哥大姐手头上有现成的，能够共享一下:
e_mail:happygirlyan@hotmail.com
e_mail:happygirlyan@hotmail.com
...全文
请发表友善的回复…
发表回复
986753421 2004-01-07
- 打赏
- 举报
这是个不错的而且实用的练习。
年糕 2004-01-06
- 打赏
- 举报
Create Procedure AtoC
@ChangeMoney Money
as
Set Nocount ON
Declare @String1 char(20)
Declare @String2 char(30)
Declare @String4 Varchar(100)
Declare @String3 Varchar(100) --从原A值中取出的值
Declare @i int --循环变量
Declare @J Int --A的值乘以100的字符串长度
Declare @Ch1 Varchar(100) --数字的汉语读法
Declare @Ch2 Varchar(100) --数字位的汉字读法
Declare @Zero Int --用来计算连续有几个零
Declare @ReturnValue VarChar(100)
Select @ReturnValue = ''
Select @String1 = '零壹贰叁肆伍陆柒捌玖'
Select @String2 = '万仟佰拾亿仟佰拾万仟佰拾元角分'
Select @String4 = Cast(@ChangeMoney*100 as int)
select @J=len(cast((@ChangeMoney*100) as int))
Select @String2=Right(@String2,@J)
Select @i = 1
while @i<= @j Begin
Select @String3 = Substring(@String4,@i,1)
if @String3<>'0' Begin
Select @Ch1 = Substring(@String1, Cast(@String3 as Int) + 1, 1)
Select @Ch2 = Substring(@String2, @i, 1)
Select @Zero = 0 --表示本位不为零
end
else Begin
If (@Zero = 0) Or (@i = @J - 9) Or (@i = @J - 5) Or (@i = @J - 1)
Select @Ch1 = '零'
Else
Select @Ch1 = ''
Select @Zero = @Zero + 1 --表示本位为0
--如果转换的数值需要扩大，那么需改动以下表达式 I 的值。
Select Ch2 = ''
If @i = @J - 10 Begin
Select @Ch2 = '亿'
Select @Zero = 0
end
If @i = @J - 6 Begin
Select @Ch2 = '万'
Select @Zero = 0
end
if @i = @J - 2 Begin
Select @Ch2 = '元'
Select @Zero = 0
end
If @i = @J
Select @Ch2 = '整'
end
Select @ReturnValue = @ReturnValue + @Ch1 + @Ch2
select @i = @i+1
end
--最后将多余的零去掉
If CharIndex('仟仟',@ReturnValue) <> 0
Select @ReturnValue = Replace(@ReturnValue, '仟仟', '仟')
If CharIndex('佰佰',@ReturnValue) <> 0
Select @ReturnValue = Replace(@ReturnValue, '佰佰', '佰')
If CharIndex('零元',@ReturnValue) <> 0
Select @ReturnValue = Replace(@ReturnValue, '零元', '元')
If CharIndex('零万',@ReturnValue) <> 0
Select @ReturnValue = Replace(@ReturnValue, '零万', '万')
If CharIndex('零亿',@ReturnValue) <> 0
Select @ReturnValue = Replace(@ReturnValue, '零亿', '亿')
If CharIndex('零整',@ReturnValue) <> 0
Select @ReturnValue = Replace(@ReturnValue, '零整', '整')
If CharIndex('零佰',@ReturnValue) <> 0
Select @ReturnValue = Replace(@ReturnValue, '零佰', '零')
If CharIndex('零仟',@ReturnValue) <> 0
Select @ReturnValue = Replace(@ReturnValue, '零仟', '零')
If CharIndex('元元',@ReturnValue) <> 0
Select @ReturnValue = Replace(@ReturnValue, '元元', '元')
Select @ReturnValue
GO
@ChangeMoney Money
as
Set Nocount ON
Declare @String1 char(20)
Declare @String2 char(30)
Declare @String4 Varchar(100)
Declare @String3 Varchar(100) --从原A值中取出的值
Declare @i int --循环变量
Declare @J Int --A的值乘以100的字符串长度
Declare @Ch1 Varchar(100) --数字的汉语读法
Declare @Ch2 Varchar(100) --数字位的汉字读法
Declare @Zero Int --用来计算连续有几个零
Declare @ReturnValue VarChar(100)
Select @ReturnValue = ''
Select @String1 = '零壹贰叁肆伍陆柒捌玖'
Select @String2 = '万仟佰拾亿仟佰拾万仟佰拾元角分'
Select @String4 = Cast(@ChangeMoney*100 as int)
select @J=len(cast((@ChangeMoney*100) as int))
Select @String2=Right(@String2,@J)
Select @i = 1
while @i<= @j Begin
Select @String3 = Substring(@String4,@i,1)
if @String3<>'0' Begin
Select @Ch1 = Substring(@String1, Cast(@String3 as Int) + 1, 1)
Select @Ch2 = Substring(@String2, @i, 1)
Select @Zero = 0 --表示本位不为零
end
else Begin
If (@Zero = 0) Or (@i = @J - 9) Or (@i = @J - 5) Or (@i = @J - 1)
Select @Ch1 = '零'
Else
Select @Ch1 = ''
Select @Zero = @Zero + 1 --表示本位为0
--如果转换的数值需要扩大，那么需改动以下表达式 I 的值。
Select Ch2 = ''
If @i = @J - 10 Begin
Select @Ch2 = '亿'
Select @Zero = 0
end
If @i = @J - 6 Begin
Select @Ch2 = '万'
Select @Zero = 0
end
if @i = @J - 2 Begin
Select @Ch2 = '元'
Select @Zero = 0
end
If @i = @J
Select @Ch2 = '整'
end
Select @ReturnValue = @ReturnValue + @Ch1 + @Ch2
select @i = @i+1
end
--最后将多余的零去掉
If CharIndex('仟仟',@ReturnValue) <> 0
Select @ReturnValue = Replace(@ReturnValue, '仟仟', '仟')
If CharIndex('佰佰',@ReturnValue) <> 0
Select @ReturnValue = Replace(@ReturnValue, '佰佰', '佰')
If CharIndex('零元',@ReturnValue) <> 0
Select @ReturnValue = Replace(@ReturnValue, '零元', '元')
If CharIndex('零万',@ReturnValue) <> 0
Select @ReturnValue = Replace(@ReturnValue, '零万', '万')
If CharIndex('零亿',@ReturnValue) <> 0
Select @ReturnValue = Replace(@ReturnValue, '零亿', '亿')
If CharIndex('零整',@ReturnValue) <> 0
Select @ReturnValue = Replace(@ReturnValue, '零整', '整')
If CharIndex('零佰',@ReturnValue) <> 0
Select @ReturnValue = Replace(@ReturnValue, '零佰', '零')
If CharIndex('零仟',@ReturnValue) <> 0
Select @ReturnValue = Replace(@ReturnValue, '零仟', '零')
If CharIndex('元元',@ReturnValue) <> 0
Select @ReturnValue = Replace(@ReturnValue, '元元', '元')
Select @ReturnValue
GO
SoHo_Andy 2004-01-06
- 打赏
- 举报
Function Fun_换算中国数目字(数值 As String) As String
Dim TempIt(1 To 28), Temp As String
Dim TempLen, i, TempItNow As Integer
Dim IntNum As String
Dim Nums As String
Dim Zero As Boolean
TempIt(1) = ""
TempIt(2) = "拾"
TempIt(3) = "佰"
TempIt(4) = "仟"
TempIt(5) = "" '万 万
TempIt(6) = "拾" '十万
TempIt(7) = "佰" '百万
TempIt(8) = "仟" '千万
TempIt(9) = "" '亿 亿
TempIt(10) = "拾" '十亿
TempIt(11) = "佰" '百亿
TempIt(12) = "仟" '千亿
TempIt(13) = "" '万亿 万
TempIt(14) = "拾" '十万亿
TempIt(15) = "佰" '百万亿
TempIt(16) = "仟" '千万亿
TempIt(17) = "" '兆 兆
TempIt(18) = "拾" '十兆
TempIt(19) = "佰" '百兆
TempIt(20) = "仟" '千兆
TempIt(21) = "" '万兆 万
TempIt(22) = "拾" '十万兆
TempIt(23) = "佰" '百万兆
TempIt(24) = "仟" '千万兆
TempIt(25) = "" '亿万兆 亿
TempIt(26) = "拾" '十亿万兆
TempIt(27) = "佰" '百亿万兆
TempIt(28) = "仟" '千万亿兆
Nums = "壹贰叁肆伍陆柒捌玖"
IntNum = 数值 '取值
TempLen = Len(IntNum)
Fun_换算中国数目字 = ""
Zero = False
For i = 1 To TempLen
TempItNow = Val(Mid(IntNum, i, 1))
Temp = TempIt(TempLen - i + 1)
If TempItNow <> 0 Then
If Zero = True Then
Fun_换算中国数目字 = Fun_换算中国数目字 + "零"
Zero = False
End If
If i = 1 And TempItNow = 1 And Temp = "拾" Then
Fun_换算中国数目字 = Fun_换算中国数目字 + "拾"
Else
Fun_换算中国数目字 = Fun_换算中国数目字 + Mid(Nums, TempItNow, 1) + Temp
End If
Else
If Zero = False Then
Zero = True
End If
End If
Select Case TempLen - i + 1
Case 5
Fun_换算中国数目字 = Fun_换算中国数目字 + "万"
Case 9
Fun_换算中国数目字 = Fun_换算中国数目字 + "亿"
Case 13
Fun_换算中国数目字 = Fun_换算中国数目字 + "万"
Case 17
Fun_换算中国数目字 = Fun_换算中国数目字 + "兆"
Case 21
Fun_换算中国数目字 = Fun_换算中国数目字 + "万"
Case 25
Fun_换算中国数目字 = Fun_换算中国数目字 + "亿"
End Select
Next
End Function
Dim TempIt(1 To 28), Temp As String
Dim TempLen, i, TempItNow As Integer
Dim IntNum As String
Dim Nums As String
Dim Zero As Boolean
TempIt(1) = ""
TempIt(2) = "拾"
TempIt(3) = "佰"
TempIt(4) = "仟"
TempIt(5) = "" '万 万
TempIt(6) = "拾" '十万
TempIt(7) = "佰" '百万
TempIt(8) = "仟" '千万
TempIt(9) = "" '亿 亿
TempIt(10) = "拾" '十亿
TempIt(11) = "佰" '百亿
TempIt(12) = "仟" '千亿
TempIt(13) = "" '万亿 万
TempIt(14) = "拾" '十万亿
TempIt(15) = "佰" '百万亿
TempIt(16) = "仟" '千万亿
TempIt(17) = "" '兆 兆
TempIt(18) = "拾" '十兆
TempIt(19) = "佰" '百兆
TempIt(20) = "仟" '千兆
TempIt(21) = "" '万兆 万
TempIt(22) = "拾" '十万兆
TempIt(23) = "佰" '百万兆
TempIt(24) = "仟" '千万兆
TempIt(25) = "" '亿万兆 亿
TempIt(26) = "拾" '十亿万兆
TempIt(27) = "佰" '百亿万兆
TempIt(28) = "仟" '千万亿兆
Nums = "壹贰叁肆伍陆柒捌玖"
IntNum = 数值 '取值
TempLen = Len(IntNum)
Fun_换算中国数目字 = ""
Zero = False
For i = 1 To TempLen
TempItNow = Val(Mid(IntNum, i, 1))
Temp = TempIt(TempLen - i + 1)
If TempItNow <> 0 Then
If Zero = True Then
Fun_换算中国数目字 = Fun_换算中国数目字 + "零"
Zero = False
End If
If i = 1 And TempItNow = 1 And Temp = "拾" Then
Fun_换算中国数目字 = Fun_换算中国数目字 + "拾"
Else
Fun_换算中国数目字 = Fun_换算中国数目字 + Mid(Nums, TempItNow, 1) + Temp
End If
Else
If Zero = False Then
Zero = True
End If
End If
Select Case TempLen - i + 1
Case 5
Fun_换算中国数目字 = Fun_换算中国数目字 + "万"
Case 9
Fun_换算中国数目字 = Fun_换算中国数目字 + "亿"
Case 13
Fun_换算中国数目字 = Fun_换算中国数目字 + "万"
Case 17
Fun_换算中国数目字 = Fun_换算中国数目字 + "兆"
Case 21
Fun_换算中国数目字 = Fun_换算中国数目字 + "万"
Case 25
Fun_换算中国数目字 = Fun_换算中国数目字 + "亿"
End Select
Next
End Function
busisoft 2004-01-06
- 打赏
- 举报
这样的例子太多了
chenyu5188 2004-01-06
- 打赏
- 举报
楼上的各位都给出了，再给也是一样。UP吧
986753421 2004-01-06
- 打赏
- 举报
呵呵，上面的程序说明补充一下，再发一遍：
Private Function prvCnvSpell(ByVal ycRes As String) As String
'定义转换用常量，其中@为个位占位符，结果输出时统一去除
Const cnsAdvPos As String = "@万亿"
Const cnsPostion As String = "@拾佰仟"
Const cnsNumber As String = "零壹贰叁肆伍陆柒捌玖"
Dim ycAdvPos As Integer '定义每四位为一级，当前数所在级，用于转换“万、亿”
Dim ycPostion As Integer '在级中，当前数所处的位置，用于转换“拾、佰、仟”
Dim ycVaildCount As Integer '在级中，记录有效数字个数
Dim yck As Integer '循环变量，用于扫描字符串
Dim ycTmpNum As String '保存当前字符
Dim ycVaildZero As Long '这个变量的用法不好描述，下面用到时再讲
Dim ycResult As String '保存转换后的结果
ycRes = StrReverse(Trim(ycRes)) '获取逆序字符串，方便后面的处理
For yck = 0 To Len(ycRes) - 1 '扫描数字串
ycAdvPos = yck \ 4 '获取当前数字所在级
ycPostion = yck Mod 4 '获取当前数字所在位
If ycPostion = 0 Then '当所在位为“个”位时
ycVaildCount = 0 '有效数字清零
End If
ycTmpNum = Mid(ycRes, yck + 1, 1) '获取当前数字
If Val(ycTmpNum) > 0 Then '当前数字不为0
If ycPostion = 0 Then '如果为“个”位
'结果=结果& 级 & 位 & 当前数字；其中位为“@”，在结果输出中再统一去掉
ycResult = ycResult & Mid(cnsAdvPos, ycAdvPos + 1, 1) & Mid(cnsPostion, ycPostion + 1, 1) & Mid(cnsNumber, Val(ycTmpNum) + 1, 1)
ElseIf ycPostion = 1 And Val(ycTmpNum) = 1 Then '当位为“十”位，且当前数字为“1”,该段程序主要处理“10：拾,100000：拾万”这样的数字
ycVaildZero = Val(StrReverse(Right(ycRes, Len(ycRes) - (yck + 1)))) '判断其余位是否有大于0的数
If ycVaildZero > 0 Then '有
'照常处理
ycResult = ycResult & Mid(cnsPostion, ycPostion + 1, 1) & Mid(cnsNumber, Val(ycTmpNum) + 1, 1)
Else '无
'显示类似:10：拾,100000：拾万；这样的数字
ycResult = ycResult & Mid(cnsPostion, ycPostion + 1, 1)
End If
Else
'其余的数字也按下面格式处理：
'结果=结果& 级 & 位 & 当前数字；
ycResult = ycResult & Mid(cnsPostion, ycPostion + 1, 1) & Mid(cnsNumber, Val(ycTmpNum) + 1, 1)
End If
ycVaildCount = ycVaildCount + 1
Else '当前数字为0
'主要避免“10000显示成壹”，产生这个结果的原因由后段程序引起
If ycPostion = 0 Then
ycVaildZero = Val(StrReverse(Mid(ycRes, yck + 1, 4)))
If ycVaildZero > 0 Then
ycResult = ycResult & Mid(cnsAdvPos, ycAdvPos + 1, 1)
End If
End If
'主要避免“1001:壹仟零拾零壹”的现象
If ycVaildCount > 0 Then
ycVaildCount = 0
ycResult = ycResult & Mid(cnsNumber, Val(ycTmpNum) + 1, 1)
End If
End If
Next yck
prvCnvSpell = StrReverse(Trim(Replace(ycResult, "@", "")))
End Function
Private Function prvCnvSpell(ByVal ycRes As String) As String
'定义转换用常量，其中@为个位占位符，结果输出时统一去除
Const cnsAdvPos As String = "@万亿"
Const cnsPostion As String = "@拾佰仟"
Const cnsNumber As String = "零壹贰叁肆伍陆柒捌玖"
Dim ycAdvPos As Integer '定义每四位为一级，当前数所在级，用于转换“万、亿”
Dim ycPostion As Integer '在级中，当前数所处的位置，用于转换“拾、佰、仟”
Dim ycVaildCount As Integer '在级中，记录有效数字个数
Dim yck As Integer '循环变量，用于扫描字符串
Dim ycTmpNum As String '保存当前字符
Dim ycVaildZero As Long '这个变量的用法不好描述，下面用到时再讲
Dim ycResult As String '保存转换后的结果
ycRes = StrReverse(Trim(ycRes)) '获取逆序字符串，方便后面的处理
For yck = 0 To Len(ycRes) - 1 '扫描数字串
ycAdvPos = yck \ 4 '获取当前数字所在级
ycPostion = yck Mod 4 '获取当前数字所在位
If ycPostion = 0 Then '当所在位为“个”位时
ycVaildCount = 0 '有效数字清零
End If
ycTmpNum = Mid(ycRes, yck + 1, 1) '获取当前数字
If Val(ycTmpNum) > 0 Then '当前数字不为0
If ycPostion = 0 Then '如果为“个”位
'结果=结果& 级 & 位 & 当前数字；其中位为“@”，在结果输出中再统一去掉
ycResult = ycResult & Mid(cnsAdvPos, ycAdvPos + 1, 1) & Mid(cnsPostion, ycPostion + 1, 1) & Mid(cnsNumber, Val(ycTmpNum) + 1, 1)
ElseIf ycPostion = 1 And Val(ycTmpNum) = 1 Then '当位为“十”位，且当前数字为“1”,该段程序主要处理“10：拾,100000：拾万”这样的数字
ycVaildZero = Val(StrReverse(Right(ycRes, Len(ycRes) - (yck + 1)))) '判断其余位是否有大于0的数
If ycVaildZero > 0 Then '有
'照常处理
ycResult = ycResult & Mid(cnsPostion, ycPostion + 1, 1) & Mid(cnsNumber, Val(ycTmpNum) + 1, 1)
Else '无
'显示类似:10：拾,100000：拾万；这样的数字
ycResult = ycResult & Mid(cnsPostion, ycPostion + 1, 1)
End If
Else
'其余的数字也按下面格式处理：
'结果=结果& 级 & 位 & 当前数字；
ycResult = ycResult & Mid(cnsPostion, ycPostion + 1, 1) & Mid(cnsNumber, Val(ycTmpNum) + 1, 1)
End If
ycVaildCount = ycVaildCount + 1
Else '当前数字为0
'主要避免“10000显示成壹”，产生这个结果的原因由后段程序引起
If ycPostion = 0 Then
ycVaildZero = Val(StrReverse(Mid(ycRes, yck + 1, 4)))
If ycVaildZero > 0 Then
ycResult = ycResult & Mid(cnsAdvPos, ycAdvPos + 1, 1)
End If
End If
'主要避免“1001:壹仟零拾零壹”的现象
If ycVaildCount > 0 Then
ycVaildCount = 0
ycResult = ycResult & Mid(cnsNumber, Val(ycTmpNum) + 1, 1)
End If
End If
Next yck
prvCnvSpell = StrReverse(Trim(Replace(ycResult, "@", "")))
End Function
986753421 2004-01-06
- 打赏
- 举报
整数部分如下，小数部分类似自己动手吧；
Private Function prvCnvSpell(ByVal ycRes As String) As String
Const cnsAdvPos As String = "@万亿"
Const cnsPostion As String = "@拾佰仟"
Const cnsNumber As String = "零壹贰叁肆伍陆柒捌玖"
Dim ycAdvPos As Integer
Dim ycPostion As Integer
Dim ycVaildCount As Integer
Dim yck As Integer
Dim ycTmpNum As String
Dim ycVaildZero As Long
Dim ycResult As String
ycRes = StrReverse(Trim(ycRes))
For yck = 0 To Len(ycRes) - 1
ycAdvPos = yck \ 4
ycPostion = yck Mod 4
If ycPostion = 0 Then
ycVaildCount = 0
End If
ycTmpNum = Mid(ycRes, yck + 1, 1)
If Val(ycTmpNum) > 0 Then
If ycPostion = 0 Then
ycResult = ycResult & Mid(cnsAdvPos, ycAdvPos + 1, 1) & Mid(cnsPostion, ycPostion + 1, 1) & Mid(cnsNumber, Val(ycTmpNum) + 1, 1)
ElseIf ycPostion = 1 And Val(ycTmpNum) = 1 Then
ycVaildZero = Val(StrReverse(Right(ycRes, Len(ycRes) - (yck + 1))))
If ycVaildZero > 0 Then
ycResult = ycResult & Mid(cnsPostion, ycPostion + 1, 1) & Mid(cnsNumber, Val(ycTmpNum) + 1, 1)
Else
ycResult = ycResult & Mid(cnsPostion, ycPostion + 1, 1)
End If
Else
ycResult = ycResult & Mid(cnsPostion, ycPostion + 1, 1) & Mid(cnsNumber, Val(ycTmpNum) + 1, 1)
End If
ycVaildCount = ycVaildCount + 1
Else
If ycPostion = 0 Then
ycVaildZero = Val(StrReverse(Mid(ycRes, yck + 1, 4)))
If ycVaildZero > 0 Then
ycResult = ycResult & Mid(cnsAdvPos, ycAdvPos + 1, 1)
End If
End If
If ycVaildCount > 0 Then
ycVaildCount = 0
ycResult = ycResult & Mid(cnsNumber, Val(ycTmpNum) + 1, 1)
End If
End If
Next yck
prvCnvSpell = StrReverse(Trim(Replace(ycResult, "@", "")))
End Function
Private Function prvCnvSpell(ByVal ycRes As String) As String
Const cnsAdvPos As String = "@万亿"
Const cnsPostion As String = "@拾佰仟"
Const cnsNumber As String = "零壹贰叁肆伍陆柒捌玖"
Dim ycAdvPos As Integer
Dim ycPostion As Integer
Dim ycVaildCount As Integer
Dim yck As Integer
Dim ycTmpNum As String
Dim ycVaildZero As Long
Dim ycResult As String
ycRes = StrReverse(Trim(ycRes))
For yck = 0 To Len(ycRes) - 1
ycAdvPos = yck \ 4
ycPostion = yck Mod 4
If ycPostion = 0 Then
ycVaildCount = 0
End If
ycTmpNum = Mid(ycRes, yck + 1, 1)
If Val(ycTmpNum) > 0 Then
If ycPostion = 0 Then
ycResult = ycResult & Mid(cnsAdvPos, ycAdvPos + 1, 1) & Mid(cnsPostion, ycPostion + 1, 1) & Mid(cnsNumber, Val(ycTmpNum) + 1, 1)
ElseIf ycPostion = 1 And Val(ycTmpNum) = 1 Then
ycVaildZero = Val(StrReverse(Right(ycRes, Len(ycRes) - (yck + 1))))
If ycVaildZero > 0 Then
ycResult = ycResult & Mid(cnsPostion, ycPostion + 1, 1) & Mid(cnsNumber, Val(ycTmpNum) + 1, 1)
Else
ycResult = ycResult & Mid(cnsPostion, ycPostion + 1, 1)
End If
Else
ycResult = ycResult & Mid(cnsPostion, ycPostion + 1, 1) & Mid(cnsNumber, Val(ycTmpNum) + 1, 1)
End If
ycVaildCount = ycVaildCount + 1
Else
If ycPostion = 0 Then
ycVaildZero = Val(StrReverse(Mid(ycRes, yck + 1, 4)))
If ycVaildZero > 0 Then
ycResult = ycResult & Mid(cnsAdvPos, ycAdvPos + 1, 1)
End If
End If
If ycVaildCount > 0 Then
ycVaildCount = 0
ycResult = ycResult & Mid(cnsNumber, Val(ycTmpNum) + 1, 1)
End If
End If
Next yck
prvCnvSpell = StrReverse(Trim(Replace(ycResult, "@", "")))
End Function
online 2004-01-06
- 打赏
- 举报
Private Sub Command1_Click()
Label1.Caption = rmb(Text1.Text)
End Sub
Public Function rmb(s As Currency) As String
s1$ = LTrim(Str$(Abs(s)))
L% = Len(s1)
Select Case L - InStrRev(s1, ".")
'双引号内是小数点
Case L
s2$ = s1 + ".00"
Case 1
s2$ = s1 + "0"
Case 2
s2$ = s1
End Select
L = Len(s2)
DX$ = ""
C1$ = "零壹贰叁肆伍陆柒捌玖"
C2$ = "分角 元拾佰仟万拾佰仟亿拾佰"
'角和元之间留一个空格
Do While L >= 1
x$ = Mid(s2, Len(s2) - L + 1, 1)
DX = DX + IIf(x <> ".", Mid(C1, Val(x) + 1, 1) + Trim(Mid(C2, (L - 1) + 1, 1)), "")
L = L - 1
Loop
rmb = DX + "整"
End Function
Label1.Caption = rmb(Text1.Text)
End Sub
Public Function rmb(s As Currency) As String
s1$ = LTrim(Str$(Abs(s)))
L% = Len(s1)
Select Case L - InStrRev(s1, ".")
'双引号内是小数点
Case L
s2$ = s1 + ".00"
Case 1
s2$ = s1 + "0"
Case 2
s2$ = s1
End Select
L = Len(s2)
DX$ = ""
C1$ = "零壹贰叁肆伍陆柒捌玖"
C2$ = "分角 元拾佰仟万拾佰仟亿拾佰"
'角和元之间留一个空格
Do While L >= 1
x$ = Mid(s2, Len(s2) - L + 1, 1)
DX = DX + IIf(x <> ".", Mid(C1, Val(x) + 1, 1) + Trim(Mid(C2, (L - 1) + 1, 1)), "")
L = L - 1
Loop
rmb = DX + "整"
End Function
northwolves 2004-01-06
- 打赏
- 举报
Function daxie(money As String) As String '
Dim x As String, y As String
Const zimu = ".sbqwsbqysbqwsbq" '定义位置代码
Const letter = "0123456789sbqwy.zjf" '定义汉字缩写
Const upcase = "零壹贰叁肆伍陆柒捌玖拾佰仟萬億圆整角分" '定义大写汉字
Dim temp As String
temp = money
If InStr(temp, ".") > 0 Then temp = Left(temp, InStr(temp, ".") - 1)
If Len(temp) > 16 Then MsgBox "数目太大，无法换算！请输入一亿亿以下的数字", 64, "错误提示": Exit Function '只能转换一亿亿元以下数目的货币！
x = Format(money, "0.00") '格式化货币
y = ""
For i = 1 To Len(x) - 3
y = y & Mid(x, i, 1) & Mid(zimu, Len(x) - 2 - i, 1)
Next
If Right(x, 3) = ".00" Then
y = y & "z" '***元整
Else
y = y & Left(Right(x, 2), 1) & "j" & Right(x, 1) & "f" '*元*角*分
End If
y = Replace(y, "0q", "0") '避免零千(如：40200肆萬零千零贰佰)
y = Replace(y, "0b", "0") '避免零百(如：41000肆萬壹千零佰)
y = Replace(y, "0s", "0") '避免零十(如：204贰佰零拾零肆)
Do While y <> Replace(y, "00", "0")
y = Replace(y, "00", "0") '避免双零(如：1004壹仟零零肆)
Loop
y = Replace(y, "0y", "y") '避免零億(如：210億 贰佰壹十零億)
y = Replace(y, "0w", "w") '避免零萬(如：210萬 贰佰壹十零萬)
y = IIf(Len(x) = 5 And Left(y, 1) = "1", Right(y, Len(y) - 1), y) '避免壹十(如：14壹拾肆；10壹拾)
y = IIf(Len(x) = 4, Replace(y, "0.", ""), Replace(y, "0.", ".")) '避免零元(如：20.00贰拾零圆；0.12零圆壹角贰分)
For i = 1 To 19
y = Replace(y, Mid(letter, i, 1), Mid(upcase, i, 1)) '大写汉字
Next
daxie = y
End Function
Private Sub Command1_Click()
MsgBox daxie("1218212212309322.3238")
End Sub
Dim x As String, y As String
Const zimu = ".sbqwsbqysbqwsbq" '定义位置代码
Const letter = "0123456789sbqwy.zjf" '定义汉字缩写
Const upcase = "零壹贰叁肆伍陆柒捌玖拾佰仟萬億圆整角分" '定义大写汉字
Dim temp As String
temp = money
If InStr(temp, ".") > 0 Then temp = Left(temp, InStr(temp, ".") - 1)
If Len(temp) > 16 Then MsgBox "数目太大，无法换算！请输入一亿亿以下的数字", 64, "错误提示": Exit Function '只能转换一亿亿元以下数目的货币！
x = Format(money, "0.00") '格式化货币
y = ""
For i = 1 To Len(x) - 3
y = y & Mid(x, i, 1) & Mid(zimu, Len(x) - 2 - i, 1)
Next
If Right(x, 3) = ".00" Then
y = y & "z" '***元整
Else
y = y & Left(Right(x, 2), 1) & "j" & Right(x, 1) & "f" '*元*角*分
End If
y = Replace(y, "0q", "0") '避免零千(如：40200肆萬零千零贰佰)
y = Replace(y, "0b", "0") '避免零百(如：41000肆萬壹千零佰)
y = Replace(y, "0s", "0") '避免零十(如：204贰佰零拾零肆)
Do While y <> Replace(y, "00", "0")
y = Replace(y, "00", "0") '避免双零(如：1004壹仟零零肆)
Loop
y = Replace(y, "0y", "y") '避免零億(如：210億 贰佰壹十零億)
y = Replace(y, "0w", "w") '避免零萬(如：210萬 贰佰壹十零萬)
y = IIf(Len(x) = 5 And Left(y, 1) = "1", Right(y, Len(y) - 1), y) '避免壹十(如：14壹拾肆；10壹拾)
y = IIf(Len(x) = 4, Replace(y, "0.", ""), Replace(y, "0.", ".")) '避免零元(如：20.00贰拾零圆；0.12零圆壹角贰分)
For i = 1 To 19
y = Replace(y, Mid(letter, i, 1), Mid(upcase, i, 1)) '大写汉字
Next
daxie = y
End Function
Private Sub Command1_Click()
MsgBox daxie("1218212212309322.3238")
End Sub
