常用搜索引擎关键字转换!

最新推荐文章于 2023-11-03 00:53:43 发布

xiandao82

最新推荐文章于 2023-11-03 00:53:43 发布

阅读量1.1k

点赞数

分类专栏： asp 文章标签：搜索引擎 function vbscript hex google 算法

本文链接：https://blog.csdn.net/xiandao82/article/details/51424

版权

asp 专栏收录该内容

1 篇文章 0 订阅

订阅专栏

Public Function GetSearchKeyword(RefererUrl) '搜索关键词
  on error resume next
  Dim re
  Set re = New RegExp
  re.IgnoreCase = True
  re.Global = True
  Dim a,b,j
  re.Pattern = "(" _
   & "google.+?q=([^&]*)" & "|sina.+?word=([^&]*)" _
   & "|sohu.+?query=([^&]*)" & "|163.+?q=([^&]*)" _
   & "|yahoo.+?p=([^&]*)" & "|baidu.+?word=([^&]*)" _
   & "|openfind.+?q=([^&]*)" & "|lycos.+?query=([^&]*)" _
   & "|aol.+?query=([^&]*)" & "|onseek.+?keyword=([^&]*)" _
   & "|3721/.com.+?p=([^&]*)" & "|search/.tom.+?word=([^&]*)" _
    & ")"
  Set a = re.Execute(RefererUrl)
  If a.Count>0 then
   Set b = a(a.Count-1).SubMatches
   For j=1 to b.Count
    If Len(b(j))>0 then GetSearchKeyword=b(j) : Exit Function
   Next
  End If
  if err then
  err.clear
  GetSearchKeyword = RefererUrl
  else
  GetSearchKeyword = ""
  end if
End Function

UTF-8类型:比如google

<%Function utf8code(strUtf)
'将单个的utf字符串，转换成gb汉字，
l=len(strutf)/9
for i=1 to l
  astr=left(strutf,9)
  if i=l then
  strutf=""
  else
  strutf=mid(strutf,10,(l-i+1)*9)
  end if

dim iCode,iCode1,iCode2

iCode=Mid(astr,2,2)
iCode1=Mid(astr,5,2)
iCode2=Mid(astr,8,2)

iCode="&h"&iCode
iCode1="&h"&iCode1
iCode2="&h"&iCode2

iiCode=(iCode And &h0f)
iiCode1=(iCOde1 And &h3f)
iiCode2=(iCode2 And &h3f)

st=ChrW((iiCode*2^12) OR (iiCode1*2^6) OR iiCode2) '编码转换算法程序,测试通过
utf8code=utf8code&st
next
End Function%>

16进制转换10进制

<% Function ten(num)
  for i=1 to len(num)
   temp=mid(num,i,1)
   if trim(temp)="A" then
   temp=10
   elseif trim(temp)="B" then
   temp=11
   elseif trim(temp)="C" then
   temp=12
   elseif trim(temp)="D" then
   temp=13
   elseif trim(temp)="E" then
   temp=14
   elseif trim(temp)="F" then
   temp=15
   end if
   cf=len(num)-i
   sum=sum+cint(temp)*(16^cf)
  next
  ten=sum
end Function

'转换搜索引擎关键字比如3721,baidu.163等
Function fn(st)
  js1=cdbl(ten(mid(st,2,2))*256)
  js2=cdbl(ten(mid(st,5,2)))
  js=cdbl(js1)+cdbl(js2)
  js=js-65536
  fn=chr(js)
end Function%>

<%function naf(str)
l=Len(str)/6
for j=1 to l
  hz=left(str,6)
  if j=l then
  str=""
  else
  str=mid(str,7,(l-j+1)*6)
  end if
  naf=naf&fn(hz)
next
end function%>

'3721，baidu,等关键字的乱码转换方法

<SCRIPT language="VBScript">
Function URLEncoding(vstrIn)
    strReturn = ""
    For i = 1 To Len(vstrIn)
        ThisChr = Mid(vStrIn,i,1)
        If Abs(Asc(ThisChr)) < &HFF Then
            strReturn = strReturn & ThisChr
        Else
            innerCode = Asc(ThisChr)
            If innerCode < 0 Then
                innerCode = innerCode + &H10000
            End If
            Hight8 = (innerCode And &HFF00)/ &HFF
            Low8 = innerCode And &HFF
            strReturn = strReturn & "%" & Hex(Hight8) & "%" & Hex(Low8)
        End If
    Next
    URLEncoding = strReturn
End Function