asp制作中常用到的函数库集合第3/8页

 '************************************************** 
  '函数ID：0011[指定目录的目录列表] 
  '函数名：ListDirs 
  '作 用：指定目录的目录列表 
  '参 数：Dirname ---- 目录名（包括路径） 
  '返回值：目录列表字符串，之间用“|”相隔 
  '************************************************** 
  Public Function ListDirs(ByVal Dirname) 
   Dim M_fso,fNS,fLS,Fnames,FnamesN 
   Set M_fso = CreateObject("Scripting.FileSystemObject") 
   If (M_fso.FolderExists(Dirname)) Then 
   Set fNS = M_fso.GetFolder(Dirname) 
   Set fLS=fNS.SubFolders 
   For Each FnamesN in fLS 
   Fnames=Fnames & FnamesN.name 
   Fnames=Fnames & "|" 
   Next 
   ListDirs=Fnames 
   End If 
   Set M_fso = Nothing 
  End Function 
  '************************************************** 
  '函数ID：0012[创建文本文件] 
  '函数名：WritTextFile 
  '作 用：创建文本文件 
  '参 数：Fname ---- 文本文件名称（包括路径） 
  '参 数：WritString ---- 写入的内容 
  '返回值：创建成功返回True，否则False 
  '************************************************** 
  Public Function WritTextFile(ByVal Fname,ByVal WritString) 
   Dim M_fso,FnameN 
   WritTextFile=False 
   Set M_fso = CreateObject("Scripting.FileSystemObject") 
   Set FnameN= M_fso.OpenTextFile(Fname,2,True) 
   FnameN.Write WritString 
   FnameN.Close 
   Set M_fso = Nothing 
   WritTextFile=True 
  End Function 
  '************************************************** 
  '函数ID：0013[读取文本文件] 
  '函数名：ReadTextFile 
  '作 用：读取文本文件 
  '参 数：Fname ---- 文本文件名称（包括路径） 
  '返回值：返回读取的文本内容 
  '************************************************** 
  Public Function ReadTextFile(ByVal Fname) 
   Dim M_fso,FnameN,Fnr 
   ReadTextFile="" 
   Set M_fso = CreateObject("Scripting.FileSystemObject") 
   Set FnameN= M_fso.OpenTextFile(Fname,1,True) 
   Fnr=FnameN.ReadAll 
   FnameN.Close 
   Set M_fso = Nothing 
   ReadTextFile=Fnr 
  End Function 
  '************************************************** 
  '函数ID：0014[检测ID是否为数字类型] 
  '函数名：JCID 
  '作 用：检测ID是否为数字类型 
  '参 数：ParaValue ---- 被检测的ID值 
  '返回值：返回ID值，如果不为数字类型返回0 
  '************************************************** 
  Public Function JCID(ByVal ParaValue) 
   If ((Not isNumeric(ParaValue)) OR (Trim(ParaValue)="")) Then 
   JCID=0 
   Else 
   JCID=ParaValue 
   End If 
  End function 
  '************************************************** 
  '函数ID：0015[正则表达式测试] 
  '函数名：CheckExp 
  '作 用：正则表达式测试 
  '参 数：patrn ---- 正则表达式 
  '参 数：strng ---- 要测试的字符串 
  '返回值：测试如果成立返回 True 否则 False 
  '例 CheckExp("(\<.[^\<]*\>)","<br>") 
  '************************************************** 
  Public Function CheckExp(ByVal patrn, ByVal strng) 
   Dim regEx, retVal 
   Set regEx = New RegExp 
   regEx.Pattern = patrn 
   regEx.IgnoreCase = False 
   retVal = regEx.Test(strng) 
   CheckExp = retVal 
  End Function 
  '************************************************** 
  '函数ID：0016[获得执行程序的名称] 
  '函数名：GT_the_proname 
  '作 用：获得执行程序的名称 
  '参 数： 
  '返回值：返回执行程序的名称 
  '************************************************** 
  Public Function GT_the_proname() 
   Dim fu_name,temp,tempsiz 
   temp=Request.ServerVariables("PATH_INFO") 
   fu_name=Split(temp, "/", -1, 1) 
   tempsiz=UBound(fu_name) 
   GT_the_proname=fu_name(tempsiz) 
  End function 
  '************************************************** 
  '函数ID：0017[读取用户IP地址信息] 
  '函数名：Readusip 
  '作 用：读取用户IP地址信息 
  '参 数： 
  '返回值：返回用户IP地址 
  '************************************************** 
  Public Function Readusip() 
   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 
   Readusip = Trim(Mid(strIPAddr, 1, 30)) 
  End Function 
  '************************************************** 
  '函数ID：0018[无组件上传文件到指定目录并改文件名称] 
  '函数名：UpFsRn 
  '作 用：无组件上传文件到指定目录并更改文件名称 
  '参 数：RetSize--- 上传限止大小（单位是M） 
  '参 数：Fdir ---- 目标路径 
  '参 数：Objwj ---- 目标文件名称 
  '返回值：如果成功 True 否则 False 
  '例 UpFsRn(10,Readsyspath(1)&"zfkhauto","test.txt") 
  '使用表单提取文件 <form method='POST' action='function.asp' enctype='multipart/form-data'><input type='file' name='T1'><input type='submit' value='提交' name='B1'></form> 
  '************************************************** 
  Public Function UpFsRn(ByVal RetSize,ByVal Fdir,ByVal Objwj) 
   UpFsRn=False 
   Dim oUpStream,oStream,formsize,Formdata,strFileName,strFileDir,ObjAllPath,datastart,dataend 
   strFileDir = Fdir 
   strFileName = Swj 
   ObjAllPath = "" 
   If Right(strFileDir,1)<>"\" Then strFileDir=strFileDir&"\" 
   ObjAllPath =strFileDir&Objwj 
   If CheckFile(ObjAllPath) Then DelFile(ObjAllPath) 
   formsize=Request.TotalBytes 
   if (formsize<=(RetSize*1024*1024)) then 
   Formdata=Request.BinaryRead(formsize) 
   Pos_ts=LenB(getByteString(Chr(13) & Chr(10) & Chr(13) & Chr(10))) 
   Pos_b=InstrB(Formdata,getByteString(Chr(13) & Chr(10) & Chr(13) & Chr(10)))+Pos_ts 
   nFormdata=MidB(Formdata,Pos_b) 
   Pos_ts=InstrB(nFormdata,getByteString(Chr(13) & Chr(10) & "--")) 
   nnFormdata=MidB(nFormdata,Pos_ts) 
   Pos_e=LenB(Formdata)-LenB(nnFormdata)-Pos_b+1 
   datastart =Pos_b 
   dataend=Pos_e 
   set oUpStream = Server.CreateObject("adodb.stream") 
   oUpStream.Type = 1 
   oUpStream.Mode = 3 
   oUpStream.Open 
   set oStream = Server.CreateObject("adodb.stream") 
   oStream.Type = 1 
   oStream.Mode = 3 
   oStream.Open 
   oUpStream.Write Formdata 
   oUpStream.position=datastart-1 
   oUpStream.copyto oStream,dataend 
   oStream.SaveToFile ObjAllPath,2 
   oStream.Close 
   set oStream=nothing 
   UpFsRn=True 
   End If 
  End function 
  '************************************************** 
  '函数ID：0019[过滤HTML脚本] 
  '函数名：FilterJS 
  '作 用：过滤HTML脚本 
  '参 数：strHTML ---- 被检测的HTML字串 
  '返回值：返回过滤后的HTML 
  '************************************************** 
  Function FilterJS(ByVal strHTML) 
   Dim objReg,strContent 
   If IsNull(strHTML) OR strHTML="" Then Exit Function 
   Set objReg=New RegExp 
   objReg.IgnoreCase =True 
   objReg.Global=True 
   objReg.Pattern="(&#)" 
   strContent=objReg.Replace(strHTML,"") 
   objReg.Pattern="(function|meta|value|window\.|script|js:|about:|file:|Document\.|vbs:|frame|cookie)" 
   strContent=objReg.Replace(strContent,"") 
   objReg.Pattern="(on(finish|mouse|Exit=|error|click|key|load|focus|Blur))" 
   strContent=objReg.Replace(strContent,"") 
   FilterJS=strContent 
   strContent="" 
   Set objReg=Nothing 
  End Function 

最新评论