我公用的函数库

发布:liuqiangew

1 Apr

<%
'******************************************************************
'*    Name: 公用函数库                                            *
'*    Version: V1.2                                               *
'*    Update: 03/24/2009                                          *
'*    Author: 飘逸的风                                            *
'*    WebSite: www.webchar.com                                    *
'******************************************************************
'==================================================================
'作    用：将html 标记替换成能在IE显示的HTML
'参    数：fString ---- 要处理的字符串
'使用方法：
'更新时间：
'作    者：
'说    明：返回处理后的字符串
'==================================================================
Function HTMLEncode(ByVal fString)
    If IsNull(fString) Or Trim(fString) = "" Then
        HTMLEncode = ""
        Exit Function
    End If
    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), "<br>")
    fString = Replace(fString, Chr(10) & Chr(10), "</P><P>")
    fString = Replace(fString, Chr(10), "<BR>")
    HTMLEncode = fString
End Function
'==================================================================
'作    用：还原Html标记,配合HTMLEncode 使用
'参    数：fString ---- 要处理的字符串
'使用方法：
'更新时间：
'作    者：
'说    明：返回处理后的字符串
'==================================================================
Function HtmlDecode(ByVal fString)
    If IsNull(fString) Or Trim(fString) = "" Then
        PE_HtmlDecode = ""
        Exit Function
    End If
    fString = Replace(fString, ">", ">")
    fString = Replace(fString, "<", "<")
    fString = Replace(fString, " ", " ")
    fString = Replace(fString, """, Chr(34))
    fString = Replace(fString, "'", Chr(39))
    fString = Replace(fString, "</P><P> ", Chr(10) & Chr(10))
    fString = Replace(fString, "<BR> ", Chr(10))
    HtmlDecode = fString
End Function

'==================================================================
'作    用：检索特定字符串是否合法
'参    数：
'          Str：需要检索的字符串，一般为地址栏信息
'          ErrMsg：错误时显示的错误信息
'          RedirectUrl：转向地址（路径）
'使用方法：
'          Cstr=Request.ServerVariables("QUERY_STRING")
'          ErrMsg="请不要恶意攻击本站！点击确定返回首页！"
'          RedirectUrl="index.asp"
'          CheckQueryString(Cstr,ErrMsg,RedirectUrl)
'更新时间：03/26/2009
'作    者：飘逸的风（整理）
'说    明：使用此函数时，关键字不要出现以下字符串：
'          select count chr char ' "" insert delete drop
'          truncate from %
'==================================================================
Function CheckQueryString(Str,ErrMsg,RedirectUrl)
CQS=Str
Dim nothis(18)
nothis(0)="net user"
nothis(1)="xp_cmdshell"
nothis(2)="/add"
nothis(3)="exec%20master.dbo.xp_cmdshell"
nothis(4)="net localgroup administrators"
nothis(5)="select"
nothis(6)="count"
nothis(7)="chr"
nothis(8)="char"
nothis(9)="mid"
nothis(10)="'"
nothis(11)=":"
nothis(12)=""""
nothis(13)="insert"
nothis(14)="delete"
nothis(15)="drop"
nothis(16)="truncate"
nothis(17)="from"
nothis(18)="%"
errc=false
For i= 0 To ubound(nothis)
  If Instr(CQS,nothis(i))<>0 Then
   errc=True
  End If
Next
If errc Then
  Response.Write "<script language=""javascript"">"
  Response.Write "parent.alert('"&ErrMsg&"');"
  Response.Write "self.location.href='"&RedirectUrl&"';"
  Response.Write "</script>"
  Response.End
End If
End Function
'==================================================================
'作    用：格式化日期时间
'参    数：
'          DateTime：日期时间
'          ShowType：时间格式以下是常用的三种格式：
'                    "Y-m-d H:I:S" "Y-m-d" "YmdHIS"
'使用方法：
'          DateToStr(Now(),"Y-m-d H:I:S")
'更新时间：03/26/2009
'作    者：
'说    明：注意参数值的大小写
'==================================================================
Function DateToStr(DateTime,ShowType)
Dim DateMonth,DateDay,DateHour,DateMinute,DateWeek,DateSecond
Dim FullWeekday,shortWeekday,Fullmonth,Shortmonth,TimeZone1,TimeZone2
TimeZone1="+0800"
TimeZone2="+08:00"
FullWeekday=Array("Sunday","Monday","Tuesday","Wednesday","Thursday","Friday","Saturday")
shortWeekday=Array("Sun","Mon","Tue","Wed","Thu","Fri","Sat")
    Fullmonth=Array("January","February","March","April","May","June","July","August","September","October","November","December")
    Shortmonth=Array("Jan","Feb","Mar","Apr","May","Jun","Jul","Aug","Sep","Oct","Nov","Dec")

DateMonth=Month(DateTime)
DateDay=Day(DateTime)
DateHour=Hour(DateTime)
DateMinute=Minute(DateTime)
DateWeek=weekday(DateTime)
DateSecond=Second(DateTime)
If Len(DateMonth)<2 Then DateMonth="0"&DateMonth
If Len(DateDay)<2 Then DateDay="0"&DateDay
If Len(DateMinute)<2 Then DateMinute="0"&DateMinute
Select Case ShowType
Case "Y-m-d"
  DateToStr=Year(DateTime)&"-"&DateMonth&"-"&DateDay
Case "Y-m-d H:I A"
  Dim DateAMPM
  If DateHour>12 Then
   DateHour=DateHour-12
   DateAMPM="PM"
  Else
   DateHour=DateHour
   DateAMPM="AM"
  End If
  If Len(DateHour)<2 Then DateHour="0"&DateHour
  DateToStr=Year(DateTime)&"-"&DateMonth&"-"&DateDay&" "&DateHour&":"&DateMinute&" "&DateAMPM
Case "Y-m-d H:I:S"
  If Len(DateHour)<2 Then DateHour="0"&DateHour
  If Len(DateSecond)<2 Then DateSecond="0"&DateSecond
  DateToStr=Year(DateTime)&"-"&DateMonth&"-"&DateDay&" "&DateHour&":"&DateMinute&":"&DateSecond
Case "YmdHIS"
  DateSecond=Second(DateTime)
  If Len(DateHour)<2 Then DateHour="0"&DateHour
  If Len(DateSecond)<2 Then DateSecond="0"&DateSecond
  DateToStr=Year(DateTime)&DateMonth&DateDay&DateHour&DateMinute&DateSecond
Case "ym"
  DateToStr=Right(Year(DateTime),2)&DateMonth
Case "d"
  DateToStr=DateDay
    Case "ymd"
        DateToStr=Right(Year(DateTime),4)&DateMonth&DateDay
    Case "mdy"
        Dim DayEnd
        select Case DateDay
         Case 1
          DayEnd="st"
         Case 2
          DayEnd="nd"
         Case 3
          DayEnd="rd"
         Case Else
          DayEnd="th"
        End Select
        DateToStr=Fullmonth(DateMonth-1)&" "&DateDay&DayEnd&" "&Right(Year(DateTime),4)
    Case "w,d m y H:I:S"
  DateSecond=Second(DateTime)
  If Len(DateHour)<2 Then DateHour="0"&DateHour
  If Len(DateSecond)<2 Then DateSecond="0"&DateSecond
        DateToStr=shortWeekday(DateWeek-1)&","&DateDay&" "& Left(Fullmonth(DateMonth-1),3) &" "&Right(Year(DateTime),4)&" "&DateHour&":"&DateMinute&":"&DateSecond&" "&TimeZone1
    Case "y-m-dTH:I:S"
  If Len(DateHour)<2 Then DateHour="0"&DateHour
  If Len(DateSecond)<2 Then DateSecond="0"&DateSecond
  DateToStr=Year(DateTime)&"-"&DateMonth&"-"&DateDay&"T"&DateHour&":"&DateMinute&":"&DateSecond&TimeZone2
Case Else
  If Len(DateHour)<2 Then DateHour="0"&DateHour
  DateToStr=Year(DateTime)&"-"&DateMonth&"-"&DateDay&" "&DateHour&":"&DateMinute
End Select
End Function
'==================================================================
'作    用：脏话过滤(方法一)
'参    数：
'          Str：需要过滤的字符串
'          BadWord1：过滤的字符串
'          RepStr：替换的字符串
'使用方法：
'          Str="你好，我的朋友~！中国好！"
'          BadWord1="中国|朋友"
'          RepStr="*"
'          Response.Write ChkBadWords(Str,BadWord1,RepStr)
'更新时间：03/26/2009
'作    者：
'说    明：
'==================================================================
Function ChkBadWords(Str,BadWord1,RepStr)
If IsNull(Str) Then Exit Function
Dim i,rBadWord,BadWord
Str=Replace(Str," ","")
Str=Replace(Str,"　","")
BadWord =""&BadWord1&""
BadWord = Split(BadWord,"|")
For i = 0 To Ubound(BadWord)
  'rBadWord = Split(BadWord(i),"=")
  Str = Replace(Str,BadWord(i),RepStr)
Next
ChkBadWords = Str
End Function
'==================================================================
'作    用：脏话过滤(方法二)
'参    数：
'          Str：需要过滤的字符串
'          BadWord1：过滤和替换的字符串的字符串，多个用|分开
'使用方法：
'          Str="你好，我的朋友~！中国好！"
'          BadWord1="中国=China|我=I"
'          Response.Write ChkBadWords_ToStr(Str,BadWord1)
'更新时间：03/26/2009
'作    者：
'说    明：
'==================================================================
Function ChkBadWords_ToStr(Str,BadWord1)
If IsNull(Str) Then Exit Function
Dim i,rBadWord,BadWord
Str=Replace(Str," ","")
Str=Replace(Str,"　","")
BadWord =""&BadWord1&""
BadWord = Split(BadWord,"|")
For i = 0 To Ubound(BadWord)
  rBadWord = Split(BadWord(i),"=")
  Str = Replace(Str,rBadWord(0),rBadWord(1))
Next
ChkBadWords_ToStr = Str
End Function
'==================================================================
'作    用：检查组件是否已经安装
'参    数：strClassString：组件名
'使用方法：IsObjInstalled("ADODB.RecordSet")
'更新时间：03/26/2009
'作    者：
'说    明：此函数又返回值，True：已经安装 False：未安装
'==================================================================
Function IsObjInstalled(s_ClassString)
     On Error Resume Next
     IsObjInstalled = False
     Err = 0
     Dim xTestObj
     Set xTestObj = Server.CreateObject(s_ClassString)
     If 0 = Err Then IsObjInstalled = True
     Set xTestObj = Nothing
     Err = 0
End Function
'==================================================================
'作    用：自定义弹窗
'参    数：
'          Str：信息内容
'          ErrInfo：错误信息
'          Url：跳转路径
'使用方法：Msg("成功！","","index.asp")
'更新时间：03/26/2009
'作    者：飘逸的风
'说    明：如果没有设置Url参数，则实现后退功能，否则跳转指定页
'==================================================================
Function Msg(Str,ErrInfo,Url)
If IsNull(Str) Then Exit Function
If Url="" Then
    UrlPath="history.back();"
Else
    UrlPath="location.href='"&Url&"'"
End If
Response.Write("<script language=""javascript"">alert('"&Str&ErrInfo&"');"&UrlPath&"</script>")
End Function
'==================================================================
'作    用：剔除所有HTML标签
'参    数：Str要剔除的字符串
'使用方法：noHTML("<a href='index.asp'>你好，朋友！</a>")
'更新时间：03/26/2009
'作    者：
'说    明：
'==================================================================
Function noHTML(Str)
Dim re
Set re=New RegExp
re.IgnoreCase =true
re.Global=True
re.Pattern="<(.[^>]*)>"
Str=re.Replace(Str,"")
noHTML=Str
Set re=Nothing
End Function
'==================================================================
'作    用：剔除HTML标签,去除Html格式，用于显示输出，保留特定字符
'参    数：Str要剔除的字符串
'使用方法：noHTML2("<a href='index.asp'>你好，朋友！</a>")
'更新时间：03/26/2009
'作    者：
'说    明：
'==================================================================
Function outHTML2(str)
Dim sTemp
sTemp = str
outHTML = ""
If IsNull(sTemp) = True Then
  Exit Function
End If
sTemp = Replace(sTemp, "&", "&")
sTemp = Replace(sTemp, "<", "<")
sTemp = Replace(sTemp, ">", ">")
sTemp = Replace(sTemp, Chr(34), """)
sTemp = Replace(sTemp, Chr(10), "<br>")
outHTML2 = sTemp
End Function
'==================================================================
'作    用：剔除HTML标签并截取指定长度的字符串
'参    数：
'          Str：要剔除的字符串
'          StrLen：截取的长度（汉字占一个字节）
'使用方法：CutStr("<a href='index.asp'>你好，朋友！</a>",3)
'更新时间：03/26/2009
'作    者：
'说    明：
'==================================================================
Function CutStr(Str,StrLen)
Dim re
Set re=New RegExp
re.IgnoreCase =True
re.Global=True
re.Pattern="<(.[^>]*)>"
Str=re.Replace(Str,"")
Set re=Nothing
CutStr=Replace(CutStr,Chr(10),"")
CutStr=Replace(CutStr,Chr(13),"")
CutStr=Replace(CutStr," ","")
CutStr=Replace(CutStr," ","")
CutStr=Replace(CutStr,"　","")
l=Len(Str)
If l>=StrLen Then
  CutStr=left(Str,StrLen)&"..."
Else
  CutStr=Str
End If
End Function
'==================================================================
'作    用：过滤非法的SQL字符
'参    数：strChar：要过滤的字符
'使用方法：ReplaceBadChar("select")
'更新时间：03/26/2009
'作    者：
'说    明：
'==================================================================
Function ReplaceBadChar(strChar)
    If strChar = "" Or IsNull(strChar) Then
        ReplaceBadChar = ""
        Exit Function
    End If
    Dim strBadChar, arrBadChar, tempChar, i
    strBadChar = "+,',%,^,&,?,(,),<,>,[,],{,},/,\,;,:," & Chr(34) & "," & Chr(0) & ",--"
    arrBadChar = Split(strBadChar, ",")
    tempChar = strChar
    For i = 0 To UBound(arrBadChar)
        tempChar = Replace(tempChar, arrBadChar(i), "")
    Next
    tempChar = Replace(tempChar, "@@", "@")
    ReplaceBadChar = tempChar
End Function
'==================================================================
'作    用：计算某个文件的大小
'参    数：tSize：需要计算的文件名
'使用方法：cSize(12333)
'更新时间：03/27/2009
'作    者：
'说    明：
'==================================================================
Function cSize(tSize)
    If tSize>=1073741824 Then
  cSize=Int((tSize/1073741824)*1000)/1000 & " GB"
    ElseIf tSize>=1048576 Then
    cSize=Int((tSize/1048576)*1000)/1000 & " MB"
    ElseIf tSize>=1024 Then
  cSize=int((tSize/1024)*1000)/1000 & " KB"
Else
  cSize=tSize & " B"
End If
End Function
'=====================================================================
'
'==================================================================
'作    用：计算随机数
'参    数：intLength：显示多少位
'使用方法：randomStr(5)
'更新时间：03/27/2009
'作    者：
'说    明：
'==================================================================
Function RandomStr(intLength)
    Dim strSeed, seedLength, pos, Str, i
    strSeed = "abcdefghijklmnopqrstuvwxyz1234567890"
    seedLength = Len(strSeed)
    Str = ""
    Randomize
    For i = 1 To intLength
        Str = Str + Mid(strSeed, Int(seedLength * Rnd) + 1, 1)
    Next
    RandomStr = Str
End Function
'=====================================================================
'
'==================================================================
'作    用：检索字符串是否合法
'参    数：Str：检索的字符串
'使用方法：CheckStr("delete")
'更新时间：03/27/2009
'作    者：
'说    明：主要用于会员注册、登陆等
'==================================================================
Function CheckStr(Str)
    CheckStr=replace(replace(replace(replace(str,"<","<"),">",">"),chr(13),"<br>")," ","")
CheckStr=replace(replace(replace(replace(CheckStr,"'",""),"and",""),"insert",""),"set","")
    CheckStr=replace(replace(replace(replace(CheckStr,"select",""),"update",""),"delete%20from",""),chr(34),""")
End Function
'==================================================================
'作    用：判断是否安全字符串,在注册登录等特殊字段中使用
'参    数：Str：检索的字符串
'使用方法：IsSafeStr("$")
'更新时间：03/27/2009
'作    者：
'说    明：主要用于会员注册、登陆等，有返回值：False
'==================================================================
Function IsSafeStr(str)
Dim s_BadStr, n, i
s_BadStr = "' 　&<>?%,;:()`~!@#$^*{}[]|+-=" & Chr(34) & Chr(9) & Chr(32)
n = Len(s_BadStr)
IsSafeStr = True
For i = 1 To n
  If Instr(str, Mid(s_BadStr, i, 1)) > 0 Then
   IsSafeStr = False
   Exit Function
  End If
Next
End Function
'==================================================================
'作    用：数据库压缩函数
'参    数：
'          dbPath：数据库的路径（物理路径）
'          boolIs97: 如果使用 Access 97 数据库请选择
'          (默认为 Access 2000 数据库)
'使用方法：CompactDB(Server.MapPath("db1.mdb"), ""|True)
'更新时间：03/27/2009
'作    者：
'说    明：操作前最好先备份
'==================================================================
Function CompactDB(dbPath, boolIs97)
Dim fso, Engine, strDBPath
strDBPath = left(dbPath,instrrev(DBPath,"\"))
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(dbPath) Then
  Set Engine = CreateObject("JRO.JetEngine")
  '其实，和在Access中压缩数据库一样，我们仍然调用 JRO 来压缩修复数据库
  '所不同的是在这里我们没有向Access那样采用“先引用”的方式（工具菜单选择引用）
  '而是采用脚本所能使用的“后引用”方式建立 JRO 的实例 CreateObject("JRO.JetEngine")
  If boolIs97 = "True" Then
   Engine.CompactDatabase "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & dbpath,"Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strDBPath & "temp.mdb;" & "Jet OLEDB:Engine Type=" & JET_3X
  Else
   Engine.CompactDatabase "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & dbpath, "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strDBPath & "temp.mdb"
  End If
  '操作完成后将已经缩小体积的数据库 COPY 回原位，覆盖原始文件
  fso.CopyFile strDBPath & "temp.mdb",dbpath
  '删除无用的临时文件
  fso.DeleteFile(strDBPath & "temp.mdb")
  Set fso = nothing
  Set Engine = nothing
  CompactDB = "true"
Else
  CompactDB = "false"
End If
Set Fso = Nothing
End Function
'==================================================================
'作    用：显示系统当前时间
'参    数：无参数
'使用方法：
'更新时间：03/27/2009
'作    者：飘逸的风
'说    明：
'==================================================================
Function Show_DateTime()
Now_Info = Now()
Now_Year = Year(Now_Info)
Now_Month = Month(Now_Info)
Now_Day = Day(Now_Info)
'Now_Hour = Hour(Now_Info)
'Now_Minute = Minute(Now_Info)
'Now_Second = Second(Now_Info)
If Len(Now_Month)<2 Then
    Now_Month="0"&Now_Month
End If
If Len(Now_Day)<2 Then
    Now_Month="0"&Now_Month
End If
Now_WeekDay = WeekDayName(WeekDay(Now_Info))
Show_Now = Now_Year & "年" & Now_Month & "月" & Now_Day & "日" &_
" " & Now_WeekDay
Show_DateTime = Show_Now
End Function
'==================================================================
'作    用：防止外部提交
'参    数：
'使用方法：
'更新时间：03/26/2009
'作    者：飘逸的风
'说    明：如果返回值为True则为外部提交
'==================================================================
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 Function
'==================================================================
'作    用：判断是否是字母、数字、点和下换线
'参    数：
'使用方法：
'更新时间：03/26/2009
'作    者：飘逸的风
'说    明：如果返回值为False则不合法
'==================================================================
Function IsEnNum(Str)
IsEnNum=True
s="0123456789abcdefghijklmnopqrstuvwxyz_."
For i=1 To Len(Str)
  c = LCase(Mid(Str, i, 1))
  If InStr(s, c) <= 0 Then
   IsEnNum=False
   Exit Function
  End If
Next
End Function
'==================================================================
'作    用：字符串Str中是否存在RegStr关键字（常用于限制用户注册）
'参    数：
'使用方法：
'更新时间：03/26/2009
'作    者：飘逸的风
'说    明：如果返回值为True则存在关键字，多个以|分割
'==================================================================
Function ChkUserReg(Str,RegStr)
ChkUserReg=False
If IsNull(Str) Then Exit Function
RegStr1=Split(RegStr,"|")
For i=0 To UBound(RegStr1)
  If Str=RegStr1(i) Then
   ChkUserReg=True
   Exit For
  End If
Next
End Function
'==================================================================
'作    用：ip地址转换为*
'参    数：IpStr：IP地址
'使用方法：Response.Write IpArray("127.0.0.1") 输出：127.0.*.*
'更新时间：03/26/2009
'作    者：飘逸的风
'说    明：根据需要修改成自己想显示的样式
'==================================================================
Function IpArray(IpStr)
dim t,ipx,ipfb
if not isnull(ipstr) then
        t = 0
ipx=""
ipfb = split(ipstr, ".",4)
for t = 0 to 1
  ipx = ipx&ipfb(t)&"."
next
IpArray = ipx&"*.*"
end if
End Function
'==================================================================
'作    用：检测是否有效的E-mail地址
'参    数：
'使用方法：
'更新时间：03/26/2009
'作    者：飘逸的风
'说    明：如果返回值为True则合法
'==================================================================
Function IsValidEmail(Email)
    Dim names, Name, i, c
    IsValidEmail = True
    Names = Split(email, "@")
    If UBound(names) <> 1 Then
        IsValidEmail = False
        Exit Function
    End If
    For Each Name IN names
        If Len(Name) <= 0 Then
            IsValidEmail = False
            Exit Function
        End If
        For i = 1 To Len(Name)
            c = LCase(Mid(Name, i, 1))
            If InStr("abcdefghijklmnopqrstuvwxyz_-.", c) <= 0 And Not IsNumeric(c) Then
                IsValidEmail = False
                Exit Function
            End If
        Next
        If Left(Name, 1) = "." Or Right(Name, 1) = "." Then
            IsValidEmail = False
            Exit Function
        End If
    Next
    If InStr(names(1), ".") <= 0 Then
        IsValidEmail = False
        Exit Function
    End If
    i = Len(names(1)) - InStrRev(names(1), ".")
    If i <> 2 And i <> 3 Then
        IsValidEmail = False
        Exit Function
    End If
    If InStr(email, "..") > 0 Then
        IsValidEmail = False
    End If
End Function
'==================================================================
'作    用：验证码函数
'参    数：
'使用方法：
'更新时间：03/26/2009
'作    者：飘逸的风
'说    明：配合GetCode.asp文件
'          读取验证码方法：Response.Write Session("GetCode")
'==================================================================
Function GetCode()
UrlPath="/inc/getcode.asp"
GetCode= "<img id=""vcodeImg"" src=""about:blank"" onerror=""this.onerror=null;this.src='"&UrlPath&"?s='+Math.random();"" alt=""验证码"" title=""看不清楚?换一张"" style=""margin-right:40px;cursor:pointer;width:40px;height:18px;margin-bottom:-4px;margin-top:3px;"" onclick=""src='"&UrlPath&"?s='+Math.random()""/>"
End Function
'==================================================================
'作    用：关闭数据库连接
'参    数：
'使用方法：
'更新时间：03/26/2009
'作    者：飘逸的风
'说    明：无返回值
'==================================================================
Function CloseDB()
Conn.Close
Set Conn=Nothing
End Function
%>