Warning: mkdir(): Permission denied in /data/pub/txcms/system/lib/Fso.php on line 151
天下站长网 ASP asp实现关键词获取(各搜索引擎,gb2312及utf-8) - powered by andsky.com
投递文章 投稿指南 RSS订阅 站点通告:网站升级,部分数据正在导入之中,请等待..
您的位置:首页 >> Web编程 >> ASP

asp实现关键词获取(各搜索引擎,gb2312及utf-8)

发布时间:2009-06-21 15:42:37  文章来源:动态网站  浏览次数:3516  
承德互联 专业的unix(freebsd)主机 无限子域 BGP多线 自主开发面版 更快 更稳 更安全

现在各大搜索引擎编码为什么会不一样?.当然不是gb2312就是utf-8了.编码问题是比较头疼的问题...

我们获得关键词,一般是通过来访页面的url进行分析的.比如

http://www.google.com/search?hl=zh-CN&q=%E5%AD%A4%E7%8B%AC&lr=

各位肯定知道这个是通过urlencode编码的.

我们得到其中的信息,需要进行2步.第一步是进行urldecode,在我们普通参数活得的时候,这个是由asp自己来进行的,但是现在我们不得不进行手工解码.

网上函数很多,但都是针对于gb2312页面解gb2312.utf-8的.对于这个,我们可以很轻松的先进行解码,然后根据搜索引擎判断它的编码,如果是utf-8就再转换为gb2312.

但是由于我的网站是utf-8页面的.而utf-8页面我找到的只有解utf-8字符的urldecode编码的.在这里停顿了很久,最后我只能用最糟糕的方法,把拆分出来的关键词用xmlhttp提交到一个gb2312的asp页面,然后活得乱码(gb2312)后再进行gb2312 to utf-8的转换.

下面主要实现代码.

ASP/Visual Basic Code复制内容到剪贴板
  1. Public Function GetSearchKeyword(RefererUrl) '搜索关键词   
  2.  if RefererUrl="" or len(RefererUrl)<1 then exit function   
  3.        
  4.   on error resume next   
  5.      
  6.   Dim re   
  7.   Set re = New RegExp   
  8.   re.IgnoreCase = True  
  9.   re.Global = True  
  10.   Dim a,b,j   
  11.   '模糊查找关键词,此方法速度较快,范围也较大   
  12.   re.Pattern = "(word=([^&]*)|q=([^&]*)|p=([^&]*)|query=([^&]*)|name=([^&]*)|_searchkey=([^&]*)|baidu.*?w=([^&]*))"  
  13.   Set a = re.Execute(RefererUrl)   
  14.   If a.Count>0 then   
  15.    Set b = a(a.Count-1).SubMatches   
  16.    For j=1 to b.Count   
  17.     If Len(b(j))>0 then    
  18.      if instr(1,RefererUrl,"google",1) then    
  19.        GetSearchKeyword=Trim(U8Decode(b(j)))   
  20.       elseif instr(1,refererurl,"yahoo",1) then    
  21.        GetSearchKeyword=Trim(U8Decode(b(j)))   
  22.       elseif instr(1,refererurl,"yisou",1) then   
  23.        GetSearchKeyword=Trim(getkey(b(j)))   
  24.       elseif instr(1,refererurl,"3721",1) then   
  25.        GetSearchKeyword=Trim(getkey(b(j)))   
  26.       else    
  27.        GetSearchKeyword=Trim(getkey(b(j)))   
  28.      end if   
  29.      Exit Function  
  30.     end if   
  31.    Next  
  32.   End If  
  33.   if err then   
  34.   err.clear   
  35.   GetSearchKeyword = RefererUrl   
  36.   else   
  37.   GetSearchKeyword = ""     
  38.   end if     
  39.  End Function  
  40.   
  41.   
  42.  Function URLEncoding(vstrIn)   
  43.   dim strReturn,i,thischr   
  44.     strReturn = ""  
  45.     For i = 1 To Len(vstrIn)   
  46.         ThisChr = Mid(vStrIn,i,1)   
  47.         If Abs(Asc(ThisChr)) < &HFF Then  
  48.             strReturn = strReturn & ThisChr   
  49.         Else  
  50.             innerCode = Asc(ThisChr)   
  51.             If innerCode < 0 Then  
  52.                 innerCode = innerCode + &H10000   
  53.             End If  
  54.             Hight8 = (innerCode  And &HFF00)\ &HFF   
  55.             Low8 = innerCode And &HFF   
  56.             strReturn = strReturn & "%" & Hex(Hight8) &  "%" & Hex(Low8)   
  57.         End If  
  58.     Next  
  59.     URLEncoding = strReturn   
  60. End Function  
  61. function getkey(key)   
  62. dim oReq   
  63. set oReq = CreateObject("MSXML2.XMLHTTP")   
  64. oReq.open "POST","http://"&WebUrl"/system/ShowGb2312XML.asp?a="&key,false   
  65. oReq.send   
  66. getkey=UTF2GB(oReq.responseText)   
  67. end function   
  68. function chinese2unicode(Str)    
  69.   dim i    
  70.   dim Str_one    
  71.   dim Str_unicode    
  72.   for i=1 to len(Str)    
  73.     Str_one=Mid(Str,i,1)    
  74.     Str_unicode=Str_unicode&chr(38)    
  75.     Str_unicode=Str_unicode&chr(35)    
  76.     Str_unicode=Str_unicode&chr(120)    
  77.     Str_unicode=Str_unicode& Hex(ascw(Str_one))    
  78.     Str_unicode=Str_unicode&chr(59)    
  79.   next    
  80.   Response.Write Str_unicode    
  81. end function        
  82.      
  83. function UTF2GB(UTFStr)   
  84. Dim dig,GBSTR   
  85.     for Dig=1 to len(UTFStr)   
  86.         if mid(UTFStr,Dig,1)="%" then   
  87.             if len(UTFStr) >= Dig+8 then   
  88.                 GBStr=GBStr & ConvChinese(mid(UTFStr,Dig,9))   
  89.                 Dig=Dig+8   
  90.             else   
  91.                 GBStr=GBStr & mid(UTFStr,Dig,1)   
  92.             end if   
  93.         else   
  94.             GBStr=GBStr & mid(UTFStr,Dig,1)   
  95.         end if   
  96.     next   
  97.     UTF2GB=GBStr   
  98. end function   
  99.   
  100.   
  101. function ConvChinese(x)    
  102. dim a,i,j,DigS,Unicode  
  103.     A=split(mid(x,2),"%")   
  104.     i=0   
  105.     j=0   
  106.        
  107.     for i=0 to ubound(A)    
  108.         A(i)=c16to2(A(i))   
  109.     next   
  110.            
  111.     for i=0 to ubound(A)-1   
  112.         DigS=instr(A(i),"0")   
  113.         Unicode=""  
  114.         for j=1 to DigS-1   
  115.             if j=1 then    
  116.                 A(i)=right(A(i),len(A(i))-DigS)   
  117.                 Unicode=Unicode & A(i)   
  118.             else   
  119.                 i=i+1   
  120.                 A(i)=right(A(i),len(A(i))-2)   
  121.                 Unicode=Unicode & A(i)    
  122.             end if    
  123.         next   
  124.            
  125.         if len(c2to16(Unicode))=4 then   
  126.             ConvChinese=ConvChinese & chrw(int("&H" & c2to16(Unicode)))   
  127.         else   
  128.             ConvChinese=ConvChinese & chr(int("&H" & c2to16(Unicode)))   
  129.         end if   
  130.     next   
  131. end function   
  132.   
  133. function U8Decode(enStr)   
  134.   '输入一堆有%分隔的字符串,先分成数组,根据utf8规则来判断补齐规则   
  135.   '输入:关 E5 85 B3  键  E9 94 AE 字   E5 AD 97   
  136.   '输出:关 B9D8  键  BCFC 字   D7D6   
  137.   dim c,i,i2,v,deStr,WeiS   
  138.   
  139.   for i=1 to len(enStr)   
  140.     c=Mid(enStr,i,1)   
  141.     if c="%" then   
  142.       v=c16to2(Mid(enStr,i+1,2))   
  143.       '判断第一次出现0的位置,   
  144.       '可能是1(单字节),3(3-1字节),4,5,6,7不可能是2和大于7   
  145.       '理论上到7,实际不会超过3。   
  146.       WeiS=instr(v,"0")   
  147.       v=right(v,len(v)-WeiS)'第一个去掉最左边的WeiS个   
  148.       i=i+3   
  149.       for i2=2 to WeiS-1   
  150.         c=c16to2(Mid(enStr,i+1,2))   
  151.         c=right(c,len(c)-2)'其余去掉最左边的两个   
  152.         v=v & c   
  153.         i=i+3   
  154.       next   
  155.       if len(c2to16(v)) =4 then   
  156.         deStr=deStr & chrw(c2to10(v))   
  157.       else   
  158.         deStr=deStr & chr(c2to10(v))   
  159.       end if   
  160.       i=i-1   
  161.     else   
  162.       if c="+" then   
  163.         deStr=deStr" "  
  164.       else   
  165.         deStr=deStr&c   
  166.       end if   
  167.     end if   
  168.   next   
  169.   U8Decode = deStr   
  170. end function   
  171.   
  172. function c16to2(x)   
  173.  '这个函数是用来转换16进制到2进制的,可以是任何长度的,一般转换UTF-8的时候是两个长度,比如A9   
  174.  '比如:输入“C2”,转化成“11000010”,其中1100是"c"是10进制的12(1100),那么2(10)不足4位要补齐成(0010)。   
  175.  dim tempstr   
  176.  dim i:i=0'临时的指针   
  177.   
  178.  for i=1 to len(trim(x))   
  179.   tempstr= c10to2(cint(int("&h" & mid(x,i,1))))   
  180.   do while len(tempstr)<4   
  181.    tempstr="0" & tempstr'如果不足4位那么补齐4位数   
  182.   loop   
  183.   c16to2=c16to2 & tempstr   
  184.  next   
  185. end function   
  186.   
ASP/Visual Basic Code复制内容到剪贴板
  1. function c2to16(x)   
  2.   '2进制到16进制的转换,每4个0或1转换成一个16进制字母,输入长度当然不可能不是4的倍数了   
  3.   
  4.   dim i:i=1'临时的指针   
  5.   for i=1 to len(x)  step 4   
  6.    c2to16=c2to16 & hex(c2to10(mid(x,i,4)))   
  7.   next   
  8. end function   
  9.   
  10. function c2to10(x)   
  11.   '单纯的2进制到10进制的转换,不考虑转16进制所需要的4位前零补齐。   
  12.   '因为这个函数很有用!以后也会用到,做过通讯和硬件的人应该知道。   
  13.   '这里用字符串代表二进制   
  14.    c2to10=0   
  15.    if x="0" then exit function'如果是0的话直接得0就完事   
  16.    dim i:i=0'临时的指针   
  17.    for i= 0 to len(x) -1'否则利用8421码计算,这个从我最开始学计算机的时候就会,好怀念当初教我们的谢道建老先生啊!   
  18.     if mid(x,len(x)-i,1)="1" then c2to10=c2to10+2^(i)   
  19.    next   
  20. end function   
  21.   
  22. function c10to2(x)   
  23. '10进制到2进制的转换   
  24.   dim sign, result   
  25.   result = ""  
  26.   '符号   
  27.   sign = sgn(x)   
  28.   x = abs(x)   
  29.   if x = 0 then   
  30.     c10to2 = 0   
  31.     exit function   
  32.   end if   
  33.   do until x = "0"  
  34.     result = result & (x mod 2)   
  35.     x = x \ 2   
  36.   loop   
  37.   result = strReverse(result)   
  38.   if sign = -1 then   
  39.     c10to2 = "-" & result   
  40.   else   
  41.     c10to2 = result   
  42.   end if   
  43. end function   
  44.   
  45. function URLDecode(enStr)   
  46.   dim  deStr,strSpecial   
  47.   dim  c,i,v   
  48.   deStr=""  
  49.   strSpecial="!""#$%&'()*+,/:;<=>?@[\]^`{ |}~%"  
  50.   for  i=1  to  len(enStr)   
  51.     c=Mid(enStr,i,1)   
  52.     if  c="%"  then   
  53.     v=eval("&h"+Mid(enStr,i+1,2))   
  54.     if  inStr(strSpecial,chr(v))>0  then   
  55.     deStr=deStr&chr(v)   
  56.     i=i+2   
  57.     else   
  58.     v=eval("&h"+Mid(enStr,i+1,2)+Mid(enStr,i+4,2))   
  59.     deStr=deStr&chr(v)   
  60.     i=i+5   
  61.     end  if   
  62.     else   
  63.     if  c="+"  then   
  64.     deStr=deStr" "  
  65.     else   
  66.     deStr=deStr&c   
  67.     end  if   
  68.     end  if   
  69.   next   
  70.   URLDecode=deStr   
  71. end function   
  72.   

许多代码都是网上的.找不到作者.

PS:现在暑假就要接受,由于家庭原因我不想留在我的城市.中考到达本地重点.不想说城市名字.否则会招来熟人.只要不在山东的学校算是重点的能不能联系下.

 

对程序有极大兴趣,但信息奥赛只活得一等的X名.因为我认为技术不应该在所谓竞赛中体现,就如才能不应该在那些无意义的考试中体现一样.电子作品也弄了各省一等..不过也一般.学习一般...所以只要是一般重点就好了..只是不想在离家太近的地方.

现在asp十分熟练,虽然有些知识缺陷,比如编码问题(汗...),但是网络如此大,我想我不是只有在课本中才能得到所谓的知识.而且现在正在啃asp.net的书,如果贵校做网站完全可以帮忙.

对新技术十分狂热,虽然被他们称为审美有障碍的人.但我想看到结构偶的程序还不至于吐血.

算了..再贴点.

偶开发D Database+asp ->xml+xslt->xhtml +css 的算是叫CMS的东西

http://www.joysou.com

也用了CSDN用的FCK编辑器,今天上来才发现换了.不过那个FCK的FIle系统让偶统统改掉.

这个系统在暑假结束前一定会发布.不过很多朋友说易用性有问题...很多人不会xslt.汗...

作者:
与好友一起分享精彩内容:

收藏到QQ书签】【返回顶部】【返回首页
关于站点 - 广告服务 - 联系我们 - 版权隐私 - 免责声明 - 程序支持 - 网站地图 - 意见反馈 - 返回顶部