/*******************************************
功 能：通用客户端脚本
作 者：殷非非
创建日期：2004年9月8日
更新日期：2005年3月18日
版 本：2.0
********************************************/
//一些VBScript里常用的常数
var __CONSTS__=new function ()
{
this.vbOKOnly = 0;；
this.vbOKCancel = 1;；
this.vbAbortRetryIgnore = 2;；
this.vbYesNoCancel = 3;；
this.vbYesNo = 4;；
this.vbRetryCancel = 5;；
this.vbCritical = 16;；
this.vbQuestion = 32;；
this.vbExclamation = 48;；
this.vbInformation = 64;；
this.vbDefaultButton1 = 0;；
this.vbDefaultButton2 = 256;；
this.vbDefaultButton3 = 512;；
this.vbDefaultButton4 = 768;；
this.vbApplicationModal = 0;；
this.vbSystemModal = 4096;；
this.vbOK = 1;；
this.vbCancel = 2;；
this.vbAbort = 3;；
this.vbRetry = 4;；
this.vbIgnore = 5;；
this.vbYes = 6;；
this.vbNo = 7;；
this.vbEmpty = 0;；
this.vbNull = 1;；
this.vbInteger = 2;；
this.vbLong = 3;；
this.vbSingle = 4;；
this.vbDouble = 5;；
this.vbCurrency = 6;；
this.vbDate = 7;；
this.vbString = 8;；
this.vbObject = 9;；
this.vbError = 10;；
this.vbBoolean = 11;；
this.vbVariant = 12;；
this.vbDataObject = 13;；
this.vbDecimal = 14;；
this.vbByte = 17;；
this.vbArray = 8192;；
}
//字符串的一些操作
//去除两端的空格
String.prototype.trim=function (){return this.replace((/(^\s*)|(\s*$)/ig),'');；}
//是否Email字符串
String.prototype.isEmail=function (){return (/^([a-z][a-z0-9\_\.]*[a-z0-9])(@)(([a-z0-9][a-z0-9\-]*[a-z0-9][\.])+(com|cn|net|hk|tw|au|uk|de|tv|info|biz))$/ig).test(this);；}
//检查字符串是否是列表中的一项
// ("test").inList('a','s','asd','sdfs','test','fdgd');；
String.prototype.inList=function(){
for(var iCnt=0;；iCnt〈arguments.length;；iCnt++)
if(this==arguments[iCnt])
return true;；
return false;；}
//字符串的实际长度
String.prototype.binaryLength=function (){return this.replace(/[\u4E00-\u9FA5]|[\uFE30-\uFFA0]/ig,'**').length;；}
//Rect对象
function Rect(){
this.width=0;；
this.height=0;；
this.left=0;；
this.top=0;；
this.right=0;；
this.bottom=0;；
}
Rect.prototype.Cal=function () {
this.right=this.left+this.width;；
this.bottom=this.top+this.height;；
}
Rect.prototype.ContaintPoint=function (x,y){
if(x〉=this.left && x〈=this.right && y〉=this.top && y〈=this.bottom) return true;；
return false;；
}
Rect.prototype.BeCoverBy=function (rectSrc){
return rectSrc.ContaintPoint(this.left,this.top) ||
rectSrc.ContaintPoint(this.left,this.bottom) ||
rectSrc.ContaintPoint(this.right,this.top) ||
rectSrc.ContaintPoint(this.right,this.bottom) ||
this.ContaintPoint(rectSrc.left,rectSrc.top) ||
this.ContaintPoint(rectSrc.right,rectSrc.top) ||
this.ContaintPoint(rectSrc.left,rectSrc.bottom) ||
this.ContaintPoint(rectSrc.right,rectSrc.bottom);；
}
//获取一个HTML对象的RECT属性
function getElementRect(obj){
var e=obj;；
var pos=new Rect;；
pos.width=obj.offsetWidth;；
pos.height=obj.offsetHeight;；
pos.left=obj.offsetLeft;；
pos.top=obj.offsetTop;；
while(e=e.offsetParent){
pos.left+=e.offsetLeft;；
pos.top+=e.offsetTop;；
}
pos.Cal();；
return pos;；
}
//##################################################################################
//检查一个对象是否数组
Object.prototype.isArray=function(){
try{
if(typeof(this)=='object'){
if(typeof(this.length)=='number'){
return true;；
}else{
return false;；
}
}else{
return false;；
}
}catch(e){
return false;；
}
}
//堆栈对象
function Stack(){
this.__DataItem=new Array;；
this.length=0;；
this.__StackPointer=-1;；
}
Stack.prototype.Push=function (data){
this.length++;；
this.__StackPointer++;；
this.__DataItem[this.__StackPointer]=data;；
}
Stack.prototype.Pop=function (){
if(this.length〈=0) return null;；
if(this.__StackPointer〈=-1) return null;；
this.length--;；
this.__StackPointer--;；
return this.__DataItem[this.__StackPointer+1];；
}
Stack.prototype.toString=function (){
try{var chr=arguments[0]}catch(e){var chr=''}finally{
if(typeof(chr)!='string') chr='';；}
if(this.length〈=0) return "";；
var retStr="";；
for(var iCnt=0;；iCnt〈this.length;；iCnt++)
retStr+=this.__DataItem[iCnt]+chr;；
return retStr;；
}
Stack.prototype.Item=function (ind){
if(ind〈0) return null;；
if(ind〉this.__StackPointer) return null;；
return this.__DataItem[ind];；
}
Stack.prototype.Top=function(){
if(this.__StackPointer〈0) return null;；
return this.__DataItem[this.__StackPointer];；
}
//设置QueryString 例如 SetQueryString('index.asp?ID=1&PAGE=2&SIZE=3','PAGE','4')
//SetQueryString(URL模板,索引,值);；
function SetQueryString(urlStr,QName,QValue){
if(urlStr.indexOf('?')〈0){
return urlStr+'?'+QName.toUpperCase()+'='+QValue;；
}else{
if(urlStr.toUpperCase().indexOf(QName.toUpperCase()+'=')〈0){
return urlStr+'&'+QName.toUpperCase()+'='+QValue;；
}else{
var oReg=new RegExp(QName+'\=[^\\&]*','ig');；
return urlStr.replace(oReg,QName.toUpperCase()+'='+QValue);；
}
}
}
//XML操作函数
/*****************************************************************************************
Object CreateXMLParser(void)
创建尽可能高版本的XMLDOM解析器
*****************************************************************************************/
function CreateXMLParser()
{
try{
return new ActiveXObject('MSXML2.DOMDocument.4.0');；
}catch(e){
try{
return new ActiveXObject('MSXML2.DOMDocument.3.0');；
}catch(e){
try{
return new ActiveXObject('MSXML2.DOMDocument.2.6');；
}catch(e){
try{
return new ActiveXObject('MSXML2.DOMDocument');；
}catch(e){
try{
return new ActiveXObject('Microsoft.XMLDOM');；
}catch(e){
return null;；
}
}
}
}
}
}
/*****************************************************************************************
Object CreateHTTPPoster(void)
创建尽可能高版本的XMLHTTP对象
*****************************************************************************************/
function CreateHTTPPoster(){
try{
return new ActiveXObject('MSXML2.XMLHTTP.4.0');；
}catch(e){
try{
return new ActiveXObject('MSXML2.XMLHTTP.3.0');；
}catch(e){
try{
return new ActiveXObject('MSXML2.XMLHTTP.2.6');；
}catch(e){
try{
return new ActiveXObject('MSXML2.XMLHTTP');；
}catch(e){
try{
return new ActiveXObject('Microsoft.XMLHTTP');；
}catch(e){
return null;；
}
}
}
}
}
}
/*****************************************************************************************
IDOMDocument GetXMLWithSession(sUrl,sMethod,vDat)
获取一个带Session的XML文档
+参数列表
sUrl 目标URL
sMethod 获取方式，POST or GET
vData 发送的数据
*只能用同步方式获取
*****************************************************************************************/
function GetXMLWithSession(sUrl,sMethod,vData)
{
var r=/(ASPSESSION.*)\=([^\;；\&]*)/ig;；
r.exec(document.cookie);；
var xmlHttp=CreateHTTPPoster();；
xmlHttp.open(sMethod,sUrl,false);；
xmlHttp.setRequestHeader("Cache-Control", "no-cache");；
xmlHttp.setRequestHeader("Connection", "Keep-Alive");；
xmlHttp.setRequestHeader("Accept", "*/*");；
xmlHttp.setRequestHeader("Accept-Language", "zh-cn");；
xmlHttp.setRequestHeader("Referer", window.top.location.href);；
xmlHttp.setRequestHeader("User-Agent", "Mozilla/4.0 (compatible;； MSIE 6.0;； Windows NT 5.1;； .NET CLR 1.0.3215;； .NET CLR 1.0.3705)");；
xmlHttp.setRequestHeader(RegExp.$1,RegExp.$2);；
xmlHttp.send(URLEncoding(vData));；
if(xmlHttp.status!=200){
if(xmlHttp.status==404){
alert('错误：请求的应用程序不存在');；
xmlHttp=null;；
return null;；
}
if(xmlHttp.status==500){
alert('错误：请求的应用程序发生内部错误');；
xmlHttp=null;；
return null;；
}
alert('发生未知错误，错误类型为 '+xmlHttp.status.toString());；
xmlHttp=null;；
return null;；
}else{
var xmlDom=xmlHttp.responseXML;；
xmlHttp=null;；
if(xmlDom.parseError.errorCode!=0){
alert(xmlDom.parseError.reason);；
xmlDom=null;；
return null;；
}else{
return xmlDom.documentElement;；
}
}
}
/*****************************************************************************************
ClearDropDownList(目标Object，是否保留第一个)
*****************************************************************************************/
function ClearDropDownList(oSel,bolLeaveFirst)
{
if(oSel==null || oSel.tagName.toLowerCase()!='select'){
alert('SELECT控件不存在！\n'+oSel.tagName);；
return;；}
var iLength=oSel.options.length;；
if(bolLeaveFirst)
iTmp=1;；
else
iTmp=0;；
for(iCnt=iLength-1;；iCnt〉=iTmp;；iCnt--)
oSel.options.remove(iCnt);；
oSel=null;；
}
/*****************************************************************************************
IDOMDocument XMLStringToNodeList(String)
将XML字符串转换成NodeList
*****************************************************************************************/
function XMLStringToNodeList(strXml){
var oXml=CreateXMLParser();；
oXml.async=false;；
try{
oXml.loadXML(strXml);；
}catch(e){
oXml=null;；
return null;；
}
var nlTemp=oXml.documentElement;；
oXml=null;；
return nlTemp;；
}
/*****************************************************************************************
NODES GetXMLNodeList(XML文件路径,XPATH选择器)
如：
GetXMLNodeList("/test.xml","//COUNTRY[@CODE='1236']'");；
*****************************************************************************************/
function GetXMLNodeList(strXMLFile,strXPathFilter){
var oDom=CreateXMLParser();；
oDom.async=false;；
oDom.load(strXMLFile);；
if(oDom.parseError.errorCode!=0){
alert('装载XML文档 '+strXMLFile+' 出错了！');；
oDom=null;；
return null;；
}else{
var nodesTemp=oDom.documentElement.selectNodes(strXPathFilter);；
oDom=null;；
if(nodesTemp.length〈1) {
//alert('错误的XMPATH选择器\n'+strXPathFilter);；
return null;；
}
return nodesTemp;；
}
}
/*****************************************************************************************
Integer MessageBox (strMessage,strTitle,intIcon,intButtons,intDefaultButton)
显示VBSctipt样式对话框
*****************************************************************************************/
function MessageBox(strMessage,strTitle,intIcon,intButtons,intDefaultButton)
{
strMessage=strMessage.replace(/\"/g,'""').replace(/\n/g,'" & vbCrLf & "');；
strTitle=strTitle.replace(/\"/g,'""').replace(/\n/g,'" & vbCrLf & "');；
window.Temp=0;；
try{
execScript('Window.Temp=MsgBox("'+strMessage+'",'+(intIcon+intButtons+intDefaultButton).toString()+',"'+strTitle+'")','VBScript');；
return window.Temp;；
}catch(e){
alert(e.description);；
return null;；
}
}
/*****************************************************************************************
void AttachVBFunctionsToWindow (void)
绑定VB常用函数到JScript
在页面中执行此函数以后就可以直接使用URLEcoding/URLDecoding/Bytes2BSTR/VBTypeName/VBVarType等函数
VBTypeName和VBVarType可以更细致地区分各种变量类型
*****************************************************************************************/
function AttachVBFunctionsToWindow()
{
var s=
'Public Function URLEncoding(v)\n'+
' Dim s,t,i,j,h,l,x : s = "" : x=Len(v)\n'+
' For i = 1 To x\n'+
' t = Mid(v,i,1) : j = Asc(t)\n'+
' If j〉 0 Then\n'+
' s = s & t\n'+
' Else\n'+
' If j 〈 0 Then j = j + &H10000\n'+
' h = (j And &HFF00) \\ &HFF\n'+
' l = j And &HFF\n'+
' s = s & "%" & Hex(h) & "%" & Hex(l)\n'+
' End If\n'+
' Next\n'+
' URLEncoding = s\n'+
'End Function\n\n'+
'Public Function URLDecoding(sIn)\n'+
' Dim s,i,l,c,t,n : s="" : l=Len(sIn)\n'+
' For i=1 To l\n'+
' c=Mid(sIn,i,1)\n'+
' If c〈〉"%" Then\n'+
' s = s & c\n'+
' Else\n'+
' c=Mid(sIn,i+1,2) : i=i+2 : t=CInt("&H" & c)\n'+
' If t〈&H80 Then\n'+
' s=s & Chr(t)\n'+
' Else\n'+
' c=Mid(sIn,i+1,3)\n'+
' If Left(c,1)〈〉"%" Then\n'+
' URLDecoding=s\n'+
' Exit Function\n'+
' Else\n'+
' c=Right(c,2) : n=CInt("&H" & c)\n'+
' t=t*256+n-65536\n'+
' s = s & Chr(t) : i=i+3\n'+
' End If\n'+
' End If\n'+
' End If\n'+
' Next\n'+
' URLDecoding=s\n'+
'End Function\n'+
'Public Function Bytes2BSTR(v)\n'+
' Dim r,i,t,n : r = ""\n'+
' For i = 1 To LenB(v)\n'+
' t = AscB(MidB(v,i,1))\n'+
' If t 〈 &H80 Then\n'+
' r = r & Chr(t)\n'+
' Else\n'+
' n = AscB(MidB(v,i+1,1))\n'+
' r = r & Chr(CLng(t) * &H100 + CInt(n))\n'+
' i = i + 1\n'+
' End If\n'+
' Next\n'+
' Bytes2BSTR = r\n'+
'End Function\n'+
'Public Function VBTypeName(chrIn) : VBTypeName=TypeName(chrIn) : End Function\n'+
'Public Function VBVarType(chrIn) : VBVarType=VarType(chrIn) : End Function\n';；
execScript(s,'VBScript');；
}
〈%
'===================================================================================
' 功 能：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
'===================================================================================
' 函数原型： MyFormatNumber (intNumber,stringPrefix,intSize)
' 功 能： 自定义格式化数字
' 参 数： intNumber 整数形，待格式化的数字
' stringPrefix 格式化时使用的前缀
' intSize 格式化以后的整个字符串长度
' 返 回 值： 字符串
' 涉及的表： 无
'===================================================================================
Public Function MyFormatNumber(num,prefix,Size)
Dim iCnt
MyFormatNumber=CStr(num)
If Size〈=Len(MyFormatNumber) Then
Exit Function
End If
For iCnt=1 To Size-Len(MyFormatNumber)
MyFormatNumber=prefix & MyFormatNumber
Next
End Function
'===================================================================================
' 函数原型： SplitFullPath(strFullPath,strSpliter,ByRef strPath,ByRef strFileName,ByRef extName) As FullFileName
' 功 能： 分离路径和文件名
' 参 数： strFullPath 包含路径和文件名的字符串
' strSpliter 路径分隔符(/ 后者 \)
' strPath 保存路径名的变量
' strFileName 保存文件名的变量
' extName 保存文件扩展名的变量
' 返 回 值： 完整的文件(= strFileName & "." & extName)
' 涉及的表： 无
'===================================================================================
Public Function SplitFullPath(strFPath,strSpliter,ByRef strPath,ByRef strFName,ByRef extName)
Dim intTemp0,fnameTemp,intTemp1
intTemp0=InStrRev(strFPath,strSpliter)
strPath=Left(strFPath,intTemp0)
fnameTemp=Right(strFPath,Len(strFPath)-intTemp0)
intTemp1=InStrRev(fnameTemp,".")
strFName=Left(fnameTemp,intTemp1-1)
extName=Right(fnameTemp,Len(fnameTemp)-intTemp1)
SplitFullPath=fnameTemp
End Function
'===================================================================================
' 函数原型： SQLEncode(strSource)
' 功 能： 为SQL语句剔除危险字符
' 参 数： strSource 输入的字符串
' 返 回 值： 将'转换成'',将"转换成""以后的字符串
' 涉及的表： 无
'===================================================================================
Public Function SQLEncode(str)
SQLEncode=Trim(Replace(str,"'","''"))
End Function
'===================================================================================
' 函数原型： DBTrim(strIn)
' 功 能： 防止从数据库里面取出的Null字符串
' 参 数： strIn 输入的字符串
' 返 回 值： 修正以后的字符串
' 涉及的表： 无
'===================================================================================
Public Function DBTrim(strIn)
If IsNull(strIn) Or IsEmpty(strIn) Then
DBTrim = ""
Else
DBTrim = Trim(CStr(strIn))
End If
End Function
'===================================================================================
' 函数原型： UrlFromPageIndex(Url,pInd)
' 功 能： 换页程序中根据当前页面URL和新的页面编号获取新的URL
' 参 数： Url：前页面URL / pInd：页面编号
' 返 回 值： 新的URL
' 涉及的表： 无
'===================================================================================
Public Function UrlFromPageIndex(Url,pInd)
If InStr(Url,"PAGE=") Then
Dim oReg
Set oReg=New RegExp
oReg.Global=True
oReg.IgnoreCase=True
oReg.Pattern ="PAGE=[0-9]+"
If pInd〈0 Then pInd=0
UrlFromPageIndex=oReg.Replace(Url,"PAGE=" & pInd)
Else
If InStr(Url,"?")〉0 Then
UrlFromPageIndex=Url & "&PAGE=" & pInd
Else
UrlFromPageIndex=Url & "?PAGE=" & pInd
End If
End If
End Function
'===================================================================================
' 函数原型： advHTMLEncode(strSource)
' 功 能： 删除HTML格式
' 参 数： strSource 输入的字符串
' 返 回 值： 转换以后的字符串
' 涉及的表： 无
'===================================================================================
Public Function advHTMLEncode(str)
Dim strTemp
strTemp=Replace(str,"&","&；")
strTemp=Replace(strTemp,"〈","<；")
strTemp=Replace(strTemp,"〉",">；")
strTemp=Replace(strTemp,"""",""；")
strTemp=Replace(strTemp," "," ；")
strTemp=Replace(strTemp,Chr(9)," ； ； ； ；")
strTemp=Replace(strTemp,vbCrLf,"chr(13)&Chr(10)")
strTemp=Replace(strTemp,Chr(10),"")
strTemp=Replace(strTemp,Chr(13),"")
advHTMLEncode=strTemp
End Function
'===================================================================================
' 函数原型： IsLeapYear(iYear)
' 功 能： 判断是否闰年
' 参 数： iYear 年份数字
' 返 回 值： 是否
' 涉及的表： 无
'===================================================================================
Public Function IsLeapYear(iYear)
If iYear Mod 400 = 0 Then
IsLeapYear=True
Exit Function
End If
If iYear Mod 4 〈〉 0 Then
IsLeapYear=False
Exit Function
End If
If iYear Mod 100 〈〉 0 Then
IsLeapYear=True
Else
IsLeapYear=False
End If
End Function
'===================================================================================
' 函数原型： DayOfMonth(iYear,iMonth)
' 功 能： 某年某月的天数
' 参 数： iYear 年份数字
' iMonth 月份数字
' 返 回 值： 天数
' 涉及的表： 无
'===================================================================================
Public Function DayOfMonth(iYear,iMonth)
If iMonth=1 Or iMonth=3 Or iMonth=5 Or iMonth=7 Or iMonth=8 Or iMonth=10 Or iMonth=12 Then
DayOfMonth=31
Exit Function
End If
If iMonth=4 Or iMonth=6 Or iMonth=9 Or iMonth=11 Then
DayOfMonth=30
Exit Function
End If
If iMonth=2 Then
If isLeapYear(iYear) Then DayOfMonth=29 :Else: DayOfMonth=28 :End If
Else
DayOfMonth=0
End If
End Function
'===================================================================================
' 函数原型： DuplicateChars(Str,iCnt)
' 功 能： 生成重复的字符
' 参 数： Str 要重复的字符串
' iCnt 重复次数
' 返 回 值： 生成的字符串
' 涉及的表： 无
'===================================================================================
Public Function DuplicateChars(Str,iCnt)
Dim iTmp
DuplicateChars=""
If TypeName(Str)="Number" Or TypeName(Str)="Byte" Or _
TypeName(Str)="Integer" Or TypeName(Str)="Long" Then
Str=Chr(Str)
End If
Str=Left(Str,1)
For iTmp=1 To iCnt
DuplicateChars=DuplicateChars & Str
Next
End Function
'===================================================================================
' 函数原型： SetQueryString(UrlStr,qKey,qValue)
' 功 能： 设置QueryString
' 参 数： UrlStr URL模板
' qKey QueryString段名字
' qValue QueryString段值
' 返 回 值： 生成的URL
' 涉及的表： 无
'===================================================================================
Public Function SetQueryString(UrlStr,qKey,qValue)
If InStr(UrlStr,"?")〈=0 Then
SetQueryString=UrlStr & "?" & qKey & "=" & qValue
Exit Function
End If
If InStr(UCase(UrlStr),"?" & UCase(qKey) & "=")〈=0 And InStr(UCase(UrlStr),"&" & UCase(qKey) & "=")〈=0 Then
SetQueryString=UrlStr & "&" & qKey & "=" & qValue
Exit Function
End If
Dim index1,index2
If InStr(UCase(UrlStr),"&" & UCase(qKey) & "=")〉0 Then
index1=InStr(UCase(UrlStr),"&" & UCase(qKey) & "=")
index2=InStr(index1+1,UCase(UrlStr),"&",1)
If Index2〈=0 Then
SetQueryString=Left(UrlStr,index1-1) & "&" & qKey & "=" & qValue
Else
SetQueryString=Left(UrlStr,index1-1) & "&" & qKey & "=" & qValue & Right(UrlStr,Len(UrlStr)-index2+1)
End If
Else
index1=InStr(UCase(UrlStr),"?" & UCase(qKey) & "=")
index2=InStr(index1+1,UCase(UrlStr),"&",1)
If Index2〈=0 Then
SetQueryString=Left(UrlStr,index1-1) & "?" & qKey & "=" & qValue
Else
SetQueryString=Left(UrlStr,index1-1) & "?" & qKey & "=" & qValue & Right(UrlStr,Len(UrlStr)-index2+1)
End If
End If
End Function
'===================================================================================
' 函数原型： ChangePage(URLTemplete,PageIndex)
' 功 能： 根据URL模板生成新的页面URL
' 参 数： URLTemplete URL模板
' PageIndex 新的页码
' 返 回 值： 生成的URL
' 涉及的表： 无
'===================================================================================
Public Function ChangePage(URLTemplete,PageIndex)
ChangePage=SetQueryString(URLTemplete,"PAGE",PageIndex)
End Function
'===================================================================================
' 函数原型： BuildPath(sPath)
' 功 能： 根据指定的路径创建目录
' 参 数： sPath URL模板
' 返 回 值： 如果成功，返回空字符串，否则返回错误信息和错误位置
' 涉及的表： 无
'===================================================================================
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文档中查找指定节点的值
' 参 数： xmlDom XML文档
' sFilter XPATH定位字符串
' 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文档中查找指定节点的指定属性
' 参 数： xmlDom XML文档
' sFilter XPATH定位字符串
' 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++里面的 ?: 运算符
' 参 数： testExpr Boolean表达式
' value1 testExpr=True 时的取值
' value2 testExpr=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解码码函数
' 参 数： v URL编码的字符串
' 返 回 值： 解码后的字符串
' 涉及的表： 无
'===================================================================================
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
' 参 数： v UTF-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
%〉