服务器端常用函数库
<%
'===================================================================================
' 功 能：StdCall 基本函数库
' 创建时间：2004年4月6日 14:35:58
' 修改时间：2005年3月18日 22:07:24
' 作 者：殷非非
'===================================================================================
'定义超全局变量
Dim URLSelf,URISelf
URISelf=Request.ServerVariables("SCRIPT_NAME")
If Request.QueryString="" Then
URLSelf=URISelf
Else
URLSelf=URISelf & "?" & Request.QueryString
End If
Response.CharSet="GB2312"
Response.Buffer=True
Response.Expires=-1
'===================================================================================
' 函数原型： 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
'===================================================================================
'功 能：正则表达式替换
'参 数：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
