Public Function ChinaNum(ByVal Num As String) As StringOn Error GoTo ChinaNumErrChinaNum = ""
Dim str_tmp_CN As StringDim str_tmp_ZS As StringDim str_tmp_XS As StringDim I As Long
If VBA.Trim(Num) = "" Then GoTo ChinaNumErrEnd 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 SelectNext 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 IfGoTo 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 StringOn 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 StringOn 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： ShawFile@163.Net QQ： 9181729
