****************************************************************
本作品来自网络，版权归原作者所有。如有异议，请留言。
****************************************************************
作者:CSDN 许仙
'Homepage : jjweb.126.com
'MSN :Coderxu#hotmail.com
'QQ:19030300
'转载请保持文章完整,保存以上作者信息 请珍惜他人劳动成果
'大部分抄的别人的自己只写了几个函数,功能挺有用的 :)

<!--#include file="Conn.asp"-->
<% '公用模块用于存储所以的函数

'Dim r, rst
'Set r = New ClsCurrent
'Set rst = r.OpenRst("Select *")
'ExeSql "Instr .."
'r.NothingRst rst'关闭释放记录集
'set r=nothing

'定义超全局变量
Dim URLSelf, URISelf
URISelf = Request.ServerVariables("SCRIPT_NAME")
If Request.QueryString = "" Then
    URLSelf = URISelf
Else
    URLSelf = URISelf & "?" & Request.QueryString
End If
response.charset="utf-8"
Response.Buffer = True
Response.Expires = -1
'===================================================================================
'   函数原型：Quit
'功    能：中止程序
'参    数：无
'返 回 值：无
'涉及的表：无
'===================================================================================
Sub Quit ()
 Response.End()
End Sub
'===================================================================================
'   函数原型：CheckEmpty(sVar,sInfo)
'功    能：'检查是否为空,若空提示,并退回
'参    数：要显示的消息
'返 回 值：无
'涉及的表：无
'===================================================================================
Public Function CheckEmpty(sVar,sInfo)
 If trim(sVar)<>""Then Exit Function
 MessageBox sInfo & "不能为空!"
 GoBack
 Quit
End Function
'===================================================================================
'   函数原型：  GotoURL (URL)
'功    能：转到指定的URL
'参    数：URL 要跳转的URL
'返 回 值：无
'涉及的表：无
'===================================================================================
Public Function GotoURL(URL)
    Response.Write "<script language=""JavaScript"">location.href='" & URL & "';</script>"
End Function

'===================================================================================
'   函数原型：  MessageBox (Msg)
'功    能：显示消息框
'参    数：要显示的消息
'返 回 值：无
'涉及的表：无
'===================================================================================
Public Function MessageBox(msg)
    msg = Replace(msg, "\", "\\")
    msg = Replace(msg, "'", "\'")
    msg = Replace(msg, """", "\""")
    msg = Replace(msg, vbCrLf, "\n")
    msg = Replace(msg, vbCr, "")
    msg = Replace(msg, vbLf, "")
    Response.Write "<script language=""JavaScript"">alert('" & msg & "');</script>"
End Function

'===================================================================================
'   函数原型：  ReturnValue (bolValue)
'功    能：设置Window对象的返回值：只能是布尔值
'参    数：返回值
'返 回 值：无
'涉及的表：无
'===================================================================================
Public Function ReturnValue(bolValue)
    If bolValue Then
        Response.Write "<script language=""JavaScript"">window.returnValue=true;</script>"
    Else
        Response.Write "<script language=""JavaScript"">window.returnValue=false;</script>"
    End If
End Function

'===================================================================================
'   函数原型：  GoBack (URL)
'功    能：后退
'参    数：无
'返 回 值：无
'涉及的表：无
'===================================================================================
Public Function GoBack()
    Response.Write "<script language=""JavaScript"">history.go(-1);</script>"
End Function

'===================================================================================
'   函数原型：  CloseWindow ()
'功    能：关闭窗口
'参    数：无
'返 回 值：无
'涉及的表：无
'===================================================================================
Public Function CloseWindow()
    Response.Write "<script language=""JavaScript"">window.opener=null;window.close();</script>"
End Function

'===================================================================================
'   函数原型：  RefreshParent ()
'功    能：刷新父框架
'参    数：无
'返 回 值：无
'涉及的表：无
'===================================================================================
Public Function RefreshParent()
    Response.Write "<script language=""JavaScript"">if(parent!=self) parent.location.reload();</script>"
End Function

'===================================================================================
'   函数原型：  RefreshTop ()
'功    能：刷新顶级框架
'参    数：无
'返 回 值：无
'涉及的表：无
'===================================================================================
Public Function RefreshTop()
    Response.Write "<script language=""JavaScript"">if(top!=self) top.location.reload();</script>"
End Function

'===================================================================================
'   函数原型：  GenPassword (intLen,PassMask)
'功    能：生成随机密码
'参    数：intLen新密码长度
'PassMask生成密码的掩码默认为空
'返 回 值：无
'涉及的表：无
'===================================================================================
Public Function GenPassword(intLen, PassMask)
    Dim iCnt, PosTemp
    Randomize
    If PassMask = "" Then
        PassMask = "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789abcdefghijklmnopqrstuvwxyz"
    End If
    For iCnt = 1 To intLen
        PosTemp = Fix(Rnd(1) * (Len(PassMask))) + 1
        GenPassword = GenPassword & Mid(PassMask, PosTemp, 1)
    Next
End Function

'===================================================================================
'   函数原型：  GenSerialString ()
'功    能：生成序列号
'参    数：无
'返 回 值：无
'涉及的表：无
'===================================================================================
Public Function GenSerialString()
    GenSerialString = Year(Now())
    If Month(Now()) < 10 Then
        GenSerialString = GenSerialString & "0"
    End If
    GenSerialString = GenSerialString & Month(Now())
    If Day(Now()) < 10 Then
        GenSerialString = GenSerialString & "0"
    End If
    GenSerialString = GenSerialString & Day(Now())
    If Hour(Now()) < 10 Then
        GenSerialString = GenSerialString & "0"
    End If
    GenSerialString = GenSerialString & Hour(Now())
    If Minute(Now()) < 10 Then
        GenSerialString = GenSerialString & "0"
    End If
    GenSerialString = GenSerialString & Minute(Now())
    If Second(Now()) < 10 Then
        GenSerialString = GenSerialString & "0"
    End If
    GenSerialString = GenSerialString & Second(Now())
    GenSerialString = GenSerialString & GenPassword(6, "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ")
End Function

'===================================================================================
'   函数原型：  ChangePage(URLTemplete,PageIndex)
'功    能：根据URL模板生成新的页面URL
'参    数：URLTempleteURL模板
'               PageIndex新的页码
'返 回 值：生成的URL
'涉及的表：无
'===================================================================================
Public Function ChangePage(URLTemplete, PageIndex)
    ChangePage = SetQueryString(URLTemplete, "PAGE", PageIndex)
End Function
'===================================================================================
'   函数原型：  BuildPath(sPath)
'功    能：根据指定的路径创建目录
'参    数：sPathURL模板
'返 回 值：如果成功，返回空字符串，否则返回错误信息和错误位置
'涉及的表：无
'===================================================================================
Public Function BuildPath(sPath)
    Dim iCnt
    Dim path
    Dim BasePath
    path = Split(sPath, "/")
    If Left(sPath, 1) = "/" Or Left(sPath, 1) = "\" Then
        BasePath = Server.MapPath("/")
    Else
        BasePath = Server.MapPath(".")
    End If
    Dim cPath, oFso
    cPath = BasePath
    BuildPath = ""
    Set oFso = Server.CreateObject("Scripting.FileSystemObject")
    For iCnt = LBound(path) To UBound(path)
        If Trim(path(iCnt)) <> "" Then
            cPath = cPath & "\" & Trim(path(iCnt))
            If Not oFso.FolderExists(cPath) Then
                On Error Resume Next
                oFso.CreateFolder cPath
                If Err.Number <> 0 Then
                    BuildPath = Err.Description & "[" & cPath & "]"
                    Exit For
                End If
                On Error GoTo 0
            End If
        End If
    Next
    Set oFso = Nothing
End Function

'===================================================================================
'   函数原型：  GetUserAgentInfo(ByRef vSoft,ByRef vOs)
'功    能：获取客户端操作系统和浏览器信息
'参    数：vSoft浏览器信息
'vOs操作系统信息
'返 回 值：无
'涉及的表：无
'===================================================================================
Public Function GetUserAgentInfo(ByRef vSoft, ByRef vOs)
    Dim theSoft
    theSoft = Request.ServerVariables("HTTP_USER_AGENT")
    ' 浏览器
    If InStr(theSoft, "NetCaptor") Then
        vSoft = "NetCaptor"
    ElseIf InStr(theSoft, "MSIE 6") Then
        vSoft = "MSIE 6.0"
    ElseIf InStr(theSoft, "MSIE 5.5+") Then
        vSoft = "MSIE 5.5"
    ElseIf InStr(theSoft, "MSIE 5") Then
        vSoft = "MSIE 5.0"
    ElseIf InStr(theSoft, "MSIE 4") Then
        vSoft = "MSIE 4.0"
    ElseIf InStr(theSoft, "Netscape") Then
        vSoft = "Netscape"
    ElseIf InStr(theSoft, "Opera") Then
        vSoft = "Opera"
    Else
        vSoft = "Other"
    End If
    ' 操作系统
    If InStr(theSoft, "Windows NT 5.0") Then
        vOs = "Windows 2000"
    ElseIf InStr(theSoft, "Windows NT 5.1") Then
        vOs = "Windows XP"
    ElseIf InStr(theSoft, "Windows NT 5.2") Then
        vOs = "Windows 2003"
    ElseIf InStr(theSoft, "Windows NT") Then
        vOs = "Windows NT"
    ElseIf InStr(theSoft, "Windows 9") Then
        vOs = "Windows 9x"
    ElseIf InStr(theSoft, "unix") Then
        vOs = "Unix"
    ElseIf InStr(theSoft, "linux") Then
        vOs = "Linux"
    ElseIf InStr(theSoft, "SunOS") Then
        vOs = "SunOS"
    ElseIf InStr(theSoft, "BSD") Then
        vOs = "BSD"
    ElseIf InStr(theSoft, "Mac") Then
        vOs = "Mac"
    Else
        vOs = "Other"
    End If
End Function
'===================================================================================
'   函数原型：  GetRegexpObject()
'功    能：获得一个正则表达式对象
'参    数：无
'返 回 值：正则表达式对象
'涉及的表：无
'===================================================================================
Public Function GetRegExpObject(sPattern)
    Dim r: Set r = New RegExp
    r.Global = True
    r.IgnoreCase = True
    r.MultiLine = True
    r.Pattern = sPattern
    Set GetRegExpObject = r
    Set r = Nothing
End Function
'===================================================================================
'   函数原型：  RegExpTest(pattern,string)
'功    能：正则表达式检测
'参    数：pattern模式字符串
'string待检查的字符串
'返 回 值：是否匹配
'涉及的表：无
'===================================================================================
Public Function RegExpTest(p, s)
    Dim r
    Set r = GetRegExpObject(p)
    RegExpTest = r.Test(s)
    Set r = Nothing
End Function
'===================================================================================
'   函数原型：  RegExpReplace(sSource,sPattern,sRep)
'功    能：正则表达式替换
'参    数：sSource要替换的源字符串
'sPattern模式字符串
'sRep要替换的目标字符串
'返 回 值：替换后的字符串
'涉及的表：无
'===================================================================================
Public Function RegExpReplace(sSource, sPattern, sRep)
    Dim r: Set r = GetRegExpTest(sPattern)
    RegExpReplace = r.Replace(sSource, sRep)
    Set r = Nothing
End Function
'===================================================================================
'   函数原型：  CreateXMLParser()
'功    能：创建一个尽可能高版本的XMLDOM
'参    数：无
'返 回 值：IDOMDocument对象
'涉及的表：无
'===================================================================================
Public Function CreateXMLParser()
    On Error Resume Next
    Set CreateXMLParser = Server.CreateObject("MSXML2.DOMDocument.4.0")
    If Err.Number <> 0 Then
        Err.Clear
        Set CreateXMLParser = Server.CreateObject("MSXML2.DOMDocument.3.0")
        If Err.Number <> 0 Then
            Err.Clear
            Set CreateXMLParser = Server.CreateObject("MSXML2.DOMDocument.2.6")
            If Err.Number <> 0 Then
                Err.Clear
                Set CreateXMLParser = Server.CreateObject("MSXML2.DOMDocument")
                If Err.Number <> 0 Then
                    Err.Clear
                    Set CreateXMLParser = Server.CreateObject("Microsoft.XMLDOM")
                    If Err.Number <> 0 Then
                        Err.Clear
                        Set CreateXMLParser = Nothing
                    Else
                        Exit Function
                    End If
                Else
                    Exit Function
                End If
            Else
                Exit Function
            End If
        Else
            Exit Function
        End If
    Else
        Exit Function
    End If
    On Error GoTo 0
End Function

'===================================================================================
'   函数原型：  CreateHTTPPoster()
'功    能：创建一个尽可能高版本的XMLHTTP
'参    数：ServerOrClient创建ServerXMLHTTP还是XMLHTTP
'返 回 值：IXMLHTTP对象
'涉及的表：无
'===================================================================================
Public Function CreateHTTPPoster(soc)
    Dim s
    If soc Then
        s = "ServerXMLHTTP"
    Else
        s = "XMLHTTP"
    End If
    On Error Resume Next
    Set CreateHTTPPoster = Server.CreateObject("MSXML2." & s & ".4.0")
    If Err.Number <> 0 Then
        Err.Clear
        Set CreateHTTPPoster = Server.CreateObject("MSXML2." & s & ".3.0")
        If Err.Number <> 0 Then
            Err.Clear
            Set CreateHTTPPoster = Server.CreateObject("MSXML2." & s)
            If Err.Number <> 0 Then
                Set CreateHTTPPoster = Nothing
            Else
                Exit Function
            End If
        Else
            Exit Function
        End If
    Else
        Exit Function
    End If
    On Error GoTo 0
End Function
'===================================================================================
'   函数原型：  XMLThrowError (errCode,errReason)
'功    能：抛出一个XML错误消息
'参    数：errCode错误编码
'errReason错误原因
'返 回 值：无
'涉及的表：无
'===================================================================================
Public Sub XMLThrowError(errCode, errReason)
    Response.Clear
    Response.ContentType = "text/xml"
    Response.Write "<?xml version=""1.0"" encoding=""gb2312"" standalone=""yes"" ?>" & vbCrLf & _
    "<ERROR CODE=""" & errCode & """ REASON=""" & errReason & """ />" & vbCrLf
    Response.Flush
    Response.End
End Sub
'===================================================================================
'   函数原型：  GetXMLNodeValue(ByRef xmlDom,sFilter,sDefValue)
'功    能：从一个XML文档中查找指定节点的值
'参    数：xmlDomXML文档
'sFilterXPATH定位字符串
'sDefValue默认值
'返 回 值：无
'涉及的表：无
'===================================================================================
Public Function GetXMLNodeValue(ByRef xmlDom, sFilter, sDefValue)
    Dim oNode: Set oNode = xmlDom.selectSingleNode(sFilter)
    If TypeName(oNode) = "Nothing" Or TypeName(oNode) = "Null" Or TypeName(oNode) = "Empty" Then
        GetXMLNodeValue = sDefValue
        Set oNode = Nothing
    Else
        GetXMLNodeValue = Trim(oNode.Text)
        Set oNode = Nothing
    End If
End Function
'===================================================================================
'   函数原型：  GetXMLNodeAttribute(ByRef xmlDom,sFilter,sName,sDefValue)
'功    能：从一个XML文档中查找指定节点的指定属性
'参    数：xmlDomXML文档
'sFilterXPATH定位字符串
'sName要查询的属性名称
'sDefValue默认值
'返 回 值：无
'涉及的表：无
'===================================================================================
Public Function GetXMLNodeAttribute(ByRef xmlDom, sFilter, sName, sDefValue)
    Dim oNode: Set oNode = xmlDom.selectSingleNode(sFilter)
    If TypeName(oNode) = "Nothing" Or TypeName(oNode) = "Null" Or TypeName(oNode) = "Empty" Then
        GetXMLNodeAttribute = sDefValue
        Set oNode = Nothing
    Else
        Dim pTemp: Set pTemp = oNode.getAttribute(sName)
        If TypeName(pTemp) = "Nothing" Or TypeName(pTemp) = "Null" Or TypeName(pTemp) = "Empty" Then
            GetXMLNodeAttribute = sDefValue
            Set oNode = Nothing
            Set pTemp = Nothing
        Else
            GetXMLNodeAttribute = Trim(pTemp.Value)
            Set oNode = Nothing
            Set pTemp = Nothing
        End If
    End If
End Function
'===================================================================================
'   函数原型：  GetQueryStringNumber (FieldName,defValue)
'功    能：从QueryString获取一个整数
'参    数：FieldName参数名
'defValue默认值
'返 回 值：无
'涉及的表：无
'===================================================================================
Public Function GetQueryStringNumber(FieldName, defValue)
    Dim r: r = Request.QueryString(FieldName)
    If r = "" Then
        GetQueryStringNumber = defValue
        Exit Function
    Else
        If Not IsNumeric(r) Then
            GetQueryStringNumber = defValue
            Exit Function
        Else
            On Error Resume Next
            r = CDbl(r)
            If Err.Number <> 0 Then
                Err.Clear
                GetQueryStringNumber = defValue
                Exit Function
            Else
                GetQueryStringNumber = r
            End If
            On Error GoTo 0
        End If
    End If
End Function
'===================================================================================
'   函数原型：  IIf (testExpr,value1,value2)
'功    能：相当于C/C++里面的 ?: 运算符
'参    数：testExprBoolean表达式
'value1testExpr=True 时的取值
'value2testExpr=False 时的取值
'返 回 值：如果testExpr为True返回value1否则返回value2
'涉及的表：无
'说    明：VBScript里没有Iif函数
'===================================================================================
Public Function IIf(testExpr, value1, value2)
    If testExpr = True Then
        IIf = value1
    Else
        IIf = value2
    End If
End Function

'===================================================================================
'   函数原型：  URLEncoding (v,f)
'功    能：URL编码函数
'参    数：v中英文混合字符串
'f是否对ASCII字符编码
'返 回 值：编码后的ASC字符串
'涉及的表：无
'===================================================================================
Public Function URLEncoding(v, f)
    Dim s, t, i, j, h, l, x: s = "": x = Len(v)
    For i = 1 To x
        t = Mid(v, i, 1): j = Asc(t)
        If j > 0 Then
            If f Then
                s = s & "%" & Right("00" & Hex(Asc(t)), 2)
            Else
                s = s & t
            End If
        Else
            If j < 0 Then j = j + &H10000
            h = (j And &HFF00) \ &HFF
            l = j And &HFF
            s = s & "%" & Hex(h) & "%" & Hex(l)
        End If
    Next
    URLEncoding = s
End Function
'===================================================================================
'   函数原型：  URLDecoding (sIn)
'功    能：URL解码码函数
'参    数：vURL编码的字符串
'返 回 值：解码后的字符串
'涉及的表：无
'===================================================================================
Public Function URLDecoding(sIn)
    Dim s, i, l, c, t, n: s = "": l = Len(sIn)
    For i = 1 To l
        c = Mid(sIn, i, 1)
        If c <> "%" Then
            s = s & c
        Else
            c = Mid(sIn, i + 1, 2): i = i + 2: t = CInt("&H" & c)
            If t < &H80 Then
                s = s & Chr(t)
            Else
                c = Mid(sIn, i + 1, 3)
                If Left(c, 1) <> "%" Then
                    URLDecoding = s
                    Exit Function
                Else
                    c = Right(c, 2): n = CInt("&H" & c)
                    t = t * 256 + n - 65536
                    s = s & Chr(t): i = i + 3
                End If
            End If
        End If
    Next
    URLDecoding = s
End Function
'===================================================================================
'   函数原型：  Bytes2BSTR (v)
'功    能：UTF-8编码转换到正常的GB2312
'参    数：vUTF-8编码字节流
'返 回 值：解码后的字符串
'涉及的表：无
'===================================================================================
Public Function Bytes2BSTR(v)
    Dim r, i, t, n: r = ""
    For i = 1 To LenB(v)
        t = AscB(MidB(v, i, 1))
        If t < &H80 Then
            r = r & Chr(t)
        Else
            n = AscB(MidB(v, i + 1, 1))
            r = r & Chr(CLng(t) * &H100 + CInt(n))
            i = i + 1
        End If
    Next
    Bytes2BSTR = r
End Function

 %>