最少代码把数字转换成人民币大写

你给来个没有BUG的吧

在他基础上改的有点不好

有空重新做个简洁点的给你看


Private Sub Command1_Click()
Dim num As Long, num_t As Long, i As Long, l As Long, s As Long
Dim rmb As String, rmb_char As String, rmb_weight As String
l = Len(Text1.Text)
s = InStr(1, Text1.Text, ".", vbTextCompare)
If s = 0 Then
For i = l To 1 Step -1
num_t = num
num = Mid(Text1.Text, l - i + 1, 1)
If num_t = num And num = 0 Then GoTo ooo1

rmb_char = IIf(num = 0, "零", Choose(num, "壹", "贰", "叁", "肆", "伍", "陆", "柒", "捌", "玖"))
rmb_weight = Choose(i, "", "拾", "佰", "仟", "萬", IIf(Mid(Text1.Text, l - i + 2, 1) = 0, "拾萬", "拾"), "佰", "仟", "萬", "亿", IIf(Mid(Text1.Text, l - i + 2, 1) = 0, "拾亿", "拾"), "佰", "仟", "萬")
rmb = rmb & rmb_char & IIf(num = 0, "", rmb_weight)
ooo1:
Next i
rmb = IIf(Mid(rmb, Len(rmb), Len(rmb)) = "零", Mid(rmb, 1, Len(rmb) - 1), rmb)
MsgBox rmb
Exit Sub
Else
For i = s - 1 To 1 Step -1
num_t = num
num = Mid(Text1.Text, s - i, 1)

If num_t = num And num = 0 Then GoTo ooo2

rmb_char = IIf(num = 0, "零", Choose(num, "壹", "贰", "叁", "肆", "伍", "陆", "柒", "捌", "玖"))
rmb_weight = Choose(i, "", "拾", "佰", "仟", "萬", IIf(Mid(Text1.Text, l - i + 2, 1) = 0, "拾萬", "拾"), "佰", "仟", "萬", "亿", IIf(Mid(Text1.Text, l - i + 2, 1) = 0, "拾亿", "拾"), "佰", "仟", "萬")
rmb = rmb & rmb_char & IIf(num = 0, "", rmb_weight)
ooo2:
Next i
rmb = IIf(Mid(rmb, Len(rmb), Len(rmb)) = "零", Mid(rmb, 1, Len(rmb) - 1), rmb)

If s <> l Then rmb = rmb & "点"
For i = l To s + 1 Step -1
num = Mid(Text1.Text, s - i + 1 + l, 1)
rmb_char = IIf(num = 0, "零", Choose(num, "壹", "贰", "叁", "肆", "伍", "陆", "柒", "捌", "玖"))
rmb = rmb & rmb_char
Next i
MsgBox rmb
Exit Sub
End If
End Sub

[此贴子已经被作者于2007-11-15 18:56:39编辑过]

Private Sub Command1_Click()
Print 大写转换("1442778565.93")
End Sub

Public Function 大写转换(ByVal NumStr As String) As String
    Dim 数 As String, 长 As Integer, i As Integer

    数 = ReplaceEx(NumStr, "0", "零 ", "1", "壹 ", "2", "贰 ", "3", "叁 ", "4", "肆 ", "5", "伍 ", "6", "陆 ", "7", "柒 ", "8", "捌 ", "9", "玖 ")
    Pos = InStr(NumStr, ".")
    If Pos = 0 Then
        长 = Len(NumStr)
    Else
        长 = Pos - 1
    End If
    For i = 长 To 1 Step - 1
        Mid(数, i * 2, 1) = Mid("圆拾佰仟万拾佰仟亿拾佰仟万", 长 - i + 1, 1)
    Next
    If Pos > 0 Then
        NumStr = Replace(数, ".", Empty, Pos * 2 - 1)
        数 = Mid(数, 1, (Pos - 1) * 2)
        Select Case Len(NumStr)
            Case 4
                Mid(NumStr, 2, 1) = "角"
                Mid(NumStr, 4, 1) = "分"
            Case 2
                Mid(NumStr, 2, 1) = "角"
        End Select
    Else
        NumStr = Empty
    End If
    数 = ReplaceEx(数 & NumStr, "零分", Empty, "零角", "零", "零拾", "零", "零佰", "零", "零仟", "零", "零零零", "零", "零零", "零", "零亿", "亿", "零万", "万", "零圆", "圆", "亿万", "亿")
    大写转换 = 数
End Function

Public Function ReplaceEx(InputStr As String, ParamArray 参数() As Variant) As String
Dim tmp As Long
ReplaceEx = InputStr
    For tmp = 0 To (UBound(参数) - 1) Step 2
        ReplaceEx = Replace(ReplaceEx, 参数(tmp), 参数(tmp + 1))
    Next
End Function