<%
sub ErrList(errmsg)
	response.write "<table width=100% border=0 align=center cellpadding=0 cellspacing=1 bgcolor=#698CC3>"
	response.write "  <tr><td bgcolor=#FFFFFF><table width=100% height=2  border=0 cellpadding=0 cellspacing=0>"
	response.write "        <tr><td></td></tr></table>"
	response.write "        <table width=99% height=30  border=0 align=center cellpadding=0 cellspacing=0 bgcolor=698cc3 class=title>"
	response.write "          <tr><td>&nbsp;返回信息: </td><td align=right>&nbsp;</td></tr></table>"
	response.write "        <table width=100% height=2  border=0 cellpadding=0 cellspacing=0>"
	response.write "          <tr><td></td></tr></table>"
	response.write "        <table width=99%  border=0 align=center cellpadding=1 cellspacing=1 bgcolor=d6e0ef id=Tab6>"
	response.write "          <tr bgcolor=#FFFFFF><td height=20>"&errmsg&"</td></tr>"
	response.write "          <tr bgcolor=#FFFFFF><td height=20 align=center><input type='button' name='Submit' value=' 返回 ' onclick=javascript:history.go(-1);> &nbsp; <input type='button' name='Submit' value=' 关闭 ' onclick=javascript:window.close();></td>"
	response.write "          </tr></table>"
	response.write "        <table width=100% height=2  border=0 cellpadding=0 cellspacing=0>"
	response.write "          <tr><td></td></tr></table></td>"
	response.write "  </tr></table>"
end sub

Public function GetWordsCount(str)
	dim l,t,c, i
	l=len(str)
	t=0
	for i=1 to l
	c=Abs(Asc(Mid(str,i,1)))
	if c>255 then
	t=t+2
	else
	t=t+1
	end if
	next
	GetWordsCount=t
end function

Public function getclassname(classid)
	if classid=0 or classid="" then
		getclassname="<font color=CCCCCC>未指定分类</font>"
		exit function
	end if
	dim rsclass
	rsclass=server.CreateObject("ADODB.Recordset")
	sql="select classname from linkclass where ID=" &classid
	set rsclass=conn.execute (sql)
	if not rsclass.eof then
		getclassname="<a href=""javascript:ReSort("&classid&")"">"&rsclass(0)&"</a>"
	else
		getclassname="<font color=CCCCCC>未指定分类</font>"
	end if
	rsclass.close
end function

Public function GetClassName2(classid)
	if classid=0 or classid="" then
		GetClassName2="未指定分类"
		exit function
	end if
	dim rsclass
	rsclass=server.CreateObject("ADODB.Recordset")
	sql="select classname from linkclass where ID=" &classid
	set rsclass=conn.execute (sql)
	if not rsclass.eof then
		GetClassName2=rsclass(0)
	else
		GetClassName2="未指定分类"
	end if
	rsclass.close
end function
'On Error Resume Next
Server.ScriptTimeOut=9999999
Function getHTTPPage(Path,CharSet1)
        t = GetBody(Path)
        getHTTPPage=BytesToBstr(t,CharSet1)
End function

Function GetBody(url_get) 
        on error resume next
        Set Retrieval = CreateObject("Microsoft.XMLHTTP") 
        With Retrieval 
        .Open "Get", url_get, False, "", "" 
        .Send 
        GetBody = .ResponseBody
        End With 
        Set Retrieval = Nothing 
End Function

Function BytesToBstr(body,Cset)
		on error resume next
        dim objstream
        set objstream = Server.CreateObject("adodb.stream")
        objstream.Type = 1
        objstream.Mode =3
        objstream.Open
        objstream.Write body
        objstream.Position = 0
        objstream.Type = 2
        objstream.Charset = Cset
        BytesToBstr = objstream.ReadText 
        objstream.Close
        set objstream = nothing
End Function

Function Newstring(wstr,strng)
        Newstring=Instr(lcase(wstr),lcase(strng))
        if Newstring<=0 then Newstring=Len(wstr)
End Function

Function IsObjInstalled(strClassString)
	On Error Resume Next
	IsObjInstalled = False
	Err = 0
	Dim xTestObj
	Set xTestObj = Server.CreateObject(strClassString)
	If 0 = Err Then IsObjInstalled = True
	Set xTestObj = Nothing
	Err = 0
End Function

function GetPR(URL)
	GoogleUrl="http://toolbarqueries.google.com.sg/search?client=navclient-auto&features=Rank:&q=info:"&URL&"&ch="&getch(URL)	
	wstr=getHTTPPage(GoogleUrl,"gb2312")
	if len(wstr)<10 then
		GetPR=0
	else
		GetPR=replace (wstr,"Rank_1:1:","")
	end if
end function

function getch(URL)'以后再改写--朱
	TodoUrl="http://service1.todo.net.cn/ch.php?url="&URL&""
	wstr=getHTTPPage(TodoUrl,"gb2312") 

	getch=wstr
end function

function GetAlexa(URL)
	URlStr=URL
	URlStr=replace(URlStr,"\","/")
	if right(URlStr,1)="/" then
		URlStr=left(URlStr,len(URlStr)-1)
	end if

	AlexaUrl="http://data.alexa.com/data/+wQ411en8000lA?cli=10&dat=snba&ver=7.0&cdt=alx_vw=20&wid=12206&act=00000000000&ss=1680x1050&bw=964&t=0&ttl=35371&vis=1&rq=4&url="&URlStr


	wstr=getHTTPPage(AlexaUrl,"gb2312")	
	
	startstr="POPULARITY "
	start=Newstring(wstr,startstr)
	
	if len(wstr)=start then
		GetAlexa = "999999999"
		exit function
	else
		body=mid(wstr,start+len(startstr),1119)
		finishstr="/>"
		finish=Newstring(body,finishstr)
		body=mid(body,1,finish)
		
		Arr=split(body," ")
		Arr1=replace(replace(Arr(0),"URL=""",""),"/""","")
		Arr2=replace(replace(Arr(1),"TEXT=""",""),"""/","")
		
		if lcase(Arr1)=lcase(right(URlStr,len(Arr1))) then
			GetAlexa = Arr2
			exit function
		else
			GetAlexa = "999999999"
			exit function
		end if
	end if
end function

function GetGoogle(URLTEMP)
	URL=URLTEMP
	URL=lcase(URL)
	URL=replace(URL,"http://","")
	URL=replace(URL,"https://","")
	
	GoogleUrl="http://www.google.cn/search?hl=zh-CN&q=site:"&URL
	wstr=getHTTPPage(GoogleUrl,"utf-8")	
	
	Dim oRe, oMatch, oMatches
	Set oRe = New RegExp
	'oRe.Pattern = "(的第 <b>1</b> - <b>10</b> 个结果，总共约为 <b>)([0-9|,]+)"
	oRe.Pattern = "(约有 <b>)([0-9|,]+)(</b> 项符合)"
	Set oMatches = oRe.Execute(wstr)
	
	if oMatches.Count=0 then
		GetGoogle = "0"
		exit function
	else
		Set oMatch = oMatches(0)
		
		GetGoogle = Replace(oMatch.SubMatches(1),",","")
		exit function
	end if
end function

function GetBaidu(URLTEMP)
	URL=URLTEMP
	URL=lcase(URL)
	URL=replace(URL,"http://","")
	URL=replace(URL,"https://","")
		
	BaiduUrl="http://www.baidu.com/s?wd=site:"&URL&"&cl=3"
	wstr=getHTTPPage(BaiduUrl,"gb2312")	
	startstr="百度一下，找到相关网页"
	
	start=Newstring(wstr,startstr)

	if len(wstr)=start then
		GetBaidu = "0"
		exit function
	else
		body=mid(wstr,start+len(startstr),1119)
	
		finishstr="篇，用时"
		finish=Newstring(body,finishstr)
		
		body=mid(body,1,finish-1)
		
		body=replace(body,",","")
		body=replace(body,"约","")
		
		if Instr(body,"<script>")>0 then
			GetBaidu = "0"
			exit function
		else
			GetBaidu = body
			exit function
		end if
	end if
end function

Function RW(num)
	if num=999999999 then RW="未收录" : else RW=num : End if
end function

Function RegExpTest(patrn, strng)
   Dim regEx, Match, Matches   ' 建立变量。
   Set regEx = New RegExp      ' 建立正则表达式。
   regEx.Pattern = patrn       ' 设置模式。
   regEx.IgnoreCase = True     ' 设置是否区分字符大小写。
   regEx.Global = True         ' 设置全局可用性。
   Set Matches = regEx.Execute(strng)   ' 执行搜索。
   For Each Match in Matches   ' 遍历匹配集合。
	  regEx.Pattern = "(>)([0-9]{1,3})(<)"
      NewValue=regEx.Replace(Match.Value, "$2")
      RetStr = RetStr & NewValue
   Next
   RegExpTest = RetStr
End Function

Function IsRightUrl(UrlStrng)
  Dim regEx, retVal
  Set regEx = New RegExp
  'regEx.Pattern = "^https?:\/\/([\u4E00-\u9FA5a-zA-Z\/0-9\-]{1,30}\.){1,3}([\u4E00-\u9FA5a-zA-Z\/0-9\-]{2,9})(:[0-9]{1,5})?([\/|\\]{1}[^\|<>\?\*:/\\""]+)*([\/|\\]{1}([^\|<>\?\*:/\\""\.]{1,255}\.[^\|<>\?\*:/\\""\.]{1,255})?)?$" 
  regEx.Pattern = "^https?:\/\/([\u4E00-\u9FA5a-zA-Z\/0-9\-]{1,30}\.){1,3}([\u4E00-\u9FA5a-zA-Z\/0-9\-]{2,9})(:[0-9]{1,5})?([\/|\\]{1}[^\|<>\?\*:/\\""]+)*([\/|\\]{1}([^\|<>\?\*:/\\""\.]{1,255}\.[^\|<>\?\*:/\\""\.]{1,255})?)?((\?{1}([\u4E00-\u9FA5a-zA-Z\/0-9\-]+[\=]?[\u4E00-\u9FA5a-zA-Z\/0-9\-]*)?([\&]{1}[\u4E00-\u9FA5a-zA-Z\/0-9\-]+[\=]?[\u4E00-\u9FA5a-zA-Z\/0-9\-]*)*){1})?$" 

  regEx.IgnoreCase = False 
  retVal = regEx.Test(UrlStrng)

  If retVal Then
    IsRightUrl = true
  Else
    IsRightUrl = false
  End If
End Function
%>