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, "&nbsp;", " "), "&quot;", Chr(34)), "&gt;", ">"), "&lt;", "<")
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, " ", "&nbsp;"), Chr(34), "&quot;"), ">", "&gt;"), "<", "&lt;")
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
'**************************************************