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.
扫一扫
529
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
