'--------------------------------
'将双精度型数值转化为大写人民币金额
'--------------------------------
Public Function DblToCurr(ByVal ValNum As Double)
Dim RetStr As String, strUnit As String, tmpStr As String
Dim LenStr As Integer, i As Integer, j As Integer
Dim strUnits As String, strNums As String, CurNum As Integer
Dim PreZero As Boolean

' If ValNum < 0 Then
' MsgBox "金额小于零", vbInformation, "系统提示"
' End If
ValNum = Abs(ValNum)
If ValNum >= 1E+15 Then
MsgBox "金额太大，系统不能处理！", vbInformation, "系统提示"
RetStr = "零元"
GoTo ReturnResult
End If
strNums = "零壹贰叁肆伍陆柒捌玖": strUnits = "拾百千万亿"
ValNum = Int(ValNum * 100 + 0.5) / 100
tmpStr = Trim(Str(Abs(ValNum)))
LenStr = Len(tmpStr)
i = InStr(1, tmpStr, "."): If i = 0 Then i = LenStr + 1
RetStr = "元"
RetStr = RetStr & Mid(strNums, Val(Mid(tmpStr, i + 1, 1)) + 1, 1) & "角"
RetStr = RetStr & Mid(strNums, Val(Mid(tmpStr, i + 2, 1)) + 1, 1) & "分"
If ValNum < 1 Then RetStr = "零" & RetStr
j = 0: PreZero = False: strUnit = ""
Do While i > 1
i = i - 1
CurNum = Val(Mid(tmpStr, i, 1))
If CurNum = 0 Then
If j Mod 4 = 0 Then
RetStr = strUnit & RetStr
ElseIf PreZero = False Then
RetStr = Mid(strNums, 1, 1) & RetStr
End If
PreZero = True
Else
RetStr = Mid(strNums, CurNum + 1, 1) & strUnit & RetStr
PreZero = False
End If
j = j + 1
If j = 4 Or j = 12 Then
strUnit = Mid(strUnits, 4, 1)
PreZero = False

ElseIf j = 8 Then
strUnit = Mid(strUnits, 5, 1)
PreZero = False
Else
strUnit = Mid(strUnits, j Mod 4, 1)
End If
Loop
ReturnResult:
DblToCurr = RetStr
End Function