hx_system.asp

带OA办公的动态源码网站

						v=eval("&h"+Mid(enStr,i+1,2)+Mid(enStr,i+4,2))
						deStr=deStr&chr(v)
						i=i+5
						else
						v=eval("&h"+Mid(enStr,i+1,2)+cstr(hex(asc(Mid(enStr,i+3,1)))))
						deStr=deStr&chr(v)
						i=i+3 
						end if
					else
						destr=destr&c
					end if
				end if
			else
				if c="+" then
					deStr=deStr&" "
				else
					deStr=deStr&c
				end if
			end if
		next
		URLDecode=deStr
	End Function




	'显示"上一页 下一页":链接地址,总数,页数,是否显示总数,是否用下拉列表跳转,单位
	Public Function PageControl(iCount,pagecount,page,table_style,font_style,colspan)
'生成上一页下一页链接
    Dim query, a, x, temp
    action = "http://" & Request.ServerVariables("HTTP_HOST") & Request.ServerVariables("SCRIPT_NAME")

    query = Split(Request.ServerVariables("QUERY_STRING"), "&")
    For Each x In query
        a = Split(x, "=")
        If StrComp(a(0), "page", vbTextCompare) <> 0 Then
            temp = temp & a(0) & "=" & a(1) & "&"
        End If
    Next
   if colspan=0 then
   Response.Write("<table " & Table_style & ">" & vbCrLf ) 
   end if      
    Response.Write("<TR><TD align=right bgcolor=ffffff colspan="&colspan&" height=25>" & vbCrLf )
    Response.Write(font_style & vbCrLf )            
    if page<=1 then
        Response.Write ("首页 " & vbCrLf)        
        Response.Write ("上页 " & vbCrLf)
    else        
        Response.Write("<A HREF=" & action & "?" & temp & "Page=1>首页</A> " & vbCrLf)
        Response.Write("<A HREF=" & action & "?" & temp & "Page=" & (Page-1) & ">上页</A> " & vbCrLf)
    end if

    if page>=pagecount then
        Response.Write ("下页 " & vbCrLf)
        Response.Write ("尾页 " & vbCrLf)            
    else
        Response.Write("<A HREF=" & action & "?" & temp & "Page=" & (Page+1) & ">下页</A> " & vbCrLf)
        Response.Write("<A HREF=" & action & "?" & temp & "Page=" & pagecount & ">尾页</A> " & vbCrLf)            
    end if

    Response.Write(" 页次：" & page & "/" & pageCount & "页" &  vbCrLf)
    Response.Write(" 共有" & iCount & "条" &  vbCrLf)
    Response.Write("</TD>" & vbCrLf )                
    Response.Write("</TR>" & vbCrLf )        
    if colspan=0 then
	Response.Write("</table>" & vbCrLf )
	end if        
	End Function
	Public Function ChecKIPlock(ip)     
 	   num_ip=IpEncode(ip)		    
       set rs=WS_S.HX_SetRSD("WS_LOID","HX_lockip"," where int(WS_Startip)<="&num_ip&" and int(WS_Endip)>=" & num_ip)
	    if rs.recordcount>0 then
		  Call WS_S.HX_RSClose(rs)	    
	      Call HX_GoBack("你所在网段已被封锁。可能该网段有人捣乱，请联系管理员！","")
	    end if		
        Call WS_S.HX_RSClose(rs)
    end function
	function IpDecode(byval uip)
	 if trim(uip)="" or not isnumeric(uip) then
		IpDecode=0
	  else
		uip=Cdbl(uip)
		dim ary_ip(3)
        ary_ip(0)=fix(uip/16777216)
        ary_ip(1)=fix((uip-ary_ip(0)*16777216)/65536)
        ary_ip(2)=fix((uip-fix(uip/65536)*65536)/256)
        uip=uip-fix(uip/65536)*65536
        ary_ip(3)=fix(uip-fix(uip/256)*256)
        IpDecode=join(ary_ip,".")
	  end if
    end function

   function IpEncode(byval uip)
	 if isnull(uip) or uip="" then
		IpEncode=0
	  else
		dim ary_ip,n
		ary_ip=split(trim(uip),".")
		n=ubound(ary_ip)
		if n=3 then
			IpEncode=ary_ip(0)*256*256*256+ary_ip(1)*65536+ary_ip(2)*256+ary_ip(3)
		else
			IpEncode=0
		end if
	 end if
   end function
	'取得带端口的URL
	Public Function Get_ScriptNameUrl()
		If request.servervariables("SERVER_PORT")="80" Then
			Get_ScriptNameUrl="http://" & request.servervariables("server_name")&replace(lcase(request.servervariables("script_name")),ScriptName,"")
		Else
			Get_ScriptNameUrl="http://" & request.servervariables("server_name")&":"&request.servervariables("SERVER_PORT")&replace(lcase(request.servervariables("script_name")),ScriptName,"")
		End If
	End Function
	' 转为根路径格式
	Public Function RelativePath2RootPath(url)
		Dim sTempUrl
		sTempUrl = url
		If Left(sTempUrl, 1) = "/" Then
			RelativePath2RootPath = sTempUrl
			Exit Function
		End If
		Dim sNowPath
		sNowPath = Request.ServerVariables("SCRIPT_NAME")
		sNowPath = Left(sNowPath, InstrRev(sNowPath, "/") - 1)
		Do While Left(sTempUrl, 3) = "../"
			sTempUrl = Mid(sTempUrl, 4)
			sNowPath = Left(sNowPath, InstrRev(sNowPath, "/") - 1)
		Loop
		RelativePath2RootPath = sNowPath & "/" & sTempUrl
	End Function
	' 根路径转为带域名全路径格式
	Public Function RootPath2DomainPath(url)
		Dim sHost, sPort
		sHost = Split(Request.ServerVariables("SERVER_PROTOCOL"), "/")(0) & "://" & Request.ServerVariables("HTTP_HOST")
		sPort = Request.ServerVariables("SERVER_PORT")
		If sPort <> "80" Then sHost = sHost & ":" & sPort
		RootPath2DomainPath = sHost & url
	End Function

	Public Function GetSize(size,unit)
		if isEmpty(size) or Not Isnumeric(size) then Exit Function
		size=CheckUnit(size,unit)
 		if size>1024 then
 			size=(size/1024)
 			getsize=formatnumber(size,2) & " MB"
		else
		    if size>0 then
			getsize=formatnumber(size,2) & " KB"	
			else
			getsize="0.00 KB"
			end if		
			Exit Function
 		end if
 		if size>1024 then
 			size=(size/1024)
 			getsize=formatnumber(size,2) & " GB"
 		end if
	End Function
	Public Function CheckUnit(size,unit)
		Select Case Lcase(Unit)
		Case "b"
			CheckUnit = formatnumber(size/1024,2)
		Case "k"
			CheckUnit = size
		Case "m"
			CheckUnit = (size*1024)
		Case "g"
			CheckUnit = (size*1024*1024)
		Case Else
			CheckUnit = size
		End Select
	End Function
	Public Sub DelFiles(strFiles)
		if strFiles="" then Exit Sub
		dim fso,arrFiles,i
		On Error Resume Next
		Err=0
		Set fso = CreateObject("scripting.FileSystemObject")
			if fso.FileExists(server.MapPath(strFiles)) then
				fso.DeleteFile(server.MapPath(strFiles))
				if 0=Err then
					Response.write "<br>清除文件（"&strFiles&"）成功！"
				else
					Response.write "<br>清除文件（"&strFiles&"）失败！"
				end if
			end if
		Set fso = Nothing
		Err=0
	End Sub
	Public Sub DownloadFile(strFile,sReName)
		On error resume next
		Server.ScriptTimeOut=999999
		Dim S,fso,f,intFilelength,strFilename
		strFilename = server.MapPath(strFile)
		Response.Clear
		Set s = Server.CreateObject("Adodb." & "Str" & "eam") 
		s.Open
		s.Type = 1 
		Set fso = Server.CreateObject("scripting.FileSystemObject") 		
		If Not fso.FileExists(strFilename) Then
			Response.Write("<h1>错误: </h1><br>系统找不到指定文件！<a href='javascript:history.go(-1)'><font color=red>点此返回</font></a>吧！")
			Exit Sub		
		End If
		Set f = fso.GetFile(strFilename)
		intFilelength = f.size
		s.LoadFromFile(strFilename)
		If err Then
		 	Response.Write("<h1>错误: </h1>" & err.Description & "<p>")
			Response.End 
		End If
		Set fso=Nothing
		Dim Data
		Data=s.Read
		s.Close
		Set s=Nothing
		If Response.IsClientConnected Then 
			Response.AddHeader "Content-Disposition", "attachment; filename="&ReplaceBadChar(sReName)&"."&GetDownLoadFileExt(f.name)
			Response.AddHeader "Content-Length", intFilelength 
 			Response.CharSet = "UTF-8" 
			Response.ContentType = "application/octet-stream"
			Response.BinaryWrite Data
			Response.Flush
		End If
	End Sub
	Public Function GetDownLoadFileExt(strFile)
		GetDownLoadFileExt="rar"
		Dim strExt
		if Isnull(strFile) then Exit Function
		if Instr(strFile,".")<=0 then Exit Function
		strExt=Split(strFile,".")
		GetDownLoadFileExt=strExt(Ubound(strExt))
	End Function
    Public Function ReplaceBadChar(strChar)
		strChar=replace(replace(strChar," ",""),"'","")
		strChar=replace(replace(strChar,".",""),"<","")
		strChar=replace(replace(strChar,")",""),"(","")
		strChar=replace(replace(strChar,"?",""),"*","")
		strChar=replace(replace(strChar,"/",""),"\","")
		ReplaceBadChar=replace(strChar,Chr(0),"")
	End Function
	Public Function HTMLEncode(fString)
		If Not IsNull(fString) then
		fString = replace(fString, ">", "&gt;")
		fString = replace(fString, "<", "&lt;")
		fString = replace(fString, "&", "&amp;")
		fString = Replace(fString, CHR(32), "&nbsp;")
		fString = Replace(fString, CHR(9), "&nbsp;")
		fString = Replace(fString, CHR(34), "&quot;")
		fString = Replace(fString, CHR(39), "&#39;")
		fString = Replace(fString, CHR(13), "")
		fString = Replace(fString, CHR(10) & CHR(10), "</P><P> ")
		fString = Replace(fString, CHR(10), "<BR> ")
		HTMLEncode = fString
		End If
	End Function

	Public Function HTMLCode(fString)
		If Not IsNull(fString) then
		fString = replace(fString, "&gt;", ">")
		fString = replace(fString, "&lt;", "<")
		fString = Replace(fString,  "&nbsp;"," ")
		fString = Replace(fString, "&quot;", CHR(34))
		fString = Replace(fString, "&#39;", CHR(39))
		fString = Replace(fString, "</P><P> ",CHR(10) & CHR(10))
		fString = Replace(fString, "<BR> ", CHR(10))
		HTMLCode = fString
		End If
	End Function

	Public Function NoHtml(str)
		if not isnull(str) then
		dim re
		Set re=new RegExp
		re.IgnoreCase =true
		re.Global=True
		re.Pattern="(\<.[^\<]*\>)"
		str=re.replace(str," ")
		re.Pattern="(\<\/[^\<]*\>)"
		str=re.replace(str," ")
		NoHtml=str
		Set re=Nothing
		End if
	End Function

	'sContent（要转换的数据字符串）
	'sFilters（要过滤掉的格式集，用"|"分隔多个）
	Public Function DeCode(sContent, sFilters)
		Dim a_Filter, i, s_Result, s_Filters
		Decode = sContent
		If IsNull(sContent) or IsNull(sFilters) Then Exit Function
		If sContent = "" or sFilters = "" Then Exit Function
		s_Result  = sContent
		s_Filters = sFilters
		If InStr(s_Filters,"|")>0 then
			a_Filter = Split(s_Filters, "|")
			For i = 0 To UBound(a_Filter)
				s_Result = DecodeFilter(s_Result, a_Filter(i))
			Next
		Else
			s_Result = DecodeFilter(s_Result, s_Filters)
		End If
		DeCode = s_Result
	End Function

	Public Function DecodeFilter(sContent, sFilter)
		Dim regEx
		Set regEx = New RegExp
		regEx.IgnoreCase = True
		regEx.Global	 = True
		Select Case Ucase(sFilter)
		Case "SCRIPT"'去除所有客户端脚本javascipt,vbscript,jscript,js,vbs,event,...
			regEx.Pattern	= "</?script[^>]*>"
			sContent		= regEx.replace(sContent,"")
			regEx.Pattern	= "(javascript|jscript|vbscript|vbs):"
			sContent		= regEx.replace(sContent,"$1：")
			regEx.Pattern	= "on(mouse|exit|error|click|key)"
			sContent		= regEx.replace(sContent,"<I>on$1</I>")
		Case "OBJECT"'去除对象<object><param><embed></object>
			regEx.Pattern	= "</?object[^>]*>"
			sContent		= regEx.replace(sContent,"")
			regEx.Pattern	= "</?param[^>]*>"
			sContent		= regEx.replace(sContent,"")
			regEx.Pattern	= "</?embed[^>]*>"
			sContent		= regEx.replace(sContent,"")
		Case "TABLE"'去除表格<table><tr><td><th>
			regEx.Pattern	= "</?table[^>]*>"
			sContent		= regEx.replace(sContent,"")
			regEx.Pattern	= "</?tr[^>]*>"
			sContent		= regEx.replace(sContent,"")
			regEx.Pattern	= "</?th[^>]*>"
			sContent		= regEx.replace(sContent,"")
			regEx.Pattern	= "</?td[^>]*>"
			sContent		= regEx.replace(sContent,"")
		Case "CLASS"'去除样式类class=""
			regEx.Pattern	= "(<[^>]+) class=[^ |^>]*([^>]*>)"
			sContent		= regEx.replace(sContent,"$1 $2")
		Case "STYLE"'去除样式style=""
			regEx.Pattern	= "(<[^>]+) style=\""[^\""]*\""([^>]*>)"
			sContent		= regEx.replace(sContent,"")
		Case "XML"'去除XML<?xml>
			regEx.Pattern	= "<\\?xml[^>]*>"
			sContent		= regEx.replace(sContent,"")
		Case "NAMESPACE"'去除命名空间<o:p></o:p>
			regEx.Pattern	= "<\/?[a-z]+:[^>]*>"