数字向中文转换

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： ShawFile@163.Net
                 QQ： 9181729