伺服器函數

<%
'===================================================================================
' 功    能：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
'===================================================================================
'   函數原型：  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
%>
posted