common.asp

直接在页面上使用标签加入友情链接站点,非使用跳转页面 ,可设置是否要求PR值验证,及所要求PR值大小,可设置是否要求Alexa排名验证,及所要求的Alexa排名次序

<%

sub ErrList(errmsg)
	response.write "<table width=530 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);></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

'On Error Resume Next
Server.ScriptTimeOut=9999999
Function getHTTPPage(Path)
        t = GetBody(Path)
        getHTTPPage=BytesToBstr(t,"GB2312")
End function

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

Function BytesToBstr(body,Cset)
        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

Public function IsValidEmail(email)
	dim names, name, i, c
	IsValidEmail = true
	names = Split(email, "@")
	if UBound(names) <> 1 then
	   IsValidEmail = false
	   exit function
	end if
	for each name in names
	   if Len(name) <= 0 then
		 IsValidEmail = false
	     exit function
	   end if
	   for i = 1 to Len(name)
		 c = Lcase(Mid(name, i, 1))
	     if InStr("abcdefghijklmnopqrstuvwxyz_-.", c) <= 0 and not IsNumeric(c) then
	       IsValidEmail = false
		   exit function
	     end if
	   next
	   if Left(name, 1) = "." or Right(name, 1) = "." then
		  IsValidEmail = false
	      exit function
	   end if
	next
	if InStr(names(1), ".") <= 0 then
	   IsValidEmail = false
	   exit function
	end if
	i = Len(names(1)) - InStrRev(names(1), ".")
	if i <> 2 and i <> 3 then
	   IsValidEmail = false
	   exit function
	end if
	if InStr(email, "..") > 0 then
	   IsValidEmail = false
	end if
end function

'ASP密文与解密BEGIN
Class clsRSA
	Public PrivateKey
	Public PublicKey
	Public Modulus
	Public Function Crypt(pLngMessage, pLngKey)
		On Error Resume Next
		Dim lLngMod
		Dim lLngResult
		Dim lLngIndex
		If pLngKey Mod 2 = 0 Then
			lLngResult = 1
			For lLngIndex = 1 To pLngKey / 2
				lLngMod = (pLngMessage ^ 2) Mod Modulus
				' Mod may error on key generation
				lLngResult = (lLngMod * lLngResult) Mod Modulus 
				If Err Then Exit Function
			Next
		Else
			lLngResult = pLngMessage
			For lLngIndex = 1 To pLngKey / 2
				lLngMod = (pLngMessage ^ 2) Mod Modulus
				On Error Resume Next
				' Mod may error on key generation
				lLngResult = (lLngMod * lLngResult) Mod Modulus
				If Err Then Exit Function
			Next
		End If
		Crypt = lLngResult
	End Function
	
	
	
	Public Function Encode(ByVal pStrMessage)
		Dim lLngIndex
		Dim lLngMaxIndex
		Dim lBytAscii
		Dim lLngEncrypted
		lLngMaxIndex = Len(pStrMessage)
		If lLngMaxIndex = 0 Then Exit Function
		For lLngIndex = 1 To lLngMaxIndex
			lBytAscii = Asc(Mid(pStrMessage, lLngIndex, 1))
			lLngEncrypted = Crypt(lBytAscii, PublicKey)
			Encode = Encode & NumberToHex(lLngEncrypted, 4)
		Next
	End Function
	
	Public Function Decode(ByVal pStrMessage)
		Dim lBytAscii
		Dim lLngIndex
		Dim lLngMaxIndex
		Dim lLngEncryptedData
		Decode = ""
		lLngMaxIndex = Len(pStrMessage)
		For lLngIndex = 1 To lLngMaxIndex Step 4
			lLngEncryptedData = HexToNumber(Mid(pStrMessage, lLngIndex, 4))
			lBytAscii = Crypt(lLngEncryptedData, PrivateKey)
			Decode = Decode & Chr(lBytAscii)
		Next
	End Function
	
	Private Function NumberToHex(ByRef pLngNumber, ByRef pLngLength)
		NumberToHex = Right(String(pLngLength, "0") & Hex(pLngNumber), pLngLength)
	End Function
	
	Private Function HexToNumber(ByRef pStrHex)
		HexToNumber = CLng("&h" & pStrHex)
	End Function

End Class

function Encryptstr(Message)
	Dim LngKeyE
	Dim LngKeyD
	Dim LngKeyN
	Dim StrMessage
	Dim ObjRSA
	LngKeyE = "32823"
	LngKeyD = "20643"
	LngKeyN = "29893"
	StrMessage = Message
	
	Set ObjRSA = New clsRSA
		ObjRSA.PublicKey = LngKeyE
		ObjRSA.Modulus = LngKeyN
		Encryptstr = ObjRSA.Encode(StrMessage)
	Set ObjRSA = Nothing
end function

function decryptstr(Message)
	Dim LngKeyE
	Dim LngKeyD
	Dim LngKeyN
	Dim StrMessage
	Dim ObjRSA
    LngKeyE = "32823"
    LngKeyD = "20643"
    LngKeyN = "29893"
    StrMessage = Message
    Set ObjRSA = New clsRSA
		ObjRSA.PrivateKey =LngKeyD
		ObjRSA.Modulus=LngKeyN
		decryptstr=ObjRSA.Decode(StrMessage)
    Set ObjRSA = Nothing
end function
'ASP密文与解密END

%>