博客园_ゞ智者.千虑

获取 Google PR 值 ASP（vbs）版（使用最新算法）

2010-03-25T14:50:00Z

在网上能找到很多个版本的，比如PHP,C#,ASP.NET等版本的，甚至有ASP（Jscript）版的，唯独没找到ASP（vbs）版的，无奈研究各个版本自己“拼”了一个，发出来方便有需要的朋友。相信这是唯一的一个能用的ASP（vbs）版。

<%
' Feature     :   Get Google PageRank
' Version     :   v0.1 beta
' Author      :   Liaoyizhi(Liaoyizhi[at]gmail.com)
' Update Date :   2010/03/25 23:20
' Description :   Get Google PageRank With Asp

'Option Explicit

Private Const OFFSET_4 = 4294967296
Private Const MAXINT_4 = 2147483647

Private Function zeroFill(ByVal a, ByVal b)
	Dim z
	z = &H80000000
	If ((z And a) <> 0) Then
		a = BitRShift(a, 1)
		a = a And Not z
		a = a Or &H40000000
		a = BitRShift(a, b - 1)
	Else
		a = BitRShift(a, b)
	End If
	zeroFill = a
End Function

Private Function uw_WordAdd(ByVal wordA, ByVal wordB)
' Adds words A and B avoiding overflow
	Dim myUnsigned
	
	myUnsigned = LongToUnsigned(wordA) + LongToUnsigned(wordB)
	' Cope with overflow
	If myUnsigned > OFFSET_4 Then
		myUnsigned = myUnsigned - OFFSET_4
	End If
	uw_WordAdd = UnsignedToLong(myUnsigned)
End Function

Private Function uw_WordSub(ByVal wordA, ByVal wordB)
' Subtract words A and B avoiding underflow
	Dim myUnsigned
	
	myUnsigned = LongToUnsigned(wordA) - LongToUnsigned(wordB)
	' Cope with underflow
	If myUnsigned < 0 Then
		myUnsigned = myUnsigned + OFFSET_4
	End If
	uw_WordSub = UnsignedToLong(myUnsigned)
End Function

Private Function UnsignedToLong(value)
	If value < 0 Or value >= OFFSET_4 Then Error 6 ' Overflow
	If value <= MAXINT_4 Then
		UnsignedToLong = value
	Else
		UnsignedToLong = value - OFFSET_4
	End If
End Function

Private Function LongToUnsigned(value)
	If value < 0 Then
		LongToUnsigned = value + OFFSET_4
	Else
		LongToUnsigned = value
	End If
End Function

Private Function BitLShift(ByVal x, n)
	If n = 0 Then
		BitLShift = x
	Else
		Dim k
		k = 2 ^ (32 - n - 1)
		Dim d
		d = x And (k - 1)
		Dim c
		c = d * 2 ^ n
		If x And k Then
			c = c Or &H80000000
		End If
		BitLShift = c
	End If
End Function

Private Function BitRShift(ByVal x, n)
	If n = 0 Then
		BitRShift = x
	Else
		Dim y
		y = x And &H7FFFFFFF
		Dim z
		If n = 32 - 1 Then
			z = 0
		Else
			z = y \ 2 ^ n
		End If
		If y <> x Then
			z = z Or 2 ^ (32 - n - 1)
		End If
		BitRShift = z
	End If
End Function

Private Function mix(ByVal a, ByVal b, ByVal c)
	a = uw_WordSub(a, b): a = uw_WordSub(a, c): a = a Xor (zeroFill(c, 13))
	b = uw_WordSub(b, c): b = uw_WordSub(b, a): b = b Xor BitLShift(a, 8)
	c = uw_WordSub(c, a): c = uw_WordSub(c, b): c = c Xor zeroFill(b, 13)
	a = uw_WordSub(a, b): a = uw_WordSub(a, c): a = a Xor zeroFill(c, 12)
	b = uw_WordSub(b, c): b = uw_WordSub(b, a): b = b Xor BitLShift(a, 16)
	c = uw_WordSub(c, a): c = uw_WordSub(c, b): c = c Xor zeroFill(b, 5)
	a = uw_WordSub(a, b): a = uw_WordSub(a, c): a = a Xor zeroFill(c, 3)
	b = uw_WordSub(b, c): b = uw_WordSub(b, a): b = b Xor BitLShift(a, 10)
	c = uw_WordSub(c, a): c = uw_WordSub(c, b): c = c Xor zeroFill(b, 15)
	
	Dim m(2)
	m(0) = a
	m(1) = b
	m(2) = c
	mix = m
End Function

Private Function GoogleCH(url(), length)
	Dim init, a, b, c
	init = &HE6359A60
	a = &H9E3779B9
	b = &H9E3779B9
	c = &HE6359A60
	
	Dim k, l
	k = 0
	l = length
	
	Dim mixo
	While (l >= 12)
		a = uw_WordAdd(a, url(k + 0))
		a = uw_WordAdd(a, BitLShift(url(k + 1), 8))
		a = uw_WordAdd(a, BitLShift(url(k + 2), 16))
		a = uw_WordAdd(a, BitLShift(url(k + 3), 24))
		b = uw_WordAdd(b, url(k + 4))
		b = uw_WordAdd(b, BitLShift(url(k + 5), 8))
		b = uw_WordAdd(b, BitLShift(url(k + 6), 16))
		b = uw_WordAdd(b, BitLShift(url(k + 7), 24))
		c = uw_WordAdd(c, url(k + 8))
		c = uw_WordAdd(c, BitLShift(url(k + 9), 8))
		c = uw_WordAdd(c, BitLShift(url(k + 10), 16))
		c = uw_WordAdd(c, BitLShift(url(k + 11), 24))
		mixo = mix(a, b, c)
		a = mixo(0): b = mixo(1): c = mixo(2)
		k = k + 12
		l = l - 12
	Wend
	c = c + length
	If l >= 11 Then c = uw_WordAdd(c, BitLShift(url(k + 10), 24))
	If l >= 10 Then c = uw_WordAdd(c, BitLShift(url(k + 9), 16))
	If l >= 9 Then c = uw_WordAdd(c, BitLShift(url(k + 8), 8))
	If l >= 8 Then b = uw_WordAdd(b, BitLShift(url(k + 7), 24))
	If l >= 7 Then b = uw_WordAdd(b, BitLShift(url(k + 6), 16))
	If l >= 6 Then b = uw_WordAdd(b, BitLShift(url(k + 5), 8))
	If l >= 5 Then b = uw_WordAdd(b, url(k + 4))
	If l >= 4 Then a = uw_WordAdd(a, BitLShift(url(k + 3), 24))
	If l >= 3 Then a = uw_WordAdd(a, BitLShift(url(k + 2), 16))
	If l >= 2 Then a = uw_WordAdd(a, BitLShift(url(k + 1), 8))
	If l >= 1 Then a = uw_WordAdd(a, url(k + 0))
	
	mixo = mix(a, b, c)
	If (mixo(2) < 0) Then
		GoogleCH = mixo(2) + 2 ^ 32
	Else
		GoogleCH = mixo(2)
	End If
End Function

Private Function StrConv(ByVal s)
	Dim tmpArr(),i
	ReDim tmpArr(Len(s))
	For i = 0 To Len(s) - 1
		tmpArr(i) = Asc(Mid(s,i+1,1))
	Next
	StrConv = tmpArr
End Function

Private Function c32to8bit(arr32())
	Dim arr8()
	ReDim arr8(4 * (UBound(arr32) + 1) - 1)
	Dim i, bitOrder
	For i = 0 To UBound(arr32)
		For bitOrder = i * 4 To i * 4 + 3
			arr8(bitOrder) = arr32(i) And 255
			arr32(i) = zeroFill(arr32(i), 8)
		Next
	Next
	c32to8bit = arr8
End Function

Private Function GoogleNewCh(ByVal ch)
	Dim prbuf(19), i
	prbuf(0) = (BitLShift(Fix(ch / 7), 2) Or ((ch - 13 * Fix(ch / 13)) And 7))
	'prbuf(0) = (BitLShift((ch / 7), 2) Or ((ch Mod 13) And 7))
	For i = 1 To 19
		prbuf(i) = prbuf(i - 1) - 9
	Next
	
	GoogleNewCh = GoogleCH(c32to8bit(prbuf), 80)
End Function

Private Function UrlEncode(ByVal urlText)
	Dim i
	Dim ansi
	Dim ascii
	Dim encText
	
	ansi = StrConv(urlText)
	
	encText = ""
		For i = 0 To UBound(ansi)
		ascii = ansi(i)
	
		Select Case ascii
		Case 48,49,50,51,52,53,54,55,56,57, 65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90, 97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122
			encText = encText & Chr(ascii)
	
		Case 32
			encText = encText & "+"
	
		Case Else
			If ascii < 16 Then
				encText = encText & "%0" & Hex(ascii)
			Else
				encText = encText & "%" & Hex(ascii)
			End If
	
		End Select
	Next
	
	UrlEncode = encText
End Function

Public Function GetPageRank(url)
	Dim reqgr, reqgre
	reqgr = "info:" & url
	reqgre = "info:" & UrlEncode(url)
	
	Dim bUrl
	bUrl = StrConv(reqgr)
	
	Dim gch
	gch = GoogleCH(bUrl, Len(reqgr))
	gch = GoogleNewCh(gch)
	Dim querystring
	querystring = "http://209.85.135.99/search?client=navclient-auto&ch=6" & gch & "&ie=UTF-8&oe=UTF-8&features=Rank:FVN&q=" & reqgre
	
	Dim xml
	Set xml = Server.CreateObject("Microsoft.XMLHTTP")
	xml.Open "GET", querystring, False
	xml.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; GoogleToolbar 2.0.114-big; Windows XP 5.1)"
	xml.send
	
	GetPageRank = ""
	Dim res
	res = xml.responseText
	Set xml = Nothing
	If Len(res) > 2 Then
		Dim pos, pos1
		pos = InStr(res, "Rank_")
		pos1 = InStr(pos, res, Chr(10))
		If pos > 0 And pos1 > 0 Then
			res = Mid(res, pos, pos1 - pos)
			Dim x
			x = Split(res, ":", 3)
			GetPageRank = x(2)
		End If
	End If
End Function

%>

<%
Example:
Response.Write(GetPageRank("baidu.com"))
%>

本文链接

Adobe CS4 Design Premium 简体中文正式版全集提供种子文件破解方法

2010-02-04T08:02:00Z

在安装Adobe CS4产品之前先更改系统host文件，更改方法如下：打开C:\WINDOWS\system32\drivers\etc\ 目录，右击Hosts文件，属性-把“只读”选项去掉，然后用记事本打开该文件...

jQuery1.4 API 中文版手册(chm格式)

2010-02-04T07:00:00Z

ASCII码表

2010-01-12T14:02:00Z

美国标准信息交换标准码( American Standard Code for Information Interchange, ASCII )在计算机中，所有的数据在存储和运算时都要使用二进制数表示（因为计算机比较傻，只有0和1两位数的二进制比较适合于它使用），同样的，象a、b、c、d这样的52个字母（包括大写）、以及0、1、2等数字还有一些常用的符号（例如*、#、@等）在计算机中存储时也要使用二进制数来表示，而具体用哪个数字表示哪个符号，当然每个人都可以约定自己的一套（这就叫编码），而大家如果要想互相通讯而不造成混乱，那么大家就必须使用相同的编码规则，于是美国有关的标准化组织就出台了所谓的ASCII编码，统一规定了上述常用符号用哪个二进制数来表示。

解决在IE7下Ext表单(form)过长的时候fieldset内组件错位的BUG

2009-11-20T06:43:00Z

被这个问题困扰很久了，今天终于解决，其实很简单，覆盖一个样式即可：[代码]

jQuery1.3 API 中文版手册(chm格式)

2009-11-13T05:16:00Z

FCKeditor的fckconfig.js配置中文说明

2009-11-11T03:22:00Z

FCKConfig.CustomConfigurationsPath = '' ; // 自定义配置文件路径和名称FCKConfig.EditorAreaCSS = FCKConfig.BasePath + 'css/fck_editorarea.css'; // 编辑区的样式表文件FCKConfig.EditorAreaStyles = '' ; // 编辑区的样式表风格FCKConfig.ToolbarComboPreviewCSS =''; //工具栏预览CSSFCKConfig.DocType = '' ;//文档类型FCKConfig.BaseHref = ''; // 相对链接的基地址FCKConfig.FullPage = false ; //是否允许编辑整个HTML文件,还是仅允许编辑BODY间的内容FCKConfig.StartupShowBlocks = false ;//决定是否启用"显示模块"FCKConfig.Debug = false ;//是否开启调试功能FCKConfig.SkinPath = FCKConfig.Ba

关于Ext ComboBox组件的expand()方法

2009-10-29T08:11:00Z

直接Ext.getCmp("ComboId").expand();是不可行的，什么都不会发生。二个重点：1、先执行focus()，再执行expand()。2、对于IE系列的浏览器，执行expand()的时候必须设置延迟，哪怕只延迟1毫秒。否则什么都不会发生（FF没有这个问题）。所以，代码大概写成这样就差不多了：[代码]

Adobe DreamweaverCS4 beta 下载地址+序列号+中文包+破解全攻略o(∩_∩)o...

2008-07-02T09:50:00Z

Adobe DreamweaverCS4 beta 已经发布一个多月了（5月27日发布），第一时间下载试用后，感觉良好，最喜欢的就是它的拆分代码功能，对于经常用代码视图来写东西的我们来说是很实用的一个功能。

清除浮动的最优方法

2008-06-29T08:18:00Z

以下内容转自：http://www.twinsenliang.net/skill/20070719.html在CSS森林（30247792）群里讨论一个margin的问题中无意间发现overflow也可以用来清除浮动，嘿嘿，这个方法不单使用简单，而且FF、OP、IE7都支持，从此可以告别那又长兼容性又差的FF清浮动的方法了。方法真的很简单，只要为需要清浮动的标签加上overflow这个属性。引用C...