数字向中文转换
Public Function ChinaNum(ByVal Num As String) As String
On Error GoTo ChinaNumErr
ChinaNum = ""
Dim str_tmp_CN As String
Dim str_tmp_ZS As String
Dim str_tmp_XS As String
Dim I As Long
If VBA.Trim(Num) = "" Then
GoTo ChinaNumErr
End If
For I = 1 To VBA.Len(Num) Step 1
Select Case VBA.Mid$(Num, I, 1)
Case "1", "2", "3", "4", "5", "6", "7", "8", "9", "0", "."
Case Else
GoTo ChinaNumErr
End Select
Next I
If Num Like "*.*" Then
If Num Like "*.*.*" Then
GoTo ChinaNumErr
End If
I = VBA.InStr(1, Num, ".", vbTextCompare)
str_tmp_ZS = VBA.Left(Num, I - 1)
str_tmp_XS = VBA.Right(Num, VBA.Len(Num) - I)
str_tmp_ZS = zsTOstr(str_tmp_ZS)
str_tmp_XS = xsTOstr(str_tmp_XS)
If str_tmp_ZS = "" Then
str_tmp_CN = "零"
Else
str_tmp_CN = str_tmp_ZS
End If
If str_tmp_XS <> "" Then
str_tmp_CN = str_tmp_CN & "点" & str_tmp_XS
End If
End If
GoTo ChinaNumOK
ChinaNumOK:
If str_tmp_CN <> "" Then
Let ChinaNum = str_tmp_CN
Else
GoTo ChinaNumErr
End If
GoTo ChinaNumExit
ChinaNumErr:
Err.Clear
ChinaNum = ""
GoTo ChinaNumExit
ChinaNumExit:
'clear all money
str_tmp_CN = ""
str_tmp_ZS = ""
str_tmp_XS = ""
I = 0
Exit Function
End Function
Private Function zsTOstr(ByVal str_ZS As String) As String
On Error GoTo zsTOstrErr
If Not IsNumeric(str_ZS) Or str_ZS Like "*.*" Or str_ZS Like "*-*" Then
If Trim(str_ZS) <> "" Then
GoTo zsTOstrErr
End If
End If
If VBA.Len(str_ZS) > 16 Then
Let str_ZS = VBA.Left(str_ZS, 16)
End If
Dim intLen As Integer, intCounter As Integer
Dim strCh As String, strTempCh As String
Dim strSeqCh1 As String, strSeqCh2 As String
Dim str_ZS2Ch As String
str_ZS2Ch = "零壹贰叁肆伍陆柒捌玖"
strSeqCh1 = " 拾佰仟 拾佰仟 拾佰仟 拾佰仟"
strSeqCh2 = " 万亿兆"
str_ZS = CStr(CDec(str_ZS))
intLen = Len(str_ZS)
For intCounter = 1 To intLen
strTempCh = Mid(str_ZS2Ch, Val(Mid(str_ZS, intCounter, 1)) + 1, 1)
If strTempCh = "零" And intLen <> 1 Then
If Mid(str_ZS, intCounter + 1, 1) = "0" Or (intLen - intCounter + 1) Mod 4 = 1 Then
strTempCh = ""
End If
Else
strTempCh = strTempCh & Trim(Mid(strSeqCh1, intLen - intCounter + 1, 1))
End If
If (intLen - intCounter + 1) Mod 4 = 1 Then
strTempCh = strTempCh & Mid(strSeqCh2, (intLen - intCounter + 1) / 4 + 1, 1)
If intCounter > 3 Then
If Mid(str_ZS, intCounter - 3, 4) = "0000" Then strTempCh = Left(strTempCh, Len(strTempCh) - 1)
End If
End If
strCh = strCh & Trim(strTempCh)
Next
GoTo zsTOstrOK
zsTOstrOK:
Let zsTOstr = strCh
GoTo zsTOstrExit
zsTOstrErr:
Err.Clear
zsTOstr = ""
GoTo zsTOstrExit
zsTOstrExit:
strCh = ""
intLen = 0
intCounter = 0
strTempCh = ""
strSeqCh1 = ""
strSeqCh2 = ""
str_ZS2Ch = ""
Exit Function
End Function
Private Function xsTOstr(ByVal str_XS As String) As String
On Error GoTo xsTOstrErr
If Not IsNumeric(str_XS) Or str_XS Like "*.*" Or str_XS Like "*-*" Then
If Trim(str_XS) <> "" Then
GoTo xsTOstrErr
End If
End If
If VBA.Len(str_XS) > 20 Then
GoTo xsTOstrErr
End If
Dim str_TH As String
str_TH = "零壹贰叁肆伍陆柒捌玖"
Dim I As Long
Dim str_tmp_XS As String
For I = 1 To VBA.Len(str_XS) Step 1
str_tmp_XS = str_tmp_XS & VBA.Mid(str_TH, VBA.CInt(VBA.Mid(str_XS, I, 1)) + 1, 1)
Next I
If str_tmp_XS = "" Then
GoTo xsTOstrErr
End If
GoTo xsTOstrOK
xsTOstrOK:
Let xsTOstr = str_tmp_XS
GoTo xsTOstrExit
xsTOstrErr:
Err.Clear
xsTOstr = ""
GoTo xsTOstrExit
xsTOstrExit:
str_TH = ""
I = 0
str_tmp_XS = ""
Exit Function
End Function
以上代码来自： SourceCode Explorer(源代码数据库)
复制时间： 2002-06-12 19:27:13
当前版本： 1.0.705
作者： Shawls
个人主页： Http://Shawls.Yeah.Net
E-Mail： [email protected]
QQ： 9181729