ASP 3.0 常用自定义函数选编

<%


'**************************************************


'ASP 3.0 常用函数库


'WDFrog选编


'2006-04-6


'<meta http-equiv="Content-Type" content="text/html; charset=gb2312">


'**************************************************


Class cls_FunLib




Public ErrMsg,ErrId


Public ReURL '来路地址


Private Sub Class_Initialize()


ReURL=Request.ServerVariables("HTTP_REFERER")


Call ClearErr()


End Sub


Private Sub Class_Terminate()


'//析构函数


End Sub


Public Function ClearErr()


ErrMsg=""


ErrId=0


End Function


'**************************************


'返回页面提交数据,并过滤[']["]


'keyName 值对名


'defValue 默认值


'**************************************


Public Function GetQ(keyName,defValue)


Dim temp


temp=Safe(Request(keyName))


if temp=vbNullString Then


temp=defValue


End If


GetQ=temp


End Function


'*******************************************


'获取页面提交的整型数据


'******************************************


Public Function GetInt(keyName,defValue)


Dim temp


if NOT IsNumeric(defValue) Then


Call Err.Raise(7474,"util","默认值应为数字!")


Exit Function


End If


temp=Safe(Request(keyName))


if temp=vbNullString Then


temp=defValue


End If


If IsNumeric(temp) Then


GetInt=CInt(temp)


End If


End Function


'****************************************


'过滤[']["]


'****************************************


Public Function Safe(str)


str=Replace(str,"'","")


str=Replace(str,"""","")


Safe=str


End Function




'***************************************


'比较两个字符串是否相等


'***************************************


Public Function Cmp(strA,strB)


if Trim(UCase(Cstr(strA)))=Trim(UCase(Cstr(strB))) Then


Cmp=True


Else


Cmp=False


End If


End Function


'****************************************


'获取访问者IP


'****************************************


Public Function GetIP()


Dim strIPAddr


If Request.ServerVariables("HTTP_X_FORWARDED_FOR") = "" OR InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), "unknown") > 0 Then


strIPAddr = Request.ServerVariables("REMOTE_ADDR")


ElseIf InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ",") > 0 Then


strIPAddr = Mid(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), 1, InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ",")-1)


ElseIf InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ";") > 0 Then


strIPAddr = Mid(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), 1, InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ";")-1)


Else


strIPAddr = Request.ServerVariables("HTTP_X_FORWARDED_FOR")


End If


GetIP = Safe(Trim(Mid(strIPAddr, 1, 30)))


End Function


'***************************************


'关闭本窗口


'***************************************


Public Function WinClose()


Response.Write "<Script language=""JScript"">" & vbcrlf


Response.Write(" window.close();") & vbcrlf


Response.Write "</Script>" & vbcrlf


End Function


'**************************************


'刷新窗口


'winType : 0,父窗口 1,本窗口


'**************************************


Public Function ReLoad(winType)


Response.Write "<Script language=""JScript"">" & vbcrlf


if winType=0 Then


Response.Write("window.opener.location.reload();") & vbcrlf


Else


Response.Write("window.location.reload();") & vbcrlf


End If


Response.Write "</Script>" & vbcrlf


End Function


'****************************************


'显示一条提示信息


'****************************************


Public Function MsgBox(msg)


msg=Replace(msg,"""","""")


Response.Write "<Script language=""JScript"">"


Response.Write "alert(""" & msg & """);"


Response.Write "</Script>"


End Function


'**************************************************


'客户端重定向


'***************************************************


Public Function Go(URL)


Response.Write "<Script language=""JScript"">"


Response.Write "window.location.href='" & URL & "';"


Response.Write "</Script>"


End Function


'********************************************


'显示文本域提交上来的数据


'保证回车正常显示


'********************************************


Public Function Deal(str)


Dim iStr


iStr=Replace(str,"<","<")


iStr=Replace(iStr,">",">")


iStr=Replace(iStr,"'","""")


iStr=Replace(iStr,Chr(13),"<BR>")


iStr=Replace(iStr," "," ")


iStr=Replace(iStr,vbTab,"   ")


Deal=iStr


End Function


'**************************************


'过滤HTML标签


'**************************************


Public Function NoHtml(str)


dim re


Set re=new RegExp


re.IgnoreCase =true


re.Global=True


re.Pattern="(<.[^<]*>)"


str=re.replace(str," ")


re.Pattern="(</[^<]*>)"


str=re.replace(str," ")


NoHtml=str


set re=nothing


end function


'**************************************


'检测是否为站外提交


'*************************************


Public Function ChkPost()


Dim server_v1, server_v2


ChkPost = False


server_v1 = CStr(request.ServerVariables("HTTP_REFERER"))


server_v2 = CStr(request.ServerVariables("SERVER_NAME"))


If Mid(server_v1, 8, Len(server_v2)) = server_v2 Then


ChkPost = True


End If


End Function


'**************************************************


'函数名：gotTopic


'作 用：截字符串，汉字一个算两个字符，英文算一个字符


'参 数：str ----原字符串


' strlen ----截取长度


'返回值：截取后的字符串


'**************************************************


Function gotTopic(str,strlen)


if str="" then


gotTopic=""


exit function


end if


dim l,t,c, i


str=replace(replace(replace(replace(str," "," "),""",chr(34)),">",">"),"<","<")


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


gotTopic=replace(replace(replace(replace(gotTopic," "," "),chr(34),"""),">",">"),"<","<")


End Function


'**************************************************


'函数名：strLength


'作 用：求字符串长度。汉字算两个字符，英文算一个字符。


'参 数：str ----要求长度的字符串


'返回值：字符串长度


'**************************************************


Public Function strLen(str)


ON ERROR RESUME NEXT


dim WINNT_CHINESE


WINNT_CHINESE = (len("中国")=2)


if WINNT_CHINESE then


dim l,t,c


dim i


l=len(str)


t=l


for i=1 to l


c=asc(mid(str,i,1))


if c<0 then c=c+65536


if c>255 then


t=t+1


end if


next


strLen=t


else


strLen=len(str)


end if


if err.number<>0 then err.clear


end function


'**************************************************


'函数名：IsObjInstalled


'作 用：检查组件是否已经安装


'参 数：strClassString ----组件名


'返回值：True ----已经安装


' False ----没有安装


'**************************************************


Public 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




'******************************************************


'作 用: 删除一个文件


'参 数: FileName ----完整的文件名


'返回值: True成功,False失败


'******************************************************


Public Function DelFile(FileName)


Dim fso,whichfile,thisfile


If not IsObjInstalled("Scripting.FileSystemObject") Then


DelFile=False


Else


Set fso=CreateObject("Scripting.FileSystemObject")


If fso.FileExists(FileName) Then


whichfile=fileName


Set thisfile = fso.GetFile(whichfile)


thisfile.Delete True


DelFile=True


Else


DelFile=False


End If


End if


End Function


'-------------根据指定名称生成目录---------


Public Function CreateDir(foldername)


On Error Resume Next


err.Clear()


Dim fso,f


Set fso = Server.CreateObject("Scripting.FileSystemObject")


Set f = fso.CreateFolder(foldername)


Set fso = nothing


If Err Then


CreateDir = False


Else


CreateDir = True


End If


End Function


'------------------检查某一目录是否存在-------------------


Public Function CheckDir(FolderPath)


dim fso


Set fso = Server.CreateObject("Scripting.FileSystemObject")


If fso.FolderExists(FolderPath) then


CheckDir = True


Else


CheckDir = False


End if


Set fso = nothing


End Function


'*********************************************


'生成当前页地址,不包括所带参数


'*********************************************


Public Function GetCurURL()


Dim URL


URL="http://" & Request.ServerVariables("SERVER_NAME")


URL=URL & Request.ServerVariables("SCRIPT_NAME")


GetCurURL=URL &"?"


End Function


'****************************************


'完成编码转换


'将字节串转换为GB2312 的字符串


'**************************************


Public Function Bytes2bStr(Byval inv)


Dim stream


Set stream=Server.CreateObject("ADODB.Stream")


With stream


.Type=2


.Open()


.WriteText inv


.Position=0


.CharSet="GB2312"


.Position=2


Bytes2bStr=.ReadText


.Close()


End With


Set stream=Nothing


End Function




'************************************


'生成一段随机数


'*************************************


Public Function GetRandNum()


Dim ranNum


randomize()


ranNum=int(9999*rnd)+100


GetRandNum=year(now)&month(now)&day(now)&hour(now)&minute(now)&second(now)&ranNum


End Function


'*********************************


'返回短时间


'********************************


Public Function ShortDate(dValue)


ShortDate=DatePart("yyyy",dValue) & "-" & DatePart("m",dValue) & "-" & DatePart("d",dValue)


End Function


'*************************************


'检测给定值是否在字符中，字符串以flag([,][|]..)分割


'Values: 数据集合


'chkValue:检测值


'flag:分割符号


'************************************


Public Function InCollection(Byval Values, byVal chkValue,ByVal flag)


Dim arr,iValue


InCollection=False


arr=split(Values,flag)


For Each iValue In arr


If Trim(UCase(Cstr(iValue)))=Trim(UCase(Cstr(chkValue))) Then


InCollection=True


Exit For


End If


Next


End Function


End Class


%>


<%


Dim util


Set util=New cls_FunLib


%>