本作品来自网络，版权归原作者所有。如有异议，请留言。
****************************************************************
作者: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
%>