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, " < " , " &lt; " )
        iStr = Replace (iStr, " > " , " &gt; " )
        iStr = Replace (iStr, " ' " , " "" " )
        iStr = Replace (iStr, Chr ( 13 ), " <BR> " )
        iStr = Replace (iStr, "   " , " &nbsp; " )
        iStr = Replace (iStr,vbTab, " &nbsp;&nbsp;&nbsp " )
        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, " &nbsp; " , "   " ), " &quot; " , chr ( 34 )), " &gt; " , " > " ), " &lt; " , " < " )
        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, "   " , " &nbsp; " ), chr ( 34 ), " &quot; " ), " > " , " &gt; " ), " < " , " &lt; " )
     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
% >