counter.asp

一本关于大学的书

	Rs(Scope)=Rs(Scope)+1
	If IsNull(Rs("StartDate")) Then Rs("StartDate")=StrDayLong
	If IsNull(Rs("OldDay")) Then Rs("OldDay")=StrDayLong
	OldDay=Rs("OldDay")
	Rs.Update
	Rs.Close
	Call ModiMaxNum

	If VisitorKeyword<> "" And FoundInArr(RegCount_Fill, "FKeyword", ",") = True then  
		VisitorKeyword=FindKeystr(Request.QueryString("Referer"))
		VisitorKeyword=ReplaceBadChar(trim(Lcase(VisitorKeyword)))
		AddNum VisitorKeyword,"PE_Statkeyword","Tkeyword","TkeywordNum"
	End If
	If FoundInArr(RegCount_Fill, "FSystem", ",") = True Then
		AddNum System,"PE_StatSystem","TSystem","TSysNum"
	End If
	If FoundInArr(RegCount_Fill, "FBrowser", ",") = True Then
		AddNum Browser,"PE_StatBrowser","TBrowser","TBrwNum"
	End If
	If FoundInArr(RegCount_Fill, "FMozilla", ",") = True Then
		AddNum Mozilla,"PE_StatMozilla","TMozilla","TMozNum"
	End If
	If FoundInArr(RegCount_Fill, "FScreen", ",") = True Then
		AddNum Screen,"PE_StatScreen","TScreen","TScrNum"
	End If
	If FoundInArr(RegCount_Fill, "FColor", ",") = True Then
		AddNum Color,"PE_StatColor","TColor","TColNum"
	End If
	If FoundInArr(RegCount_Fill, "FTimezone", ",") = True Then
		AddNum Timezone,"PE_StatTimezone","TTimezone","TTimNum"
	End If
	If FoundInArr(RegCount_Fill, "FRefer", ",") = True Then
		AddNum Referer,"PE_StatRefer","TRefer","TRefNum"
	End If
	If FoundInArr(RegCount_Fill, "FWeburl", ",") = True Then
		AddNum Weburl,"PE_StatWeburl","TWeburl","TWebNum"
	End If
	If FoundInArr(RegCount_Fill, "FAddress", ",") = True Then
		AddNum Address,"PE_StatAddress","TAddress","TAddNum"
	End If
	If FoundInArr(RegCount_Fill, "FIP", ",") = True Then
		AddNum Ip,"PE_StatIp","TIp","TIpNum"
	End If

	AddNum StrDayLong,"PE_StatDay","TDay",StrHour
	AddNum "Total","PE_StatDay","TDay",StrHour
	AddNum StrYear,"PE_StatYear","TYear",StrMonth
	AddNum "Total","PE_StatYear","TYear",StrMonth
	AddNum StrMonthLong,"PE_StatMonth","TMonth",StrDay
	AddNum "Total","PE_StatMonth","TMonth",StrDay
	AddNum "Total","PE_StatWeek","TWeek",StrWeek
	If DateDiff("Ww",Cdate(OldDay),Date)>0 Then
	    Sql="Delete From PE_StatWeek Where TWeek='Current'"
	    conn_counter.Execute(Sql)
	End If
	AddNum "Current","PE_StatWeek","TWeek",StrWeek
end sub

Sub AddNum(Data,TableName,CompareField,AddField)
	Dim RowCount
	conn_counter.execute "update "&TableName&" set ["&AddField&"]=["&AddField&"]+1 where  "&CompareField&"='"&Data&"'", RowCount
	If RowCount = 0 Then conn_counter.execute "insert into "&TableName&" ("&CompareField&",["&AddField&"]) values ('"&Data&"',1)"
End Sub

Sub ModiMaxNum()
    Sql="Select * From PE_StatInfoList"
    Rs.Open Sql,conn_counter,1,3
    If Rs("OldMonth")=StrMonthLong Then
        Rs("MonthNum")=Rs("MonthNum")+1
    Else
        Rs("OldMonth")=StrMonthLong
        Rs("MonthNum")=1
    End If
    If Rs("MonthNum")>Rs("MonthMaxNum") Then 
        Rs("MonthMaxNum")=Rs("MonthNum")
        Rs("MonthMaxDate")=StrMonthLong
    End If
	If Rs("OldDay")=StrDayLong Then
        Rs("DayNum")=Rs("DayNum")+1
    Else
        Rs("OldDay")=StrDayLong
        Rs("DayNum")=1
    End If
    If Rs("DayNum")>Rs("DayMaxNum") Then 
        Rs("DayMaxNum")=Rs("DayNum")
        Rs("DayMaxDate")=StrDayLong
    End If
	If Rs("OldHour")=StrHourLong Then
        Rs("HourNum")=Rs("HourNum")+1
    Else
        Rs("OldHour")=StrHourLong
        Rs("HourNum")=1
    End If
    If Rs("HourNum")>Rs("HourMaxNum") Then 
        Rs("HourMaxNum")=Rs("HourNum")
        Rs("HourMaxTime")=StrHourLong
    End If
    Rs.Update
    Rs.Close
End Sub

Sub UpdateVisit()
    Dim rsOut,VisitCount,OutNum
    VisitCount = 0
    Set rsOut = conn_counter.Execute("select count(ID) From PE_StatVisitor")

    VisitCount = rsOut(0)
    If VisitCount >= VisitRecord Then
		dim rsOd
		set rsOd = conn_counter.Execute("select top 1 VTime from PE_StatVisitor order by VTime asc")
		if CountDatabaseType="SQL" then
			conn_counter.Execute("update PE_StatVisitor set VTime='"&Now()&"',IP='"&IP&"',Address='"&Address&"',Browser='"&Browser&"',System='"&System&"',Screen='"&Screen&"',Color='"&Color&"',Timezone="&VisitTimezone&",Referer='"&Referer&"' where VTime='" & rsOd("VTime") & "'")
		else
			conn_counter.Execute("update PE_StatVisitor set VTime='"&Now()&"',IP='"&IP&"',Address='"&Address&"',Browser='"&Browser&"',System='"&System&"',Screen='"&Screen&"',Color='"&Color&"',Timezone="&VisitTimezone&",Referer='"&Referer&"' where VTime=#" & rsOd("VTime") & "#")
		end if
		Set rsOd = Nothing
	else
		conn_counter.Execute  "insert into PE_StatVisitor (VTime,IP,Address,Browser,System,Screen,Color,Timezone,Referer) Values('"&Now()&"','"&IP&"','"&Address&"','"&Browser&"','"&System&"','"&Screen&"','"&Color&"',"&VisitTimezone&",'"&Referer&"')"
	End If
    Set rsOut = Nothing
End Sub

Function SaveIP(InIP)
	SaveIP=left(InIP,len(InIP)-1)
	SaveIP=right(SaveIP,len(SaveIP)-1)
	Dim FriendIP
	FriendIP=split(SaveIP,"#")
	if ubound(FriendIP) < KillRefresh then
		SaveIP="#" & SaveIP & "#" & IP & "#"
	else
		SaveIP=replace("#" & SaveIP,"#" & FriendIP(0) & "#","#") & "#" & IP & "#"
	end if
End Function

' 从URL中获取关键词
Function FindKeystr(urlstr)
    dim regEx,vKey,findKeystr1
    FindKeystr=""
    set regEx=new regexp
    regEx.Global = true
    regEx.IgnoreCase = true
    regEx.Pattern = "(?:yahoo.+?[\?|&]p=|openfind.+?q=|google.+?q=|lycos.+?query=|aol.+?query=|onseek.+?keyword=|search\.tom.+?word=|search\.qq\.com.+?word=|zhongsou\.com.+?word=|search\.msn\.com.+?q=|yisou\.com.+?p=|sina.+?word=|sina.+?query=|sina.+?_searchkey=|sohu.+?word=|sohu.+?key_word=|sohu.+?query=|163.+?q=|baidu.+?word=|3721\.com.+?name=|Alltheweb.+?q=|3721\.com.+?p=|baidu.+?wd=)([^&]*)"
  
    set Matches = regEx.Execute(urlstr)
    for each Match in Matches
  	    findKeystr1 = regEx.replace(Match.value,"$1")
    next
  
    if findKeystr1<> "" then
        FindKeystr=lcase(decodeURI(findkeystr1))
        if FindKeystr = "undefined" then
  	        FindKeystr = URLDecode(findKeystr1)
        end if
    end if
End Function

' 解开URL编码的函数(这是别人写的,地方标注为: 来源： CSDN  作者： dyydyy )
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 GetYesterdayNum()
	If CacheIsEmpty("nYesterDayVisitorNum") Then
		dim YesterdayStrLong
		YesterdayStrLong=year(dateadd("d","-1",date()))&"-"&month(dateadd("d","-1",date()))&"-"&day(dateadd("d","-1",date()))
		set rs=server.createobject("adodb.recordset")
		If CountDatabaseType="SQL" Then
			sql="SELECT * FROM PE_StatDay WHERE TDay='"&YesterdayStrLong&"'"
		Else
			sql="SELECT * FROM PE_StatDay WHERE TDay=#"&YesterdayStrLong&"#"
		End If
		rs.Open sql,conn_counter,1,1
		If Not rs.BOF or Not rs.EOF then
			for i=0 to 23
				nYesterDayNum=nYesterDayNum+rs(CStr(i))
			next
		else
			nYesterDayNum=0
		end if
		CacheData = Application("nYesterDayVisitorNum")
		If IsArray(CacheData) Then
			CacheData(0) = nYesterDayNum
			CacheData(1) = Now()
		Else
			ReDim CacheData(2)
			CacheData(0) = nYesterDayNum
			CacheData(1) = Now()
		End If
		Application.Lock
		Application("nYesterDayVisitorNum") = CacheData
		Application.UnLock	
	Else
		CacheData = Application("nYesterDayVisitorNum")
		If IsArray(CacheData) Then
			nYesterDayNum = CacheData(0)
		Else
			nYesterDayNum = 0
		End If
	End If
end Function

Function ReplaceBadChar(strChar)
    If strChar = "" Or IsNull(strChar) Then
        ReplaceBadChar = ""
        Exit Function
    End If
    Dim strBadChar, arrBadChar, tempChar, i
    strBadChar = "+,',--,%,^,&,?,(,),<,>,[,],{,},/,\,;,:," & Chr(34) & "," & Chr(0) & ""
    arrBadChar = Split(strBadChar, ",")
    tempChar = strChar
    For i = 0 To UBound(arrBadChar)
        tempChar = Replace(tempChar, arrBadChar(i), "")
    Next
    tempChar = Replace(tempChar, "@@", "@")
    ReplaceBadChar = tempChar
End Function

Function ReplaceUrlBadChar(strChar)
    If strChar = "" Or IsNull(strChar) Then
        ReplaceUrlBadChar = ""
        Exit Function
    End If
    Dim strBadChar, arrBadChar, tempChar, i
    strBadChar = "+,',--,(,),<,>,[,],{,},\,;," & Chr(34) & "," & Chr(0) & ""
    arrBadChar = Split(strBadChar, ",")
    tempChar = strChar
    For i = 0 To UBound(arrBadChar)
        tempChar = Replace(tempChar, arrBadChar(i), "")
    Next
    tempChar = Replace(tempChar, "@@", "@")
    ReplaceUrlBadChar = tempChar
End Function

Function CacheIsEmpty(MyCacheName)
    CacheIsEmpty = True
    CacheData = Application(MyCacheName)
    If Not IsArray(CacheData) Then Exit Function
    If Not IsDate(CacheData(1)) Then Exit Function
    If DateDiff("s", CDate(CacheData(1)), Now()) < 60 * 1440 Then
        CacheIsEmpty = False
    End If
End Function
%>
<script language="javascript" runat="server" type="text/javascript">	
//解码URI
function decodeURI(furl){
	var a=furl;
	try{return decodeURIComponent(a)}catch(e){return 'undefined'};
	return '';
}
</script>