ASP函数库(全部可以直接调用，非常方便) 1

'**************************************************''''
'函数ID：0001[截字符串]
'函数名：SubstZFC
'作 用：截字符串，汉字一个算两个字符，英文算一个字符
'参 数：str ----原字符串
' strlen ----截取长度
'返回值：截取后的字符串
'**************************************************
Public Function SubstZFC(ByVal str, ByVal strlen)
If str = "" Then
SubstZFC = ""
Exit Function
End If
Dim l, t, c, i, strTemp
str = Replace(Replace(Replace(Replace(str, " ", " "), """, Chr(34)), ">", ">"), "<", "<")
l = Len(str)
t = 0
strTemp = str
strlen = CLng(strlen)
For i = 1 To l
c = Abs(Asc(Mid(str, i, 1)))
If c > 255 Then
t = t + 2
Else
t = t + 1
End If
If t >= strlen Then
strTemp = Left(str, i)
Exit For
End If
Next
SubstZFC = Replace(Replace(Replace(Replace(strTemp, " ", " "), Chr(34), """), ">", ">"), "<", "<")
End Function
'**************************************************
'函数ID：0002[过滤html]
'函数名：GlHtml
'作 用：过滤html 元素
'参 数：str ---- 要过滤字符
'返回值：没有html 的字符
'**************************************************
Public Function GlHtml(ByVal str)
If IsNull(str) Or Trim(str) = "" Then
GlHtml = ""
Exit Function
End If
Dim re
Set re = New RegExp
re.IgnoreCase = True
re.Global = True
re.Pattern = "(\<.[^\<]*\>)"
str = re.Replace(str, " ")
re.Pattern = "(\<\/[^\<]*\>)"
str = re.Replace(str, " ")
Set re = Nothing
str = Replace(str, "'", "")
str = Replace(str, Chr(34), "")
GlHtml = str
End Function
'**************************************************
'函数ID：0003[打开任意数据表并显示表结构及内容]
'函数名：OpOtherDB
'作 用：打开任意数据表并显示表结构及内容
'参 数：DBtheStr ---- 要打开表的数据库链接字串
'参 数：Opentdname ---- 要打开表名
'返回值：显示表结构及内容
'**************************************************
Public Function OpOtherDB(ByVal DBtheStr,ByVal Opentdname)
Response.write "<table border='0' width='100%' cellspacing='0' cellpadding='0'>" & vbCrlf
Set Opdb_Conn=server.createobject("ADODB.Connection")
Set Opdb_Rs =server.createobject("ADODB.Recordset")
Opdb_Conn.open DBtheStr
Opdb_sql_str="select * from "&Opentdname
Opdb_Rs.open Opdb_Sql_Str,Opdb_Conn,1,1
Nfieldnumber=Opdb_Rs.Fields.count
If Nfieldnumber >0 then
Response.write "<tr>" & vbCrlf
For i=0 to (Nfieldnumber-1)
Response.write "<td style='border-style: ridge; border-width: 1' bgcolor='#E1E1E1' valign='middle' align='center'>"
Response.write Trim(Opdb_Rs.Fields(i).Name)
Response.write "</td>" & vbCrlf
Next
temptbi=0
Do While Not Opdb_Rs.Eof
Response.write "</tr>" & vbCrlf
For i=0 to (Nfieldnumber-1)
If (temptbi<2) Then
Response.write "<td style='border-style: ridge; border-width: 1' bgcolor='#F6F6F6' valign='middle'>"
Response.write Trim(Opdb_Rs.Fields(i))
Response.write "</td>" & vbCrlf
temptbi=temptbi+1
Else
Response.write "<td style='border-style: ridge; border-width: 1' valign='middle'>"
Response.write Trim(Opdb_Rs.Fields(i))
Response.write "</td>" & vbCrlf
If temptbi>=3 Then
temptbi=0
Else
temptbi=temptbi+1
End If
End If
Next
Opdb_Rs.MoveNext
Response.write "</tr>" & vbCrlf
Loop
End If
Opdb_Rs.Close
Opdb_Conn.Close
Set Opdb_Rs = Nothing
Set Opdb_Conn=Nothing
Response.write "</table>" & vbCrlf
End function
'**************************************************
'函数ID：0004[读取两种路径]
'函数名：Readsyspath
'作 用：读取路径
'参 数：lx ---- 0:服务器IP加路径 1:服务物理路径
'返回值：路径字串
'**************************************************
Public Function Readsyspath(ByVal lx)
Dim templj,aryTemp,newpath
templj=""
newpath=""
If lx=0 Then
templj="http://"&Request("SERVER_NAME")&Request("PATH_INFO")
aryTemp = Split(templj,"/")
Else
templj=Request("PATH_TRANSLATED")
aryTemp = Split(templj,"\")
End If
For i = LBound(aryTemp) To UBound(aryTemp)-1
If lx=0 Then
newpath=newpath&aryTemp(i)&"/"
Else
newpath=newpath&aryTemp(i)&"\"
End If
Next
Readsyspath=newpath
End Function
'**************************************************
'函数ID：0005[测试某个文件存在否]
'函数名：CheckFile
'作 用：测试某个文件存在否
'参 数：ckFilename ---- 被测试的文件名（包括路径）
'返回值：文件存在返回True,否则False
'**************************************************
Public Function CheckFile(ByVal ckFilename)
Dim M_fso
CheckFile=False
Set M_fso = CreateObject("Scripting.FileSystemObject")
If M_fso.FileExists(ckFilename) Then
CheckFile=True
End If
Set M_fso = Nothing
End Function
'**************************************************
'函数ID：0006[删除某个文件]
'函数名：DelFile
'作 用：删除某个文件
'参 数：dFilename ---- 被删除的文件名（包括路径）
'返回值：文件删除返回True,否则False
'**************************************************
Public Function DelFile(ByVal dFilename)
Dim M_fso
DelFile=False
Set M_fso = CreateObject("Scripting.FileSystemObject")
If M_fso.FileExists(dFilename) Then
M_fso.DeleteFile(dFilename)
DelFile=True
End If
Set M_fso = Nothing
End Function
'**************************************************
'函数ID：0007[判断目录是否存在]
'函数名：CheckDir
'作 用：判断目录是否存在
'参 数：ckDirname ---- 目录名（包括路径）
'返回值：目录存在返回True,否则False
'**************************************************
Public Function CheckDir(ByVal ckDirname)
Dim M_fso
CheckDir=False
Set M_fso = CreateObject("Scripting.FileSystemObject")
If (M_fso.FolderExists(ckDirname)) Then
CheckDir=True
End If
Set M_fso = Nothing
End Function
'**************************************************
'函数ID：0008[创建目录]
'函数名：CreateDir
'作 用：创建目录
'参 数：crDirname ---- 目录名（包括路径）
'返回值：目录创建成功返回True,否则False
'**************************************************
Public Function CreateDir(ByVal crDirname)
Dim M_fso
CreateDir=False
Set M_fso = CreateObject("Scripting.FileSystemObject")
If (M_fso.FolderExists(crDirname)) Then
CreateDir=False
Else
M_fso.CreateFolder(crDirname)
CreateDir=True
End If
Set M_fso = Nothing
End Function
'**************************************************