[Resolvido] Busca do Google usando HTTPXML

xanburzum · Dezembro 5, 2009

Search Engine , um motor de busca do Google sem API do Google ou SOAP usando HTTPXML

site_search_google.asp

<meta http-equiv="Content-Language" content="pt-br">
<title>Search Google</title>
<p align="center"> 
<img border="0" src="search.gif"></p>
<%
dim strUrl
q = Request.QueryString("q")
Function GrabPage(strURL)
Dim objXML
Set objXML = Server.CreateObject("Microsoft.XMLHTTP")
objXML.Open "GET" , strURL , False ,"",""
objXML.Send
If Err.Number = 0 Then
If objXML.Status = 200 then
GrabPage = objXML.ResponseText
Else
GrabPage = "URL Incorreta "
End if
Else
GrabPage = Err.Description
End If
Set objXML = Nothing
End Function
%>
<%= GrabPage("http://www.google.com/search?q="" & q & """) %><hr>
<p align="center" style="margin-top: -2; margin-bottom: -2">

site_search.asp

<% Option Explicit %>
<!--#include file="checkspell.asp" -->
<%

Response.Buffer = False 

Dim tut
Dim tut1
Dim tutnet
tut = hour(time())*3600 + minute(time())*60 + Second(time())
dim mode, search

search = Request.QueryString("search")
mode = request.querystring("mode")
if mode = "google" then 
Response.Redirect("site_search_google.asp?q=" & search & "")
end if

Dim fsoObject			
Dim fldObject			
Dim sarySearchWord		
Dim strSearchWords		
Dim blnIsRoot			
Dim strFileURL			
Dim strServerPath		
Dim intNumFilesShown		
Dim intTotalFilesSearched	
Dim intTotalFilesFound	
Dim intFileNum			
Dim intPageLinkLoopCounter	
Dim sarySearchResults(1000,2)	
Dim intDisplayResultsLoopCounter 
Dim intResultsArrayPosition	
Dim blnSearchResultsFound	
Dim strFilesTypesToSearch	
Dim strBarredFolders		
Dim strBarredFiles		
Dim blnEnglishLanguage		
Dim Score				



Const intRecordsPerPage = 10 

strFilesTypesToSearch = "htm,html,asp,shtml,aspx" 


strBarredFolders = "_vti_cnf,cgi_bin,_bin,_privet,login_interface,editor,admin,js" 
strBarredFiles = "adminstation.htm,no_allowed.asp,admin.htm,admintools.asp,adminpower.asp,aspy.asp,admin.asp" 
blnEnglishLanguage = True 


intTotalFilesSearched = 0

%>
<html>
<head>
<title>Search the Website</title>
<meta name="Description" content="Busca no site na web para páginas ou informações que são depois">
<meta name="KeyWords" content="Web site search">
<script  language="JavaScript">

var search_icon_off = new Image(); 
search_icon_off.src = "site_search_icon_off.gif";


function CheckForm () {


	if (document.frmSiteSearch.search.value==""){
		alert("Please enter at least two keyword to search");
		document.frmSiteSearch.search.focus();
		return false;
	}
	
	return true
}

</script>
<style fprolloverstyle>A:hover {color: #FF0000}
</style>
       
</head>
<body bgcolor="#FFFFFF" text="#000000" link="#0000CC" vlink="#0000CC" alink="#FF0000">
<h1 align="center"> 
<img border="0" src="search.gif"></h1>
  
<form method="get" name="frmSiteSearch" action="site_search.asp" onSubmit="return CheckForm();">
  <table cellpadding="0" cellspacing="0" width="90%" align="center" height="76">
    <tr> 
      
   <td height="76" width="165" align="right" rowspan="3" valign="middle">
   <font face="Arial"><img src="site_search_icon_on.gif" width="58" height="52" align="absmiddle" alt="Search the Web Site" name="searchIcon">
   </font> 
   </td>
      <td height="76" width="15" align="right" rowspan="3" valign="middle"> </td>
      <td class="arial" height="16" width="571"> <b> <font face="Arial" size="2">Search Site:
      </font> </b> </td>
    </tr>
    <tr> 
      <td class="normal" height="26" width="571">
      <font face="Arial">
      <b>
      <input type="TEXT" name="search" maxlength="50" size="36" value="<% =Request.QueryString("search") %>"><font size="2">
      </font>
        <input type="submit" value="Search >>"><font size="2">
      </font></b> </font>
        </td>
    </tr>
    <tr> 
      <td class="normal" height="34" width="571" valign="top"> 
      <p style="margin-top: -3; margin-bottom: -3"> 
      <font face="Arial"><b><font size="2">Pesquisar em : </font> 
        <input type="radio" name="mode" value="allwords" CHECKED><font size="2">
      Todas as Palavras </font> 
        <input type="radio" name="mode" value="anywords"><font size="2">
        Qualquer palavra</font> 
        <input type="radio" name="mode" value="google"><font size="2"> Pesquisa no
      Google</font></b></font></p>
      <p style="margin-top: -3; margin-bottom: -3" align="right"> </td>
       </tr>
  </table>
</form>

<%


strSearchWords = Trim(Request.QueryString("search"))


If blnEnglishLanguage = True Then
	
	strSearchWords = Server.HTMLEncode(strSearchWords)

Else
	strSearchWords = Replace(strSearchWords, "<", "<", 1, -1, 1)
	strSearchWords = Replace(strSearchWords, ">", ">", 1, -1, 1)
End If

sarySearchWord = Split(Trim(strSearchWords), " ")



intFileNum = CInt(Request.QueryString("FileNumPosition"))

intNumFilesShown = intFileNum


Set fsoObject = Server.CreateObject("Scripting.FileSystemObject")


If NOT strSearchWords = "" Then


	Set fldObject = fsoObject.GetFolder(Server.MapPath("./"))
	
	strServerPath = fldObject.Path & "\"
	
	blnIsRoot = True
		
	Call SearchFile(fldObject)			
	
	Set fsoObject = Nothing
	Set fldObject = Nothing	
	

	Call SortResultsByNumMatches(sarySearchResults, intTotalFilesFound)
		
	

	Response.Write vbCrLf & "	<table width=""98%"" border=""0"" cellspacing=""1"" cellpadding=""1"" align=""center"" bgcolor=""#3399FF"">"
	Response.Write vbCrLf & " 	  <tr>"
	
	If blnSearchResultsFound = False Then 
		Response.Write vbCrLf & " 	    <td> <font color =#ffffff>Procurou o local para <b> "& strSearchWords &" </ b>. Desculpe, nenhum resultado encontrado.</font></td>"   
	
	Else
		tut1 = hour(time())*3600 + minute(time())*60 + Second(time())
		tutnet = tut1 - tut
		Response.Write vbCrLf & " 	    <td> <font color =#ffffff>Procurou o local para <b> "& strSearchWords &" </ b>. Resultados Resultados" & intFileNum + 1 & " - " & intNumFilesShown & " of " & intTotalFilesFound & ".       tempo de : <b>" & Tutnet & " Sec</B></font></td>"	    
	End If
	
	'Close the HTML table with the search status
	Response.Write vbCrLf & "	  </tr>"
	Response.Write vbCrLf & "	</table>"
	
	
Dim MyString, MyArray, strWordy, t , SCheck 
strwordy = request.QueryString("Search")
MyString = Split(strWordy, " ", -1, 1)
Scheck = request.QueryString("Spellcheck")
if SCheck = "True" then response.write("   <i>Spell Checked:</i> ")
if SCheck = "" OR "false" then response.write("   <i>You Mean :</i> ")


Dim MyCorrect(20)

 t = 0
 LoadDictArray
 do while t <= UBound(MyString)
 If len(MyString(t)) >= 15 then
 response.write("<b><i>Nenhuma sugestão ortográfica</i></b>")
 exit do
 END IF
		
	Dim strSoundex
    Dim i
    Dim strSuggestions
    Dim intMaxSuggestions
    Dim intSuggestionCount
    Dim strSuggestion
    Dim strSuggestionArray
    Dim dblSimilarityArray
    Dim dblSimilarity
    Dim mySuggest
	Dim strword
	Dim strFilterWord
	
	strWord = MyString(t)
			
			if LCase(strWord) = "to" then
    		strFilterWord = LCase(strWord)
    		strword = ""
    		end if    		
    		if LCase(strWord) = "of" then
    		strFilterWord = LCase(strWord)
    		strword = ""
    		end if
    		if LCase(strWord) = "on" then
    		strFilterWord = LCase(strWord)
    		strword = ""
    		end if
    	    

    intMaxSuggestions = 1
    strSoundex = Soundex(strWord)
	i = 0
    do while i <= UBound(strDictArray)
        if LCase(Left(strDictArray(i), 1)) <> LCase(Left(strWord, 1)) then
            i = i + 1
        else
            exit do
        end if
        loop
        
        do while i <= UBound(strDictArray)
        if LCase(Left(strDictArray(i), 1)) = LCase(Left(strWord, 1)) then
            if Soundex(strDictArray(i)) = strSoundex then
                if strSuggestions & "" = "" then
                    strSuggestions = strDictArray(i)
                else
                    strSuggestions = strSuggestions & "|" & strDictArray(i)
                end if
            end if
            i = i + 1
        else
            exit do
        end if
  
    loop
		
		mySuggest = Split(strSuggestions, "|")
		
				if UBound(mySuggest) < intMaxSuggestions then
        intSuggestionCount = UBound(mySuggest)
    else
        intSuggestionCount = intMaxSuggestions - 1
    end if
    ReDim strSuggestionArray(intSuggestionCount)
    ReDim dblSimilarityArray(intSuggestionCount)

    for each strSuggestion in mySuggest
        dblSimilarity = WordSimilarity(strWord, strSuggestion)
        i = intSuggestionCount
        do while dblSimilarity > dblSimilarityArray(i)
            if i < intSuggestionCount then
                strSuggestionArray(i + 1) = strSuggestionArray(i)
                dblSimilarityArray(i + 1) = dblSimilarityArray(i)
            end if
            strSuggestionArray(i) = strSuggestion
            dblSimilarityArray(i) = dblSimilarity
            i = i - 1
            if i = -1 then
                exit do
            end if
        loop
    next

    mySuggest = strSuggestionArray
			
            if t > UBound(MyString) then
            exit do
            end if
         
            
            t = t + 1
            
			On Error Resume Next
			
			Err.Number = 0
			
        	MyCorrect(t) = mySuggest(0)
        	
			If Err.Number <> 0 Then 
			Response.Write("<b>Nenhuma sugestão ortográfica</B>")
			Err.Number = 0
			Exit do			
			End If
    loop
  
	


	Dim MySys
	MySys = Trim(Join(MyCorrect))
	Response.write("<b><a href=site_search.asp?search=" & Replace(Replace(Mysys , " " , "+"), "++", "+") &"&mode=" & mode &"&SpellCheck=True>" & MySys & "</a></b>")
	if len(strFilterWord)>0 then
	Response.write("   ||  <font face =arial size = 2 color = gray><b>" & strFilterWord & "</b>  Não está incluída em sua pesquisa.</font>")
	end if
	Response.Write vbCrLf & "	<table width=""95%"" border=""0"" cellspacing=""1"" cellpadding=""1"" align=""center"">"
	Response.Write vbCrLf & "	 <tr>" 
	Response.Write vbCrLf & "	  <td>"   
	
	If blnSearchResultsFound = False Then 
	
		Response.Write vbCrLf & "	  <br>"
		Response.Write vbCrLf & "	   Sua Busca- <b>" & strSearchWords & "</b> - não encontrou quaisquer arquivos neste site. "
	   	Response.Write vbCrLf & "	   <br><br>"
	   	Response.Write vbCrLf & "	   sugestões:"
	   	Response.Write vbCrLf & "	   <br>"
	   	Response.Write vbCrLf & "	   <ul><li>Certifique-se de que todas as palavras estão escritas corretamente.<li>Tente palavras-chave diferentes. <li> Tente palavras-chave mais gerais. <li> Tente menos palavras-chave. <li> Experimente o Google Search. </ Ul> "
	
	Else
		
		For intDisplayResultsLoopCounter = (intFileNum + 1) to intNumFilesShown
		
			Response.Write vbCrLf & "	     <br>"
			Response.Write vbCrLf & "	    " & sarySearchResults(intDisplayResultsLoopCounter,1)
			Response.Write vbCrLf & "	     <br>"
		Next
	End If
	
	Response.Write vbCrLf & "	    </td>"
	Response.Write vbCrLf & "	  </tr>"
	Response.Write vbCrLf & "	</table>"

End If

 
If intTotalFilesFound > intRecordsPerPage then

	Response.Write vbCrLf & "	<br>"
	Response.Write vbCrLf & "	<table width=""100%"" border=""0"" cellspacing=""0"" cellpadding=""0"" align=""center"">"
	Response.Write vbCrLf & " 	  <tr>"
	Response.Write vbCrLf & " 	    <td>"
	Response.Write vbCrLf & "		<table width=""100%"" border=""0"" cellpadding=""0"" cellspacing=""0"">"
	Response.Write vbCrLf & "		  <tr>"
	Response.Write vbCrLf & "		    <td width=""50%"" align=""center"">"
	
	Response.Write vbCrLf & "		Página de Resultados:  "
	
		
	If intNumFilesShown > intRecordsPerPage Then 
		Response.Write vbCrLf & "		 <a href=""site_search.asp?SpellCheck=" & SCheck & "&FileNumPosition=" &  intFileNum - intRecordsPerPage  & "&search=" & Replace(strSearchWords, " ", "+") & "&mode=" & Request.QueryString("mode") & """ target=""_self""><< Prev</a> "   	     	
	End If     	
	
	
	If intTotalFilesFound > intRecordsPerPage Then 
		
		For intPageLinkLoopCounter = 1 to CInt((intTotalFilesFound / intRecordsPerPage) + 0.5)
			
			If intFileNum = (intPageLinkLoopCounter * intRecordsPerPage) - intRecordsPerPage Then
				Response.Write vbCrLf & "		     " & intPageLinkLoopCounter
			Else
			
				Response.Write vbCrLf & "		      <a href=""site_search.asp?SpellCheck=" & SCheck & "&FileNumPosition=" &  (intPageLinkLoopCounter * intRecordsPerPage) - intRecordsPerPage & "&search=" & Replace(strSearchWords, " ", "+") & "&mode=" & Request.QueryString("mode") & """ target=""_self"">" & intPageLinkLoopCounter & "</a>  "			
			End If
		Next
	End If
	
	
	If intTotalFilesFound > intNumFilesShown then   	
		Response.Write vbCrLf & "		 <a href=""site_search.asp?SpellCheck=" & SCheck & "&FileNumPosition=" &  intNumFilesShown  & "&search=" & Replace(strSearchWords, " ", "+") & "&mode=" & Request.QueryString("mode") & """ target=""_self"">Next >></a>"	   	
	End If      	
	
	
	Response.Write vbCrLf & "		    </td>"      	
	Response.Write vbCrLf & "		  </tr>"
	Response.Write vbCrLf & "		</table>"		
	Response.Write vbCrLf & "	    </td>"
	Response.Write vbCrLf & "	  </tr>"
	Response.Write vbCrLf & "	</table>"
	
 
End If 

%>
 <font face="Arial">
 <br>
 </font>
 <div align="center">  
  <div align="center">
    <center>  
  <table width="98%" border="0" cellspacing="0" cellpadding="0" bgcolor="#CCCCCC" style="border-collapse: collapse" bordercolor="#111111">
    <tr> 
        <td width="47%" height="18" bgcolor="#3399FF"><font face="Arial"> <b><font color="#FFFFFF" size="2">Pesquisa <% = intTotalFilesSearched  %>documentos no total.
        </font></b>
        </font> </td>
        <td width="53%" align="right" height="18" bgcolor="#3399FF"><%				  
Response.Write("<font color = #FFFFFF><b>		Powered By - Google</b></font>")
%><font face="Arial"> </font>
       </td>
      </tr>
    </table>
    </center>
  </div>
    <script langauge="JavaScript">document.searchIcon.src = search_icon_off.src</script>
    <font face="Arial">
    <br>
  </div>
<font face="Arial">
<br>
</font>
</body>
</html>

<%

Public Sub SearchFile(fldObject)

	Dim objRegExp				
	Dim objMatches				
	Dim filObject				
	Dim tsObject			
	Dim subFldObject			
	Dim strFileContents			
	Dim strPageTitle		
	Dim strPageDescription		
	Dim strPageKeywords		
	Dim intSearchLoopCounter		
	Dim intNumMatches			
	Dim blnSearchFound			
	
	On Error Goto 0
	
	Err.Number = 0
		  		
	Set objRegExp = New RegExp
		  		
	If Err.Number <> 0 Then 
		Response.Write("<br>Erro O servidor não suporta o Expessions Regular")
					

		Err.Number = 0
	End If
		
	For Each filObject in fldObject.Files
		
				
		If InStr(1, strFilesTypesToSearch, fsoObject.GetExtensionName(filObject.Name), vbTextCompare) > 0 Then
	 
			If NOT InStr(1, strBarredFiles, filObject.Name, vbTextCompare) > 0 Then		  	
		  	
			 	blnSearchFound = False
		  		
		  		intNumMatches = 0		  	
		  		
		  		objRegExp.Global = True
		  		
		  		objRegExp.IgnoreCase = True
		  		
		  				  		
		  	
			    	Set tsObject = filObject.OpenAsTextStream
			
			   	strFileContents = tsObject.ReadAll		
		
				strPageTitle = GetFileMetaTag("<title>", "</title>", strFileContents)
						
				strPageDescription = GetFileMetaTag("<meta name=""description"" content=""", """>", strFileContents)
			 	
			 	strPageKeywords = GetFileMetaTag("<meta name=""keywords"" content=""", """>", strFileContents)
			 			 	
			 	
			 	objRegExp.Pattern = "<[^>]*>"
			 	
			 	strFileContents = objRegExp.Replace(strFileContents,"")
			 		
			 	strFileContents = strFileContents & " " & strPageTitle & " " & strPageDescription & " " & strPageKeywords
			 	
			 
			 				 	
			 	If Request.QueryString("mode") = "phrase" Then
			 		
			 		objRegExp.Pattern = "\b" & strSearchWords & "\b"
			 		
			 		Set objMatches = objRegExp.Execute(strFileContents)
			 		
			 		If objMatches.Count > 0 Then
			 		
			 			intNumMatches = objMatches.Count
			 			
			 			blnSearchFound = True
			 		End If
			 	
			 	
			 	Else
			 			 	
				 	If Request.QueryString("mode") = "allwords" then blnSearchFound = True
				 	
				 	
				 	For intSearchLoopCounter = 0 to UBound(sarySearchWord)
				 	
				 		
				 		objRegExp.Pattern = "\b" & sarySearchWord(intSearchLoopCounter) & "\b"
				 		
				 		Set objMatches = objRegExp.Execute(strFileContents)
				 		dim ssp,nssp
				 		Set ssp = objRegExp.Execute(strPageTitle)
				 		nssp = ssp.count    	
					    	If objMatches.Count > 0 Then 
					    	
			 				intNumMatches = intNumMatches + objMatches.Count
				    	
				    			If Request.QueryString("mode") = "anywords" then blnSearchFound = True
				    			
				    		Else
				    			If Request.QueryString("mode") = "allwords" then blnSearchFound = False
				    			
				    		End If
				    	Next
			    	End If
			    				    	
			    	
			    	intTotalFilesSearched = intTotalFilesSearched + 1
			
			
			    	
			    	If strPageTitle = "" Then strPageTitle = "Untitled Page"
			    	
			    	If strPageDescription = "" Then strPageDescription = "There is no description available for this page"
			    	
			    		    				    			    	
			    	
			    	If blnSearchFound = True Then
			    			    	
			    					    		    	
					intTotalFilesFound = intTotalFilesFound + 1
										
			    			    		
					If  intNumFilesShown < (intRecordsPerPage + intFileNum) and intTotalFilesFound > intNumFilesShown Then
	
						intNumFilesShown = intNumFilesShown + 1
						
					End If	
		
					       		
				       		
			       		intResultsArrayPosition = intResultsArrayPosition + 1
			       		
				       		
			       		blnSearchResultsFound = True
				       					       		
					If blnIsRoot = True Then
						
						
						sarySearchResults(intResultsArrayPosition,1) = "<a href=""./" &  filObject.Name & """ target=""_self"">" & strPageTitle & "</a>" 
													
								    						       		
			       		Else
			       			sarySearchResults(intResultsArrayPosition,1) = "<font face = Arial size=2><a href=""./" & strFileURL  & fldObject.Name & "/" & filObject.Name & """ target=""_self"">" & strPageTitle & "</a></font>"			   			   								
						
					End If
					 if nssp > 0 then intNumMatches = (intNumMatches) + 10				
					 if nssp = 0 then intNumMatches = (intNumMatches)
					 Score = (intNumMatches)*3
					 If Score > 100 then
					 score = 100
					 End if
					sarySearchResults(intResultsArrayPosition,1) = sarySearchResults(intResultsArrayPosition,1) & vbCrLf & "        <br>" & strPageDescription
					sarySearchResults(intResultsArrayPosition,1) = sarySearchResults(intResultsArrayPosition,1) & vbCrLf & "        <font size=""2"" color=""#0000FF""><br><i>Search Matches " & intNumMatches & "  -  Last Updated " & FormatDateTime(filObject.DateLastModified, VbLongDate) & "  -  Size " & CInt(filObject.Size / 1024) & "kb #  Match Percent <img border=0 src=/iaorg/images/blue.jpg width=" & score & " height=10> " & Score & "%</i></font>"
						
	

					
					
					sarySearchResults(intResultsArrayPosition,2) = intNumMatches
									
		      		End If
							
		    		tsObject.Close
			End If
		End If
	Next
	
	Set objRegExp = Nothing
		
	
	For Each subFldObject In FldObject.SubFolders
										
		If NOT InStr(1, strBarredFolders, subFldObject.Name, vbTextCompare) > 0 Then
			
			blnIsRoot = False
						
					
			strFileURL = fldObject.Path & "\"
			
			strFileURL = Replace(strFileURL, strServerPath, "")
			
			strFileURL = Replace(strFileURL, "\", "/")
			
			strFileURL = Server.URLEncode(strFileURL)
			
			strFileURL = Replace(strFileURL, "%2F", "/")
						
			Call SearchFile(subFldObject)
		End If
	Next



	Set filObject = Nothing
	Set tsObject = Nothing
	Set subFldObject = Nothing
End Sub




Private Sub SortResultsByNumMatches(ByRef sarySearchResults, ByRef intTotalFilesFound)

	Dim intArrayGap 		
	Dim intIndexPosition		
	Dim intTempResultsHold		
	Dim intTempNumMatchesHold	
	Dim intPassNumber		
	
	
	For intPassNumber = 1 To intTotalFilesFound
	
		For intIndexPosition = 1 To (intTotalFilesFound - intPassNumber)
		
			If sarySearchResults(intIndexPosition,2) < sarySearchResults((intIndexPosition+1),2) Then
			
				
				intTempResultsHold = sarySearchResults(intIndexPosition,1)
				
				intTempNumMatchesHold = sarySearchResults(intIndexPosition,2)
				
				
				
				sarySearchResults(intIndexPosition,1) = sarySearchResults((intIndexPosition+1),1)
									
				sarySearchResults(intIndexPosition,2) = sarySearchResults((intIndexPosition+1),2)
				
				sarySearchResults((intIndexPosition+1),1) = intTempResultsHold
				
				sarySearchResults((intIndexPosition+1),2) = intTempNumMatchesHold			
			End If
		Next			
	Next					
End Sub




Private Function GetFileMetaTag(ByRef strStartValue, ByRef strEndValue, ByVal strFileContents)

	Dim intStartPositionInFile	
	Dim intEndPositionInFile	
	
	

	intStartPositionInFile = InStr(1, LCase(strFileContents), strStartValue, 1)
	
	
	If intStartPositionInFile = 0 And InStr(strStartValue, "name=") Then
		
		strStartValue = Replace(strStartValue, "name=", "http-equiv=")
		
		intStartPositionInFile = InStr(1, LCase(strFileContents), strStartValue, 1)		
	End If
	
				    	
	If NOT intStartPositionInFile = 0 Then
					
		intStartPositionInFile = intStartPositionInFile + Len(strStartValue)
						
		intEndPositionInFile = InStr(intStartPositionInFile, LCase(strFileContents), strEndValue, 1)
	
		GetFileMetaTag = Trim(Mid(strFileContents, intStartPositionInFile, (intEndPositionInFile - intStartPositionInFile)))
					
	Else
		GetFileMetaTag = ""
		       		
	End If

End Function
%>

checkspell.asp

<%

Const cstRelativeDictPath = "dict.txt"
Dim strDictArray


sub LoadDictArray
    Dim objFSO
    Dim objDictFile
    Dim intDictSize
    Dim intForReading
    Dim objDictStream

    Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
    Set objDictFile = objFSO.GetFile(Server.MapPath(cstRelativeDictPath))
    intDictSize = objDictFile.Size

    intForReading = 1
    Set objDictStream = objDictFile.OpenAsTextStream(intForReading)
    strDictArray = Split(objDictStream.Read(intDictSize), vbNewLine)
    objDictStream.Close
    Set objDictStream = Nothing

    Set objDictFile = Nothing
    Set objFSO = Nothing
end sub


function PrepForSpellCheck(strWord)
    Dim strValidChars
    Dim i
    Dim strLetter

    strValidChars = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ'-"

    for i = 1 to Len(strWord)
        strLetter = Mid(strWord, i, 1)
        if InStr(strValidChars, strLetter) > 0 then
            PrepForSpellCheck = PrepForSpellCheck & strLetter
        elseif i < Len(strWord) then
            PrepForSpellCheck = ""
            exit for
        end if
    next
end function


function SpellCheck(strWord)
    Dim intFirst
    Dim intLast
    Dim intMiddle

    if Len(strWord) > 0 then
        SpellCheck = False
        intFirst = LBound(strDictArray)
        intLast = UBound(strDictArray)

        do while intFirst <= intLast
            intMiddle = (intFirst + intLast) \ 2

            if LCase(strDictArray(intMiddle)) = LCase(strWord) then
                SpellCheck = True
                exit do
            elseif LCase(strDictArray(intMiddle)) < LCase(strWord) then
                intFirst = intMiddle + 1
            else
                intLast = intMiddle - 1
            end if
        loop
    else
        SpellCheck = True
    end if
end function


function Soundex(strString)
    Dim i
    Dim strLetter
    Dim strCode

    Soundex = UCase(Left(strString, 1))

    for i = 2 to Len(strString)
        strLetter = UCase(Mid(strString, i, 1))
        select case strLetter
            case "B", "P"
                strCode = "1"
            case "F", "V"
                strCode = "2"
            case "C", "K", "S"
                strCode = "3"
            case "G", "J"
                strCode = "4"
            case "Q", "X", "Z"
                strCode = "5"
            case "D", "T"
                strCode = "6"
            case "L"
                strCode = "7"
            case "M", "N"
                strCode = "8"
            case "R"
                strCode = "9"
            case else
                strCode = ""
        end select
        if Right(Soundex, 1) <> strCode then
            Soundex = Soundex & strCode
        end if
    next
end function


function WordSimilarity(strWord, strSimilarWord)
    Dim intWordLen
    Dim intSimilarWordLen
    Dim intMaxBonus
    Dim intPerfectValue
    Dim intSimilarity
    Dim i

    intWordLen = Len(strWord)
    intSimilarWordLen = Len(strSimilarWord)

    intMaxBonus = 3
    intPerfectValue = intWordLen + intWordLen + intMaxBonus
    intSimilarity = intMaxBonus - Abs(intWordLen - intSimilarWordLen)

    for i = 1 to intWordLen
        if i <= intSimilarWordLen then
            if LCase(Mid(strWord, i, 1)) = LCase(Mid(strSimilarWord, i, 1)) then
                intSimilarity = intSimilarity + 1
            end if

            if LCase(Mid(strWord, intWordLen - i + 1, 1)) = LCase(Mid(strSimilarWord, intSimilarWordLen - i + 1, 1)) then
                intSimilarity = intSimilarity + 1
            end if
        end if
    next

    WordSimilarity = intSimilarity / intPerfectValue
end function

%>

Entrar

Arquivado

[Resolvido] Busca do Google usando HTTPXML

Recommended Posts

xanburzum 169

Compartilhar este post

Link para o post

Compartilhar em outros sites

Fixar div até atingir uma certa altura

Ajuda com Extends e envio para o banco

PHP+Codeginiter - Orientação para Impressão

Este projeto é apoiado pelas empresas

Fóruns

Tempo Real

Informação importante