Arkadaşlar yabancı bir sitede buldum. Güzel functionlar var işinize yarayanı kullanabilirsiniz.


<%
Function LoseHTML(strHTML)
On Error Resume Next
Dim objRegExp, strOutput
Set objRegExp = New Regexp
objRegExp.IgnoreCase = True
objRegExp.Global = True
objRegExp.Pattern = "<.+?>"
strHTML = strHTML & ""
if strHTML="" Then LoseHTML="":Exit Function
strOutput = objRegExp.Replace(strHTML, "")
strOutput = Replace(strOutput, "<", "<")
strOutput = Replace(strOutput, ">", ">")
strOutput = Replace(strOutput, " ", "")
strOutput = Replace(strOutput, "•", "·")
LoseHTML = Trim(strOutput)
Set objRegExp = Nothing
End Function

Public Function Checkstr(Str)
If Isnull(Str) or str = "" Then
CheckStr = ""
Exit Function
End If
Str = Replace(Str,Chr(0),"")
Str = Replace(Str,Chr(10),"")
Str = Replace(Str,Chr(13),"")
CheckStr = Replace(Str,"'","''")

End Function

Rem 空字段则赋值为零长度字符串
Function ChkIsNull(str)
If IsNull(str) then
ChkIsNull = ""
Else
ChkIsNull = str
End If
End Function


function JoinChar(strUrl)
if strUrl="" then
JoinChar=""
exit function
end if
if InStr(strUrl,"?") if InStr(strUrl,"?")>1 then
if InStr(strUrl,"&") JoinChar=strUrl & "&"
else
JoinChar=strUrl
end if
else
JoinChar=strUrl & "?"
end if
else
JoinChar=strUrl
end if
end function


Function IsObjInstalled(strClassString)
On Error Resume Next
IsObjInstalled = False
Err = 0
Dim xTestObj
Set xTestObj = Server.CreateObject(strClassString)
If 0 = Err Then IsObjInstalled = True
Set xTestObj = Nothing
Err = 0
End Function

Function getver(Classstr)
On Error Resume Next
getver=""
Err = 0
Dim xTestObj
Set xTestObj = Server.CreateObject(Classstr)
If 0 = Err Then getver=xtesTobj.version
Set xTestObj = Nothing
Err = 0
End Function

'*************************************
'反转换HTML代码
'*************************************
Function HTMLDecode(ByVal reString)
Dim Str:Str=reString
If Not IsNull(Str) Then
Str = Replace(Str, ">", ">")
Str = Replace(Str, "<", "<")
Str = Replace(Str, " ", CHR(9))
Str = Replace(Str, "    ", CHR(9))
Str = Replace(Str, "'", CHR(39))
Str = Replace(Str, """, CHR(34))
Str = Replace(Str, "", CHR(13))
Str = Replace(Str, "

", CHR(10) & CHR(10))
Str = Replace(Str, "
", CHR(10))
HTMLDecode = Str
End If
End Function

Function HTMLEncode(ByVal fString)
If Not IsNull(fString) Then
fString = replace(fString, ">", ">")
fString = replace(fString, "<", "<")
fString = Replace(fString, CHR(32), " ")
fString = Replace(fString, CHR(9), " ")
fString = Replace(fString, CHR(34), """)
fString = Replace(fString, CHR(39), "'")
fString = Replace(fString, CHR(13), "")
HTMLEncode = fString
End If
End Function

Function ServerHTMLEncode(ByVal str)
If Not IsNull(str) Then
ServerHTMLEncode = Server.HTMLEncode(str)
Else
ServerHTMLEncode = ""
End If
End Function

Sub MsgBox(str, stype, ac)
response.write "<script>"
If chkisnull(str)<>"" Then
response.write "alert('"&str&"');"
End If
select case stype
case "back"
response.write "history.go(-1);"
case "gourl"
response.write "window.location='"&ac&"';"
case "close"
response.write "window.opener=self;window.close();"
Case Else
response.write ac
end select
response.write "</script>"
response.write ""
response.end
End Sub

'*************************************
'检测是否只包含英文和数字
'*************************************
Function IsValidChars(str)
Dim re,chkstr
Set re=new RegExp
re.IgnoreCase =true
re.Global=True
re.Pattern="[^_\.a-zA-Z\d]"
IsValidChars=True
chkstr=re.Replace(str,"")
if chkstr<>str then IsValidChars=False
set re=nothing
End Function

'*************************************
'检测是否包含在允许的字符范围
'*************************************
Function IsvalidValue(ArrayN,Str)
IsvalidValue = false
Dim GName
For Each GName in ArrayN
If Str = GName Then
IsvalidValue = true
Exit For
End If
Next
End Function

'*************************************
'检测是否有效的数字
'*************************************
Function IsInteger(Para)
IsInteger=False
If Not (IsNull(Para) Or Trim(Para)="" Or Not IsNumeric(Para)) Then
IsInteger=True
End If
End Function


'*************************************
'计算随机数
'*************************************
function randomStr(intLength)
dim strSeed,seedLength,pos,str,i
strSeed = "abcdefghijklmnopqrstuvwxyz1234567890ABCDEFGHIJKLMNOPQRSTUVWXYZ!@#$&"
seedLength=len(strSeed)
str=""
Randomize
for i=1 to intLength
str=str+mid(strSeed,int(seedLength*rnd)+1,1)
next
randomStr=str
end function

'***********************************************
'过程名:showpage
'作 用:显示“上一页 下一页”等信息
'参 数:sfilename ----链接地址
' totalnumber ----总数量
' maxperpage ----每页数量
' ShowTotal ----是否显示总数量
' ShowAllPages ---是否用下拉列表显示所有页面以供跳转。有某些页面不能使用,否则会出现JS错误。
' strUnit ----计数单位
'***********************************************
sub showpage(sfilename,totalnumber,maxperpage,ShowTotal,ShowAllPages,strUnit)
dim n, i,strTemp,strUrl
if totalnumber mod maxperpage=0 then
n= totalnumber \ maxperpage
else
n= totalnumber \ maxperpage+1
end If
strTemp= ""
If ShowAllPages Then strTemp= "

"
if ShowTotal=true then
strTemp=strTemp & "共 " & totalnumber & " " & strUnit & "  "
end if
strUrl=JoinChar(sfilename)
if CurrentPage<2 then
strTemp=strTemp & "首页 上一页 "
else
strTemp=strTemp & "首页 "
strTemp=strTemp & "上一页 "
end if

if n-currentpage<1 then
strTemp=strTemp & "下一页 尾页"
else
strTemp=strTemp & "下一页 "
strTemp=strTemp & "尾页"
end if
strTemp=strTemp & " 页次:" & CurrentPage & "/" & n & "页 "
strTemp=strTemp & " " & maxperpage & "" & strUnit & "/页"
if ShowAllPages=True then
strTemp=strTemp & " 转到:"
strTemp=strTemp & "
"
end if

response.write strTemp
end Sub

Function GotTopic(Str,Strlen)
if Strlen = "" then Strlen = 0
If Str="" or IsNull(Str) or Cint(Strlen) < 1 Then
GotTopic = Str
Exit Function
End If
Dim l,t,c, i
l=Len(Str)
t=0
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
GotTopic=Left(Str,i)
Exit For
Else
GotTopic=Str
End If
Next
End Function

Function RequestForm(str)
Dim Temp
Temp = Request.Form(str)
Temp = ChkIsNull(Temp)
Temp = Checkstr(Temp)
RequestForm = Trim(Temp)
End Function

' 获取拼音
Function PinYin(ByVal Chinese)
Chinese = Replace(Chinese,"/","") : Chinese = Replace(Chinese,"\","")
Chinese = Replace(Chinese,"*","") : Chinese = Replace(Chinese,"]","")
Chinese = Replace(Chinese,"[","") : Chinese = Replace(Chinese,"}","")
Chinese = Replace(Chinese,"{","") : Chinese = Replace(Chinese,"'","")
Dim Pinyinstr,iStr,iIsCn,IsCn
Dim PinyinConn,i,X
On Error Resume Next
Set PinyinConn = Server.Createobject("Adodb.Connection")
PinyinConn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source="&server.mappath(SystemDirectory & "/Inc/Pinyin.Asp")
If Err Then PinYin = "" : Set PinyinConn = Nothing : Exit Function
IsCN = True
For i = 1 To Len(Chinese)
iIsCn = IsCn ' 获取上次是不是中文的值
iStr = Mid(Chinese,i,1)
X = Asc(iStr)
If (X>=65 And X<=90) Or (X>=97 And X<=122) Or (X>=48 And X<=57) Or iStr = " " Then
IsCn = False ' 这些是英文,数字(保留字符),不改动
If iStr = " " Then iStr = "-"
Else
Set Rs = PinyinConn.Execute("Select Top 1 [Pinyin] From [5U_Pinyin] Where [Content] like '%"&iStr&"%';")
If Not Rs.eof Then
iStr = Rs(0) : IsCn = True ' 中文
Else
IsCn = False
If iStr = " " Then iStr = "-" Else iStr = "" ' 将空格转换成-,如果是其他字符则清除
End If
Rs.Close : Set Rs = Nothing
End If
If iIsCn = IsCn Then Pinyinstr=Pinyinstr & iStr Else Pinyinstr = Pinyinstr & "-" & iStr
Pinyinstr = Replace(Pinyinstr,"--","-")
Pinyinstr = Replace(Pinyinstr,"__","_")
Next
If Right(Pinyinstr,1) = "-" Then Pinyinstr = Left(Pinyinstr,Len(Pinyinstr)-1)
If Right(Pinyinstr,1) = "_" Then Pinyinstr = Left(Pinyinstr,Len(Pinyinstr)-1)
If Left(Pinyinstr,1) = "-" Then Pinyinstr = Right(Pinyinstr,Len(Pinyinstr)-1)
If Left(Pinyinstr,1) = "_" Then Pinyinstr = Right(Pinyinstr,Len(Pinyinstr)-1)
PinyinConn.Close
Set PinyinConn = Nothing
PinYin = Trim(Pinyinstr)
End Function

Sub DeleteBlankFolder(vPath)
Dim temp, FS, Fo
temp = vPath
If temp="" Or temp="/" Then Exit Sub
temp = server.MapPath(temp)
Set FS = Server.CreateObject(Lone_FSO)
If FS.FolderExists(temp) Then
Set Fo = FS.getFolder(temp)
If Fo.Files.Count=0 And Fo.SubFolders.Count=0 Then
Fo.Delete
temp = Left(temp, InstrRev(temp, "/"))
DeleteBlankFolder(temp)
End If
Set Fo = Nothing
End If
Set FS = Nothing
End Sub

Function chkFolderExist(byVal folderName)
On Error Resume Next
chkFolderExist = False
Dim FSO, Folder
Set fso=CreateObject("Scripting.FileSystemObject")
Folder = Left(folderName, InstrRev(folderName, "/"))
Folder = Server.MapPath(Folder)
If FSO.FolderExists(Folder) Then chkFolderExist = True
Set FSO = Nothing
End Function


Function Binary2String(binstr, charset)
Dim Objstream
Set Objstream = Server.CreateObject("adodb.stream")
objstream.Type = 1
objstream.Mode = 3
objstream.Open
objstream.Write binstr
objstream.Position = 0
objstream.Type = 2
objstream.Charset = charset
StringReturn = objstream.ReadText
objstream.Close
set objstream = nothing
Binary2String = StringReturn
End Function


Function ScriptHtml(Byval ConStr,TagName,FType)
Dim Re
Set Re=new RegExp
Re.IgnoreCase =true
Re.Global=True
Select Case FType
Case 1
Re.Pattern="<" & TagName & "([^>])*>"
ConStr=Re.Replace(ConStr,"")
Case 2
Re.Pattern="<" & TagName & "([^>])*>.*?])*>"
ConStr=Re.Replace(ConStr,"")
Case 3
Re.Pattern="<" & TagName & "([^>])*>"
ConStr=Re.Replace(ConStr,"")
Re.Pattern="])*>"
ConStr=Re.Replace(ConStr,"")
End Select
ScriptHtml=ConStr
Set Re=Nothing
End Function

'
Function NoWrap(ByVal Str)
Dim temp
temp = chkIsNull(Str)
If temp<>"" Then
temp = Replace(temp, vbNewLine, "")
temp = Replace(temp, Chr(0), "")
temp = Replace(temp, Chr(10), "")
temp = Replace(temp, Chr(13), "")
End If
NoWrap = Trim(temp)
End Function

Function UpNumber(ByVal Number)
Dim Result, strNumber, lngNumberLen, strTmp
Dim strFirst, strEnd, lngI, lngJ, lngTmp
Dim strNum, strUnit
If Not IsInteger(Number) Then Exit Function
strNum = Split("零 一 二 三 四 五 六 七 八 九 ")
strUnit = Split(" 十 百 千 万 十 百 千 亿 十 百 千 万 十 百 千 ")
Result = "" : strFirst = "" : lngI = 0
strNumber = Trim(CStr(Number))
lngNumberLen = Len(strNumber)
For lngJ = lngNumberLen To 1 Step -1
lngTmp = CLng(Mid(strNumber, lngJ, 1))

If lngTmp>0 Then
Result = strNum(lngTmp) & strUnit(lngI) & Result
Else
If lngI = 0 Or lngI = 4 Or lngI = 8 Or lngI = 12 Then '超过 16 位不支持
Result = strNum(lngTmp) & strUnit(lngI) & Result
Else
Result = strNum(lngTmp) & Result
End If
End If
lngI = lngI + 1
Next
Result = Replace(Result, strNum(0) & strNum(0), strNum(0))
If Number>0 And Right(Result, 1) = strNum(0) Then Result=Left(Result, Len(Result)-1)
If Number>9 And Number<20 Then Result = Mid(Result, 2)
UpNumber = Result
End Function

Function GetVolumeName(ByVal PlayURL)
Dim PlayURLs
If Left(PlayURL, 7)="qvod://" Then
PlayURLs=Split(PlayURL, "|")
GetVolumeName = PlayURLs(UBound(PlayURLs)-1)
Else
PlayURLs=Split(PlayURL, "/")
GetVolumeName = PlayURLs(UBound(PlayURLs))
End If
End Function

%>