网站来路分析统计系统代码,ASP代码库,德仔网

代码语言
代码分类
【ASP】网站来路分析统计系统
作者:Dezai.CN / 发布于2013/7/16/ 1798

	正文开始：

	whbcount.asp文件。

	<!--Copyright Infor
	//Author: whb
	//Time : 2009-3-26
	//保留一切权利，All rights reserved.
	-->
	<%
	 dim conn,connstr
	 Set conn = Server.CreateObject("ADODB.Connection")
	 connstr="driver={SQL Server};server=60.208.73.199;uid=sa;pwd=1234;database=WHB"
	 conn.Open connstr
	 If Err Then
	Err.Clear
	Set conn = Nothing
	Response.Write "数据库连接文件出错，请联系管理员。"
	Response.End
	 End If
	%>
	<%
	'定义统计类
	Class WhbCount

	private IPinfor
	private Addr
	private ComePath
	private Keywords
	private prevurl '来访前所在网页路径
	private presenthtm '来访时所浏览的本站页面


	'定义WhbCount类的相关属性=======================

	Public Property Get IP '来访所用IP
	IP= IPinfor
	End Property

	Public Property Get Address '来访所用IP
	Address= Addr
	End Property

	Public Property Get URL '来访时所浏览的本站页面
	URL= presenthtm
	End Property

	Public Property Get Comeurl '来访时所浏览的本站页面
	Comeurl= prevurl
	End Property

	Public Property Get Engine '来访所用引擎名称
	Engine= ComePath
	End Property

	Public Property Get Keyword '来访时所用关键字
	Keyword= Keywords
	End Property

	'四个类属性定义完毕。=============================

	'函数功能：获得来访客户真实IP地址，判断是否代理
	Function GetIP()
	dim realip,proxy
	realip = Request.ServerVariables("HTTP_X_FORWARDED_FOR")
	proxy = Request.ServerVariables("REMOTE_ADDR")
	if realip = "" then
	 IPinfor = proxy
	else
	 IPinfor = realip
	end if
	End Function

	'函数功能：获得来访客户真实物理地址，判断是否代理
	Function GetAddress(ByVal sip)
	Dim str1,str2,str3,str4
	Dim num
	Dim irs
	If isnumeric(left(sip,2)) Then
	 If sip="127.0.0.1" Then
	 Addr="本机环路IP地址"
	 Exit Function
	 End if
	 'response.Write IPinfor
	 'response.end
	 str1=left(sip,instr(sip,".")-1)
	 sip=mid(sip,instr(sip,".")+1)
	 str2=left(sip,instr(sip,".")-1)
	 sip=mid(sip,instr(sip,".")+1)
	 str3=left(sip,instr(sip,".")-1)
	 str4=mid(sip,instr(sip,".")+1)
	 If isNumeric(str1)=0 Or isNumeric(str2)=0 Or isNumeric(str3)=0 Or isNumeric(str4)=0 Then
	 Else
	 num=cint(str1)*256*256*256+cint(str2)*256*256+cint(str3)*256+cint(str4)-1
	 sql="select * from webcount_ip where StartIP <="&num&" and EndIP >="&num
	 Set irs=conn.Execute(sql)
	 If irs.eof And irs.bof Then
	 Addr="未能解析IP地址"
	 Else
	 Do While Not irs.eof
	 Addr=Addr &irs("pos") & irs("Detail")
	 irs.movenext
	 Loop
	 End If
	 irs.close
	 Set irs=nothing
	 End If
	Else
	 getaddress="无效IP地址"
	End If
	End Function

	'函数功能：获得访客所访问的页面路径，既当前页面完整路径。
	Function GetUrl()
	 Dim strTemp
	'If LCase(Request.ServerVariables("HTTPS")) = "off" Then
	'strTemp = "http://"
	'Else
	'strTemp = "https://"
	'End If
	 strTemp = strTemp & Request.ServerVariables("SERVER_NAME")
	 If Request.ServerVariables("SERVER_PORT") <> 80 Then strTemp = strTemp & ":" & Request.ServerVariables("SERVER_PORT")
	 strTemp = strTemp & Request.ServerVariables("URL")
	 If Trim(Request.QueryString) <> "" Then strTemp = strTemp & "?" & Trim(Request.QueryString)
	 presenthtm = strTemp
	End Function

	'函数功能：获得访客来访前的页面路径
	Function GetComeurl()
	 Dim strTemp
	 if(Request.ServerVariables("HTTP_REFERER"))="" then
	 prevurl="#"
	 else
	 prevurl=Request.ServerVariables("HTTP_REFERER")
	 end if
	End Function

	'函数功能：得到关键字的汉字形式。
	Function GetKeywords(URLStr)
	Dim Encodestyle 'URL编码格式
	if len(URLStr)=0 then
	ComePath="其他"
	Keywords="其他"
	exit Function
	end if
	if InStr(URLStr,"google.")>0 then
	 ComePath="谷歌"
	 Encodestyle="utf8"
	 whbarray=split(URLStr,"q=")
	 whbarray2=split(whbarray(1),"&")
	elseif InStr(URLStr,"baidu.")>0 and InStr(URLStr,"word=")>0 then'百度URL有两种
	 ComePath="百度"
	 Encodestyle="gb2312"
	 whbarray=split(URLStr,"word=")
	 whbarray2=split(whbarray(1),"&")
	elseif InStr(URLStr,"baidu.")>0 and InStr(URLStr,"wd=")>0 then'百度URL有两种
	 ComePath="百度"
	 Encodestyle="gb2312"
	 whbarray=split(URLStr,"wd=")
	 whbarray2=split(whbarray(1),"&")
	elseif InStr(URLStr,"yahoo.")>0 then
	 ComePath="雅虎"
	 Encodestyle="utf8"
	 whbarray=split(URLStr,"p=")
	 whbarray2=split(whbarray(1),"&")
	%>
	<!-- 此处非用户定制，故注释掉
	elseif InStr(URLStr,"youdao.")>0 and InStr(URLStr,"search?q=")>0 then'有道URL有两种
	 ComePath="youdao"
	 Encodestyle="gb2312"
	 whbarray=split(URLStr,"?q=")
	 whbarray2=split(whbarray(1),"&")
	elseif InStr(URLStr,"youdao.")>0 and InStr(URLStr,"&q=")>0 then'有道URL有两种
	 ComePath="youdao"
	 Encodestyle="gb2312"
	 whbarray=split(URLStr,"&q=")
	 whbarray2=split(whbarray(1),"&")
	elseif InStr(URLStr,"search.live")>0 then
	 ComePath="MSN"
	 Encodestyle="utf8"
	 whbarray=split(URLStr,"q=")
	 whbarray2=split(whbarray(1),"&")
	-->
	<%else
	 ComePath="其他"
	 Encodestyle="gb2312"
	 whbarray=split(URLStr,"word=")
	 whbarray2=split(whbarray(1),"&")
	end if
	KWStr_URL=whbarray2(0)'获得关键字的URL编码,带%号格式

	if Encodestyle="gb2312" then' 如果是gb码，则直接解析URL编码，否则，要多一步UTF2GB
	Keywords=URLDecode(KWStr_URL)
	else
	Keywords=URLDecode(UTF2GB(KWStr_URL))
	end if
	End Function

	'函数功能：解析URL中带%的关键字编码串为汉字。
	Function URLDecode(enStr)
	dim deStr
	dim c,i,v
	deStr=""
	for i=1 to len(enStr)
	 c=Mid(enStr,i,1)
	 if c="%" then
	 v=eval("&h"+Mid(enStr,i+1,2))
	 if v<128 then
	 deStr=deStr&chr(v)
	 i=i+2
	 else
	 if isvalidhex(mid(enstr,i,3)) then
	 if isvalidhex(mid(enstr,i+3,3)) then
	 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

	'以下为中间调用函数，与程序所要实现的功能并无直接联系。
	function UTF2GB(UTFStr)
	for Dig=1 to len(UTFStr)
	if mid(UTFStr,Dig,1)="%" then
	if len(UTFStr) >= Dig+8 then
	 GBStr=GBStr & ConvChinese(mid(UTFStr,Dig,9))
	 Dig=Dig+8
	else
	 GBStr=GBStr & mid(UTFStr,Dig,1)
	end if
	else
	 GBStr=GBStr & mid(UTFStr,Dig,1)
	end if
	next
	 UTF2GB=GBStr
	end function

	function ConvChinese(x)
	 A=split(mid(x,2),"%")
	 i=0
	 j=0
	for i=0 to ubound(A)
	 A(i)=c16to2(A(i))
	next
	for i=0 to ubound(A)-1
	 DigS=instr(A(i),"0")
	 Unicode=""
	for j=1 to DigS-1
	if j=1 then
	 A(i)=right(A(i),len(A(i))-DigS)
	 Unicode=Unicode & A(i)
	else
	 i=i+1
	 A(i)=right(A(i),len(A(i))-2)
	 Unicode=Unicode & A(i)
	end if
	next
	if len(c2to16(Unicode))=4 then
	 ConvChinese=ConvChinese & chrw(int("&H" & c2to16(Unicode)))
	else
	 ConvChinese=ConvChinese & chr(int("&H" & c2to16(Unicode)))
	end if
	next
	end function

	function c2to16(x)
	 i=1
	for i=1 to len(x) step 4
	 c2to16=c2to16 & hex(c2to10(mid(x,i,4)))
	next
	end function
	function c2to10(x)
	 c2to10=0
	if x="0" then exit function
	 i=0
	for i= 0 to len(x) -1
	if mid(x,len(x)-i,1)="1" then c2to10=c2to10+2^(i)
	next
	end function

	function c16to2(x)
	 i=0
	for i=1 to len(trim(x))
	 tempstr= c10to2(cint(int("&h" & mid(x,i,1))))
	do while len(tempstr)<4
	 tempstr="0" & tempstr
	loop
	 c16to2=c16to2 & tempstr
	next
	end function

	function c10to2(x)
	 mysign=sgn(x)
	 x=abs(x)
	 DigS=1
	do
	if x<2^DigS then
	exit do
	else
	 DigS=DigS+1
	end if
	loop
	 tempnum=x

	 i=0
	for i=DigS to 1 step-1
	if tempnum>=2^(i-1) then
	 tempnum=tempnum-2^(i-1)
	 c10to2=c10to2 & "1"
	else
	 c10to2=c10to2 & "0"
	end if
	next
	if mysign=-1 then c10to2="-" & c10to2
	end function

	function isvalidhex(str)
	dim c
	isvalidhex=true
	str=ucase(str)
	if len(str)<>3 then isvalidhex=false:exit function
	if left(str,1)<>"%" then isvalidhex=false:exit function
	 c=mid(str,2,1)
	if not (((c>="0") and (c<="9")) or ((c>="A") and (c<="Z"))) then isvalidhex=false:exit function
	 c=mid(str,3,1)
	if not (((c>="0") and (c<="9")) or ((c>="A") and (c<="Z"))) then isvalidhex=false:exit function
	end function
	'以上为中间调用函数，与程序所要实现的功能无直接联系。

	Function Run()
	Call GetIP()
	Call GetAddress(IPinfor)
	Call GetUrl()
	Call GetComeurl()
	Call GetKeywords(Request.ServerVariables("HTTP_REFERER"))
	End Function
	End Class

	Set whb = New WhbCount
	whb.run
	sqlstr="insert into webcount_infor(IP,Address,Engine,Keyword,Comeurl,url)values('"&whb.IP&"','"&whb.Address&"','"&whb.Engine&"','"&whb.Keyword&"','"&whb.Comeurl&"','"&whb.URL&"')"
	conn.execute sqlstr
	'response.Write("Run success.")
	Set whb=nothing

	conn.close
	set conn=nothing
	%>

	结果文件showcout.asp.

	<%@LANGUAGE="VBSCRIPT" CODEPAGE="936"%>
	<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
	<html xmlns="http://www.w3.org/1999/xhtml">
	<head>
	<meta http-equiv="Content-Type" content="text/html; charset=gb2312" />
	<title>WHB网站来客访问统计系统</title>
	<style type="text/css">
	<!--
	.STYLE1 {color: #FF0000}
	body,td,th {
	font-family: 宋体;
	font-size: 13px;
	}
	-->
	</style>
	</head>
	<body>
	<!--#include file="conn.asp"-->
	<%
	Dim filter
	filter="是"
	if request("filter")<>"" then
	filter=request("filter")
	end if
	set rs=server.CreateObject("adodb.recordset")' //(建立recordset对象)
	if filter="是" then'如果用户选择过滤关键字
	sqlstr="select ip,Address,engine,keyword,Comeurl,url,visittime,name,jingjia from webcount_infor i,webcount_keyword k where keyword like '%'+name+'%' order by name,visittime"
	else
	sqlstr="select ip,Address,engine,keyword,Comeurl,url,visittime from webcount_infor order by keyword,visittime"
	end if
	'response.Write sqlstr
	'response.end
	rs.open sqlstr,conn,1,1
	if not rs.eof then '判断记录集是否为空
	rs.movefirst
	%>
	&nbsp;&nbsp;
	<form id="form1" name="form1" method="post" action="">
	 <table width="950" height="29" border="0" align="center">
	 <tr>
	 <td width="669">本站访问历史明细表：
	 <label></label></td>
	 <td width="165">是否过滤关键字：
	 <label>
	 <select name="filter" id="filter" onchange="document.form1.submit();">
	 <option value="是" <% if filter="是" then response.Write("selected") end if %>>是</option>
	 <option value="否" <% if filter="否" then response.Write("selected") end if %> >否</option>
	 </select>
	 </label></td>
	 <td width="102"><input type="button" name="btn_setfilter" id="btn_setfilter" value="设置过滤关键字" onclick="window.open('setkeyword.asp','_blank','status=no,scrollbars=yes,left=270,top=200,width=460,height=300');return false;"/></td>
	 </tr>
	 </table>
	 <table width="950" border="1" cellpadding="1" cellspacing="1" bordercolor="#000000" align="center">
	 <tr align="center">
	 <td width="100">访客IP地址</td>
	 <td width="150">访客<a href="http://www.163.com">物理</a>地址</td>
	 <td width="100">来源引擎</td>
	 <td width="100">关键字</td>
	 <% if filter="是" then'如果用户选择过滤关键字 %>
	 <td width="50">竞价</td>
	 <%end if%>
	 <td width="300">访问本站页面</td>
	 <td width="150">来访时间</td>
	 </tr>
	 <%do while not rs.eof%>
	 <tr align="center">
	 <td><%=rs("IP")%></td>
	 <td><%=rs("Address")%></td>
	 <td><a href="<%=rs("Comeurl")%>"><%=rs("Engine")%></a></td>
	 <td><%=rs("keyword")%></td>
	 <% if filter="是" then'如果用户选择过滤关键字 %>
	 <td><%=rs("jingjia")%></td>
	 <%end if%>
	 <td><%=rs("URL")%></td>
	 <td><%=rs("visittime")%></td>
	 </tr>
	 <%
	rs.movenext
	loop
	else '输出错误信息
	response.Write("Sorry,目前还没有任何统计数据！")
	end if
	rs.close
	set rs=nothing
	%>
	 </table>
	 
	&nbsp;<span class="STYLE1">&nbsp;注意事项：</span>重新设置系统关键字后，需要 <a href="showcount.asp">刷新页面</a>。
	</form>
	
	 
	
	 <!--第2项统计-->
	
	</body>
	</html>
试试其它关键字
　来路分析　
同语言下
可能有用的
Dezai.CN贡献的其它代码(4037)