淘特网独自开发的一套访问统计系统

源代码在线查看: function.asp

软件大小: 44 K
上传用户: Erlin
关键词: 访问 统计系统
下载地址: 免注册下载 普通下载 VIP

相关代码

								'获取IP
				function GetIp()
					dim userip
					userip = Request.ServerVariables("HTTP_X_FORWARDED_FOR")
					if userip = "" then 
						userip = Request.ServerVariables("REMOTE_ADDR")
					end if
					GetIp=userip
				end function
				' 从URL中获取关键词
				function findKeystr(urlstr)
				  dim regEx,vKey,vP,findKeystr1,searchtype
				  if(instr(urlstr,"google")0) then
				  	searchtype=1
				  end if
				  findkeystr=""
				  vP = "(?:yahoo.+?[\?|&]p=|openfind.+?q=|google.+?q=|lycos.+?query=|aol.+?query=|onseek.+?keyword=|search\.tom.+?word=|soso\.com.+?w=|chinasearch\.com\.cn.+?word=|search\.msn\.com.+?q=|sina.+?word=|sogou.+?query=|163.+?q=|baidu.+?wd=|baidu.+?word=|3721\.com.+?name=|huicong\.com.+?word=|Alltheweb.+?q=)([^&]*)"
				  set regEx=new regexp
				  regEx.Global = true
				  regEx.IgnoreCase = true
				  regEx.Pattern = vP
				
				  set Matches = regEx.Execute(urlstr)
				  for each Match in Matches	
					findKeystr1 = regEx.replace(Match.value,"$1")
				  next
				  if findKeystr1 "" then
				  	if(searchtype=1) then
				    	findkeystr=urldecode(UTF2GB(findKeystr1))
					else
						findkeystr=urldecode(findKeystr1)
					end if
				    if left(findkeystr,4)="http" or left(findkeystr,2)="搜索" or mid(findkeystr,1,4)="http" then findkeystr=""    
				  end if  
				end function
				
				function UTF2GB(UTFStr) 
				
				for Dig=1 to len(UTFStr) 
				  '如果UTF8编码文字以%开头则进行转换
				  if mid(UTFStr,Dig,1)="%" then 
				     'UTF8编码文字大于8则转换为汉字
				    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)				         tempstr="0" & tempstr 
				      loop 
				      c16to2=c16to2 & tempstr 
				   next 
				end function 
				
				'十进制代码转换为二进制代码
				function c10to2(x) 
				   mysign=sgn(x) 
				   x=abs(x) 
				   DigS=1 
				   do 
				      if x				        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
				
				'GB转UTF8--将GB编码文字转换为UTF8编码文字
				
				Function toUTF8(szInput)
				    Dim wch, uch, szRet
				    Dim x
				    Dim nAsc, nAsc2, nAsc3
				    '如果输入参数为空,则退出函数
				    If szInput = "" Then
				        toUTF8 = szInput
				        Exit Function
				    End If
				    '开始转换
				     For x = 1 To Len(szInput)
				        '利用mid函数分拆GB编码文字
				        wch = Mid(szInput, x, 1)
				        '利用ascW函数返回每一个GB编码文字的Unicode字符代码
				        '注:asc函数返回的是ANSI 字符代码,注意区别
				        nAsc = AscW(wch)
				        If nAsc < 0 Then nAsc = nAsc + 65536
				    
				        If (nAsc And &HFF80) = 0 Then
				            szRet = szRet & wch
				        Else
				            If (nAsc And &HF000) = 0 Then
				                uch = "%" & Hex(((nAsc \ 2 ^ 6)) Or &HC0) & Hex(nAsc And &H3F Or &H80)
				                szRet = szRet & uch
				            Else
				               'GB编码文字的Unicode字符代码在0800 - FFFF之间采用三字节模版
				                uch = "%" & Hex((nAsc \ 2 ^ 12) Or &HE0) & "%" & _
				                            Hex((nAsc \ 2 ^ 6) And &H3F Or &H80) & "%" & _
				                            Hex(nAsc And &H3F Or &H80)
				                szRet = szRet & uch
				            End If
				        End If
				    Next
				        
				    toUTF8 = szRet
				End Function
				
				'GB转unicode---将GB编码文字转换为unicode编码文字
				
				function chinese2unicode(Str) 
				  dim i 
				  dim Str_one 
				  dim Str_unicode 
				  if(isnull(Str)) then
				     exit function
				  end if
				  for i=1 to len(Str) 
				    Str_one=Mid(Str,i,1) 
				    Str_unicode=Str_unicode&chr(38) 
				    Str_unicode=Str_unicode&chr(35) 
				    Str_unicode=Str_unicode&chr(120) 
				    Str_unicode=Str_unicode& Hex(ascw(Str_one)) 
				    Str_unicode=Str_unicode&chr(59) 
				  next 
				  chinese2unicode=Str_unicode 
				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				    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 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="A") and (c				  c=mid(str,3,1)
				if not (((c>="0") and (c="A") and (c				end function
				
				'年、月、日转换
				function getPreMonth(monthnum)
					if(monthnum=1) then
						getPreMonth=12		
					else
						getPreMonth=monthnum-1
					end if
				end function
				function getNextMonth(monthnum)
					if(monthnum=12) then
						getNextMonth=1		
					else
						getNextMonth=monthnum+1
					end if
				end function
				function getPreDay(daynum)
					if(daynum=1) then
						getPreDay=31		
					else
						getPreDay=daynum-1
					end if
				end function
				function getNextDay(daynum)
					if(daynum=31) then
						getNextDay=1		
					else
						getNextDay=daynum+1
					end if
				end function
				%>			

相关资源