Excel自定义函数

1.

返回 Column 英文字

Function ColLetter(ColNumber As Integer) As String
    On Error GoTo Errorhandler
    ColLetter = Left(Cells(1, ColNumber).Address(0, 0), 1 - (ColNumber > 26))
Exit Function
Errorhandler:
    MsgBox "Error encountered, please re-enter "
End Function

2.考勤记录

Function MyFind(Value1, ByVal Range1 As Range, ByVal num As Integer, ByVal Col As Integer)
    If Value1 = "" Then Exit Function
    If Range1.Columns.Count > 1 Then Exit Function
    For Each D In Range1
        If D.Value = Value1 Then
            c = c + 1
            If c = num Then
                v1 = D(1, Col)
                Exit For
            End If
        ElseIf IsEmpty(D) Then
            Exit For
        End If
    Next
    If v1 = "" Then v1 = "not"
    MyFind = v1
End Function

3.

 求个人所得税Grsds(bsc,mysala)

Function Grsds(bsc As Double, mysala As Double) As Double
'bsc为起征点加上允许税前扣除的合理费用,mysala为工资薪金所得
'author：tanjh
On Error GoTo Grsds_err
Select Case mysala
Case Is <= bsc
Grsds = 0
Case Is <= bsc+500
Grsds = Application.WorksheetFunction.Round((mysala - bsc) * 0.05, 2)
Case Is <= bsc+2000
Grsds = Application.WorksheetFunction.Round((mysala - bsc) * 0.1 - 25, 2)
Case Is <= bsc+5000
Grsds = Application.WorksheetFunction.Round((mysala - bsc) * 0.15 - 125, 2)
Case Is <= bsc+20000
Grsds = Application.WorksheetFunction.Round((mysala - bsc) * 0.2 - 375, 2)
Case Is <= bsc+40000
Grsds = Application.WorksheetFunction.Round((mysala - bsc) * 0.25 - 1375, 2)
Case Is <= bsc+60000
Grsds = Application.WorksheetFunction.Round((mysala - bsc) * 0.3 - 3375, 2)
Case Is <= bsc+80000
Grsds = Application.WorksheetFunction.Round((mysala - bsc) * 0.35 - 6375, 2)
Case Is <= bsc+100000
Grsds = Application.WorksheetFunction.Round((mysala - bsc) * 0.4 - 10375, 2)
Case Else
Grsds = Application.WorksheetFunction.Round((mysala - bsc) * 0.45 - 15375, 2)
End Select
Grsds_Exit:
Exit Function
Grsds_err:
MsgBox Err.Number & ":" & Err.Description
Resume Grsds_Exit
End Function
该函数返回一个个人工资薪金所得应纳个人所得税税额。
语法：Grsds(bsc,mysala)
其中：
bsc,必选项，为起征点，包括税法规定的工资基数800元加上允许税前扣除的合理费用；
mysala,必选项，为人个工资薪金所得。
示例：
Grsds(850,20000)=3455.00
返回当个人工资薪金所得为2000元(起征点为850元)时的应纳个人所得税税额。

4.

取数据前置字符串、与数据居中(或滞后)字符串中数据的自定义函数
从"123545ABCDE"中取出数字的函数：
Function myvalue(mystring As String) As Double
myvalue = Val(mystring)
End Function
从"ABCD12455EDF"中取出数字的函数。
Function mydata(mystring As String) As Double
Dim i As Integer
i = 1
Do Until Val(Mid(mystring, i, 1)) > 0
i = i + 1
Loop
mydata = Val(Mid(mystring, i, Len(mystring) - i+1))
End Function

5.

金额数字转中文大写，财务人员必备
代码来自我们officefans的一位高手，在此大家先谢谢它
我只不过把它做成加载宏而已，举手之劳
哈哈


Function Money(Number As Currency)

Dim i, j, k, m, leng           As Integer         '计数器
Dim Zero                       As Integer         '连续零标识
Dim Tnumber                    As String          '储存数字字符串,计算数组长度
Dim Num()                      As String          '定义数组
Dim Num1(3)                    As String          '存储万元以下数字
Dim Num2(1)                    As String          '储存拆分后的数字
Dim Cha(8), Cha1(9), Cha2(4)   As String          '储存转化后的汉字
Dim Zcha                       As String          '连接后的字符串
Dim Flag, Flag1                As Boolean         '正负标志
               
Flag = True
Flag1 = False
Zero = 0

'*******如果大于一亿，则不处理*********

If (Number > 99999999) Or (Number < -99999999) Then
MsgBox ("Sorry,数据超过一亿，暂不处理。")
MsgBox ("顺便问一下，你真有那么多钱吗？")
Money = "Sorry!"
Else

If (Number = 0) Then
Money = "零元整"
Else


'*******将负数数字转化正数并更改标识*************

If (Number < 0) Then
   Number = Number * (-1)
   Flag = False
End If

'*******小数点后超过两位，则截断******

If (((Number - Int(Number)) * 100 - Int((Number - Int(Number)) * 100)) > 0) Then
   Tnumber = CStr(Int(Number * 100) / 100)
Else
   Tnumber = CStr(Number)
End If


'*******处理四舍五入*******************

If (((Number - Int(Number)) * 100 - Int((Number - Int(Number)) * 100)) >= 0.5) Then
   
   Tnumber = CStr((CCur(Tnumber)) + 0.01)
   
End If

Number = CCur(Tnumber)

'*******重新分配数组空间***************

ReDim Num(Len(Tnumber) - 1) As String


'*******将字符串分开存储至数组中*******

For i = 0 To Len(Tnumber) - 1
   Num(i) = Mid(Tnumber, i + 1, 1)
Next i


'*******定义所需字符*******************

Dim M1, M2
M1 = Array("零", "壹", "贰", "叁", "肆", "伍", "陆", "柒", "捌", "玖")
M2 = Array("", "拾", "佰", "仟", "万", "亿")



'*******处理小于一元金额***************
   
'*******小数点后一位，则***************

If ((Number - Int(Number) > 0) And ((Number * 100 - Int(Number) * 100) Mod 10) = 0) Then
       i = i - 1
       Num2(0) = Num(i)
       Num(i) = ""
       i = i - 1
       Num(i) = ""
       i = i - 1
       Cha2(0) = M1(CByte(Num2(0)))
       Cha2(1) = "角"
       Cha2(2) = "整"
    Else
   
'*******小数点后两位则*****************

       If ((Number - Int(Number) > 0)) Then
          i = i - 1
          Num2(1) = Num(i)
          Num2(0) = Num(i - 1)
          Num(i) = ""
          i = i - 1
          Num(i) = ""
          i = i - 1
          Num(i) = ""
          i = i - 1
          Cha2(0) = M1(CByte(Num2(0)))
          Cha2(1) = "角"
          Cha2(2) = M1(CByte(Num2(1)))
          Cha2(3) = "分"
       End If
    End If
   
'********分解大于一万的整数部分******************

    If (Int(Number) > 9999) Then
   
       If (Cha2(0) <> "") Then
          i = i + 1
       End If
      
       For j = 3 To 0 Step -1
          Num1(j) = Num(i - 1)
          Num(i - 1) = ""
          i = i - 1
       Next j
      
    Else
   
       If (Cha2(0) <> "") Then
          i = i + 1
       End If
      
       For j = 0 To i - 1
          Num1(j) = Num(j)
          Num(j) = ""
       Next j
      
    End If
   
   
'*******转换万元以上数字**********************************

If (Num(0) <> "") Then

    leng = i
    j = 0
   
    For k = 0 To leng - 1
   
      If (Num(k) = "0") Then
      
         Zero = Zero + 1
         
         For m = 1 To 5
            If (Cha(j - 1) = M2(m)) Then
               Flag1 = True
            End If
         Next m
         
         If ((Zero = 1) And (Flag1 = False)) Then
            Cha(j) = M1(CByte(Num(k)))
         End If
         
         If (Zero = 1) Then
            j = j + 1
         End If
         
      Else
      
         If (Num(k) <> "") Then
            If (Zero > 0) Then
               Cha(j - 1) = "零"
            End If
            Cha(j) = M1(CByte(Num(k)))
         End If
         
         j = j + 1
         
      End If
      
      If (Num(k) = "0") Then
         i = i - 1
      Else
         Cha(j) = M2(i - 1)
         j = j + 1
         i = i - 1
         Zero = 0
      End If
      
    Next k
   
    Cha(j - 1) = "万"
    Zero = 0
   
  End If
  
'*******转换万元以下数字**********************************

  If (Num1(0) <> "") Then
  
    j = 0
    Flag1 = False
    leng = 3
   
    While (Num1(leng) = "")
       leng = leng - 1
    Wend
   
    i = leng + 1
   
    For k = 0 To leng
   
     If (Num1(k) <> "") Then
     
      If (Num1(k) = "0") Then
      
         Zero = Zero + 1
         
         For m = 1 To 5
           If (j <> 0) Then
            If (Cha1(j - 1) = M2(m)) Then
               Flag1 = True
            End If
           End If
         Next m
         
         If ((Zero = 1) And (Flag1 = False)) Then
            Cha1(j) = M1(CByte(Num1(k)))
         End If
         
         If (Zero = 1) Then
            j = j + 1
         End If
         
      Else
      
         If (Num1(k) <> "") Then
            If (Zero > 0) Then
               Cha1(j - 1) = "零"
            End If
            Cha1(j) = M1(CByte(Num1(k)))
         End If
         
         j = j + 1
         
      End If
      
      If (Num1(k) = "0") Then
         i = i - 1
      Else
         Cha1(j) = M2(i - 1)
         j = j + 1
         i = i - 1
         Zero = 0
      End If
      
     End If
     
    Next k
   
    Cha1(j - 1) = "元"
   
    If (Cha2(0) = "") Then
       Cha1(j) = "整"
    End If
   
  End If
  
'*******连接字符串*********************

  j = 0
  While (Cha(j) <> "")
     Zcha = Zcha & Cha(j)
     j = j + 1
  Wend
  j = 0
  While (Cha1(j) <> "")
     Zcha = Zcha & Cha1(j)
     j = j + 1
  Wend
  j = 0
  While (Cha2(j) <> "")
     Zcha = Zcha & Cha2(j)
     j = j + 1
  Wend
  
'*******最终显示***********************

   If (Flag) Then
     Money = Zcha
   Else
     Money = "负" & Zcha
   End If
   
  End If
  
End If

End Function

6.

求税金：Public Function 税(fa)
  Dim x
If (fa - 800) > 0 And (fa - 800) < 500 Then
   x = (fa - 800) * 0.05
   税 = x
   ElseIf (fa - 800) >= 500 And (fa - 800) < 2000 Then
   x = (fa - 800) * 0.1 - 25
   税 = x
   ElseIf (fa - 800) >= 2000 And (fa - 800) < 5000 Then
   x = (fa - 800) * 0.15 - 125
   税 = x
   ElseIf (fa - 800) >= 5000 And (fa - 800) < 20000 Then
   x = (fa - 800) * 0.2 - 375
   税 = x
   ElseIf (fa - 800) >= 20000 And (fa - 800) < 40000 Then
   x = (fa - 800) * 0.25 - 1375
   税 = x
   ElseIf (fa - 800) >= 40000 And (fa - 800) < 60000 Then
   x = (fa - 800) * 0.3 - 3375
   税 = x
   ElseIf (fa - 800) >= 60000 And (fa - 800) < 80000 Then
   x = (fa - 800) * 0.35 - 6375
   税 = x
   ElseIf (fa - 800) >= 80000 And (fa - 800) < 100000 Then
   x = (fa - 800) * 0.4 - 10375
   税 = x
   ElseIf (fa - 800) >= 100000 Then
   x = (fa - 800) * 0.45 - 15375
   税 = x
   Else
End If
End Function
人民币大、小写：
Function 小写(k)
Application.ScreenUpdating = False
m1 = Application.WorksheetFunction.Round(k * 100, 0)
n1 = Int(m1 / 100)
n2 = Int(m1 / 10) - n1 * 10
n3 = m1 - n1 * 100 - n2 * 10
e = Application.WorksheetFunction.Text(n1, "[DBNum1]")
f = Application.WorksheetFunction.Text(n2, "[DBNum1]")
g = Application.WorksheetFunction.Text(n3, "[DBNum1]")
If n3 = 0 Then
  小写 = "人民币大写：" & e & "元" & "整"
   End If
If (n3 <> 0) And (n2 <> 0) Then
   小写 = "人民币大写：" & e & "元" & f & "角" & g & "分"
   If n1 = 0 Then
   小写 = "人民币大写：" & f & "角" & g & "分"
   End If
End If
If (n3 = 0) And n2 <> 0 Then
小写 = "人民币大写：" & e & "元" & f & "角" & "整"
  If n1 = 0 Then
  小写 = "人民币大写：" & f & "角" & "整"
  End If
End If
If (n3 <> 0) And (n2 = 0) Then
小写 = "人民币大写：" & e & "元" & g & "分"
If n1 = 0 Then
   小写 = "人民币大写：" & g & "分"
   End If
End If
If k = 0 Or k = "" Then
k = ""
End If
Application.ScreenUpdating = True
End Function
Function 大写(k)
Application.ScreenUpdating = False
m1 = Application.WorksheetFunction.Round(k * 100, 0)
n1 = Int(m1 / 100)
n2 = Int(m1 / 10) - n1 * 10
n3 = m1 - n1 * 100 - n2 * 10
e = Application.WorksheetFunction.Text(n1, "[dbnum2]")
f = Application.WorksheetFunction.Text(n2, "[dbnum2]")
g = Application.WorksheetFunction.Text(n3, "[dbnum2]")
If n3 = 0 Then
  大写 = "人民币大写：" & e & "元" & "整"
   End If
If (n3 <> 0) And (n2 <> 0) Then
   大写 = "人民币大写：" & e & "元" & f & "角" & g & "分"
   If n1 = 0 Then
   大写 = "人民币大写：" & f & "角" & g & "分"
   End If
End If
If (n3 = 0) And n2 <> 0 Then
  大写 = "人民币大写：" & e & "元" & f & "角" & "整"
  If n1 = 0 Then
  大写 = "人民币大写：" & f & "角" & "整"
  End If
End If
If (n3 <> 0) And (n2 = 0) Then
大写 = "人民币大写：" & e & "元" & f & g & "分"
If n1 = 0 Then
   大写 = "人民币大写：" & g & "分"
   End If
End If
If k = 0 Or k = "" Then
大写 = ""
End If
Application.ScreenUpdating = True
End Function
查汉字区位码：
Public Function 区(fa$) As String
    On Error Resume Next
    Dim L1$, R1$, L$, R$, a, b$, c, d, e$
    c = Len(fa)
    For i = 1 To c
    d = Mid(fa, i, 1)
    a = Hex(Asc(d))
    L1 = CInt("&H" + Mid(a, 1, 2)) - 160
    R1 = CInt("&H" + Mid(a, 3, 2)) - 160
    If Len(L1) = 1 Then
    L = "0" & L1
    Else
    L = L1
    End If
    If Len(R1) = 1 Then
    R = "0" & R1
    Else
    R = R1
    End If
    b =d & " " & L & R & " "
    e = e & b
    Next i
    区 = e
End Function

7.

'用指定字符替换某字符
Public Function ReplaceIt(OriginalStr As String, SearchStr As String, ToBeReplaced As String) As String
    Dim FoundPos As Integer
    Do While VBA.InStr(1, OriginalStr, SearchStr) <> 0
        FoundPos = VBA.InStr(1, OriginalStr, SearchStr)
        OriginalStr = VBA.Left(OriginalStr, FoundPos - 1) & ToBeReplaced & VBA.Mid(OriginalStr, (FoundPos + VBA.Len(SearchStr)))
    Loop
    ReplaceIt = OriginalStr
End Function

8.

'从右边开始查找指定字符在字符串中的位置
Public Function MyInStrRev(MainStr As String, SubStr As String) As Integer
    Dim Counter As Integer
    Dim Success As Boolean
    If VBA.Len(MainStr) < VBA.Len(SubStr) Then
        MyInStrRev = 0
    Else
        For Counter = VBA.Len(SubStr) To VBA.Len(MainStr)
            If VBA.Left(VBA.Right(MainStr, Counter), VBA.Len(SubStr)) = SubStr Then
                Success = True
                Exit For
            End If
        Next Counter
        If Success Then
            MyInStrRev = VBA.Len(MainStr) - Counter + 1
        Else
            MyInStrRev = 0
        End If
    End If
End Function
9.

将20040510数字格式，转换为2004－5－10的日期格式的函数

Public Function 日期格式(rd1)
    Dim day1 As Date
    Dim rdy1 As String
    Dim nn1, yn1, dn1 As Integer
    rdy1 = Trim(rd1)
   If Len(rdy1) <> 8 Then
    日期格式 = "日期位数不对"
    Exit Function
   End If
   
   On Error GoTo tishi
    nn1 = Left(rdy1, 4)
    yn1 = Mid(rdy1, 5, 2)
    dn1 = Right(rdy1, 2)
    day1 = nn1 & "-" & yn1 & "-" & dn1
    日期格式 = day1
    Exit Function
tishi:
   日期格式 = "错误的日期"
End Function
10.工龄计算：
Function Elapsed(StartDate As Date, EndDate As Date, ReturnType As Integer)
Dim StartYear As Integer '定义变量用以参数中开始日期的计算
Dim StartMonth As Integer
Dim StartDay As Integer
Dim EndYear As Integer '定义变量用以参数中结束日期的计算
Dim EndMonth As Integer
Dim EndDay As Integer
StartYear = Year(StartDate) '从参数中获取开始日期和结束日期的年数，月数，天数
StartMonth = Month(StartDate)
StartDay = Day(StartDate)
EndYear = Year(EndDate)
EndMonth = Month(EndDate)
EndDay = Day(EndDate)
If EndDay < StartDay Then '如果结束日期参数的天数小于开始日期中的天数，则...
EndDay = EndDay + (DateSerial(EndYear, EndMonth + 1, EndDay) - DateSerial(EndYear, EndMonth, EndDay))
EndMonth = EndMonth - 1 '...从月数中借1后再进行减运算，从而得到相关天数
End If
If EndMonth < StartMonth Then '如果结束日期参数的月数小于开始日期参数中的月数，则...
EndMonth = EndMonth + 12
EndYear = EndYear - 1 '从年数中借1后再进行减运算，从而得到相差月数
End If
Select Case ReturnType '如果没有以上特殊情况，则直接进行相减的运算
Case 1 '返回年数
Elapsed = EndYear - StartYear
Case 2 '返回月数
Elapsed = EndMonth - StartMonth
Case 3 '返回天数
Elapsed = EndDay - StartDay
End Select
End Function

11.'计算日期差，除去星期六、星期日的自定义函数
Function daydif(x As Range, y As Range)

    Dim date1, date2 As Date
    date1 = x
    date2 = y
   
    dif = 0
    Do
    If (date1 >= date2) Then
        Exit Do
    End If
   
    date1 = date1 + 1
    t1 = Weekday(date1)
    If (t1 < 7 And t1 > 1) Then
        dif = dif + 1
    End If
    Loop
    daydif = dif
   
End Function
12.這是一個將英文字反轉的自定函數.

Function TextReverse(sSource As String) As String
Dim iCounter As Integer
Dim sText As String
    For iCounter = Len(sSource) To 1 Step -1
        sText = sText & Mid(sSource, iCounter, 1)
    Next
    TextReverse = sText
End Function
13.个人所得税

'q为应纳税所得额  ，w为扣除额，可自定义，如800

'应用：如a1为应纳税所得额，直接在单元格输入“=sds(a1,800)"，也可以是“=sds(a1,b1))"
'如果扣除额不是800，可自己改数字，也可以是单元格

Public Function sds(q, w)

je = q - w
If q < w Then
'msgbox("应纳税所得额必须大于或等于扣除额!")
    sds = 0
ElseIf je <= 500 Then
    sds = je * 0.05
ElseIf je > 500 And je <= 2000 Then
    sds = je * 0.1 - 25
ElseIf je > 2000 And je <= 5000 Then
    sds = je * 0.15 - 125
ElseIf je > 5000 And je <= 20000 Then
    sds = je * 0.2 - 375
ElseIf je > 20000 And je <= 40000 Then
    sds = je * 0.25 - 1375
ElseIf je > 40000 And je <= 60000 Then
    sds = je * 0.3 - 3375
ElseIf je > 60000 And je <= 80000 Then
    sds = je * 0.35 - 6375
ElseIf je > 80000 And je <= 10000 Then
    sds = je * 0.4 - 10375
Else
    sds = je * 0.45 - 15375
End If

End Function

14.财务人员常用的大小写转换功能

由于前几年初学VBA时只会用IF语句，包括上面个人所得税和下面的大小写转换全用IF，望大家不要见笑：

Public qb As String
Public hb As String
Public Function xs(p)
xs1 = Choose(Left(p, 1) + 1, "", "壹", "贰", "叁", "肆", "伍", "陆", "柒", "捌", "玖")
xs2 = Choose(Right(p, 1) + 1, "", "壹", "贰", "叁", "肆", "伍", "陆", "柒", "捌", "玖")
If Right(p, 1) <> "0" Then
    If Left(p, 1) <> "0" Then
        xs = xs + xs1 + "角" + xs2 + "分"
    ElseIf Val(qb) = 0 Then
        xs = xs + xs2 + "分"
    Else
        xs = xs + "零" + xs2 + "分"
    End If
ElseIf Right(p, 1) = "0" Then
    If Left(p, 1) <> "0" Then
        xs = xs + xs1 + "角" + "整"
    Else
        xs = xs + "整"
    End If
End If
   
End Function


Public Function dx(aa)

kk = Format(aa, "###0.00")
l = Len(kk)
cy = 15 - l
qb = Left(kk, l - 3)
hb = Right(kk, 2)
'Mid(kk, l - 2, 1) = "0"
If l > 15 Then
    dx = MsgBox("警告：请不要输入超过：“仟亿”重量级的数值，好咩？")
    dx = ""
ElseIf aa >= 1 Then
    For x = 1 To l - 3
        a1 = Choose(x + cy, "仟", "佰", "拾", "亿", "仟", "佰", "拾", "万", "仟", "佰", "拾", "元", "", "角", "分")
        b1 = Mid(kk, x, 1)
        b2 = Mid(kk, x + 1, 1)
        c = Choose(b1 + 1, "零", "壹", "贰", "叁", "肆", "伍", "陆", "柒", "捌", "玖")
        If b1 = 0 Then
            If a1 = "亿" Then
                If b2 <> 0 Then
                    dx = dx + "亿零"
                Else
                    dx = dx + "亿"
                End If
            ElseIf a1 = "万" Then
                If Right(dx, 1) = "亿" Then
                    dx = dx + ""
                ElseIf b2 <> 0 Then
                    dx = dx + "万零"
                Else
                    dx = dx + "万"
                End If

            ElseIf a1 = "元" Then
                If Left(hb, 1) = 0 Then
                    dx = dx + "元"
                Else
                    dx = dx + "元零"
                End If
            ElseIf b2 = 0 Then
                dx = dx + ""
            Else
                dx = dx + "零"
            End If
        Else
            dx = dx + c + a1
        End If
    Next x
        dx = dx + xs(hb)
Else
    dx = xs(hb)
End If
End Function

在使用时只需在单元格中只录入”=dx(a1)"即可，参数可自行修改为a2、a3.........

15.一个能计算是否有重复单元的函数

Function IsRepeate(c As Range) As Boolean

Dim cell As Range
Dim SumC As Integer
Dim CountBlank As Integer
SumC = 0: CountBlank = 0
For Each cell In c
   If VBA.IsEmpty(cell) Then
       CountBlank = CountBlank + 1
   Else
          SumC = SumC + 1 / WorksheetFunction.CountIf(c, cell)
   End If
Next cell
If SumC = c.count - CountBlank  and c.count > CountBlank Then '不重复的话就返回FALSE
   IsRepeate = False

Else                    '重复的话就返回TRUE
   IsRepeate =True

End If

End Function

16.'此过程为西人所写，数字转英文谨推荐给大家.


'****************' Main Function *'****************
Function SpellNumber(ByVal MyNumber)
    Dim Dollars, Cents, Temp
    Dim DecimalPlace, Count
    ReDim Place(9) As String
    Application.Volatile True
    Place(2) = " Thousand "
    Place(3) = " Million "
    Place(4) = " Billion "
    Place(5) = " Trillion "     ' String representation of amount
    MyNumber = Trim(Str(MyNumber))     ' Position of decimal place 0 if none
    DecimalPlace = InStr(MyNumber, ".")
    'Convert cents and set MyNumber to dollar amount
    If DecimalPlace > 0 Then
        Cents = GetTens(Left(Mid(MyNumber, DecimalPlace + 1) & "00", 2))
        MyNumber = Trim(Left(MyNumber, DecimalPlace - 1))
        End If
    Count = 1
    Do While MyNumber <> ""
       Temp = GetHundreds(Right(MyNumber, 3))
       If Temp <> "" Then Dollars = Temp & Place(Count) & Dollars
          If Len(MyNumber) > 3 Then
             MyNumber = Left(MyNumber, Len(MyNumber) - 3)
             Else
            MyNumber = ""
            End If
            Count = Count + 1
            Loop
    Select Case Dollars
        Case ""
            Dollars = "No Dollars"
        Case "One"
            Dollars = "One Dollar"
        Case Else
            Dollars = Dollars & " Dollars"
    End Select
    Select Case Cents
        Case ""
            Cents = " and No Cents"
        Case "One"
            Cents = " and One Cent"
        Case Else
            Cents = " and " & Cents & " Cents"
    End Select
    SpellNumber = Dollars & Cents
    End Function
'*******************************************
' Converts a number from 100-999 into text *
'*******************************************
Function GetHundreds(ByVal MyNumber)
    Dim Result As String
    If Val(MyNumber) = 0 Then Exit Function
    MyNumber = Right("000" & MyNumber, 3)     'Convert the hundreds place
    If Mid(MyNumber, 1, 1) <> "0" Then
        Result = GetDigit(Mid(MyNumber, 1, 1)) & " Hundred "
        End If
    'Convert the tens and ones place
    If Mid(MyNumber, 2, 1) <> "0" Then
        Result = Result & GetTens(Mid(MyNumber, 2))
        Else
        Result = Result & GetDigit(Mid(MyNumber, 3))
        End If
    GetHundreds = Result
    End Function
'*********************************************
' Converts a number from 10 to 99 into text. *
'*********************************************
Function GetTens(TensText)
    Dim Result As String
    Result = ""           'null out the temporary function value
    If Val(Left(TensText, 1)) = 1 Then   ' If value between 10-19
        Select Case Val(TensText)
        Case 10: Result = "Ten"
            Case 11: Result = "Eleven"
            Case 12: Result = "Twelve"
            Case 13: Result = "Thirteen"
            Case 14: Result = "Fourteen"
            Case 15: Result = "Fifteen"
            Case 16: Result = "Sixteen"
            Case 17: Result = "Seventeen"
            Case 18: Result = "Eighteen"
            Case 19: Result = "Nineteen"
            Case Else
            End Select
      Else                                 ' If value between 20-99
        Select Case Val(Left(TensText, 1))
            Case 2: Result = "Twenty "
            Case 3: Result = "Thirty "
            Case 4: Result = "Forty "
            Case 5: Result = "Fifty "
            Case 6: Result = "Sixty "
            Case 7: Result = "Seventy "
            Case 8: Result = "Eighty "
            Case 9: Result = "Ninety "
            Case Else
        End Select
         Result = Result & GetDigit _
            (Right(TensText, 1))  'Retrieve ones place
            End If
      GetTens = Result
      End Function
'*******************************************
' Converts a number from 1 to 9 into text. *
'*******************************************
Function GetDigit(Digit)
    Select Case Val(Digit)
        Case 1: GetDigit = "One"
        Case 2: GetDigit = "Two"
        Case 3: GetDigit = "Three"
        Case 4: GetDigit = "Four"
        Case 5: GetDigit = "Five"
        Case 6: GetDigit = "Six"
        Case 7: GetDigit = "Seven"
        Case 8: GetDigit = "Eight"
        Case 9: GetDigit = "Nine"
        Case Else: GetDigit = ""
    End Select
End Function
17.'判断是否连接在线的函数

Public Declare Function InternetGetConnectedState _
    Lib "wininet.dll" (lpdwFlags As Long, _
    ByVal dwReserved As Long) As Boolean

Function IsConnected() As Boolean
    Dim Stat As Long
    IsConnected = (InternetGetConnectedState(Stat, 0&) <> 0)
End Function


Sub Test()
' Randy Birch
    If IsConnected = True Then
        MsgBox "Copy your mail code here"
    Else
        MsgBox "You can't use this subroutine because you are not online"
    End If
End Sub

18.