Classe para pesquisa

xanburzum · Dezembro 21, 2008

Este código faz uma busca dentro de arquivos do site.

Como usar

<%Dim ss
Set ss = New SiteSearch

ss.Filter = "htm,html,asp"
ss.Folder = Server.MapPath("./")
ss.IncludeSubFolders = True
ss.WholeWord = True

ss.SearchFolder "substring a ser pesquisada"

For i = 0 To ss.TotalMatches
	Response.Write ss.Match(i).Title & " -> " & ss.Match(i).Path & "<br>"
	Response.Write ss.Match(i).Text & "<br><br>"
Next

Class SiteSearch
	
	Private pFilter				  'Filtro das extensões de arquivo a serem buscados
	Private pFolder				  'Nome da pasta a ser buscada pela sub SearchFolder
	Private pFiles				   'Lista de nomes de arquivos a serem buscados pela sub SearchFile
	Private pGlobal				  'Se for False, retorna no máximo uma ocorrência por arquivo
	Private pIgnoreCase			  'Busca sensível a caixa
	Private pIgnoreHTML			  'Se for True, reconhece as codificações de caracteres em HTML
	Private pFullText				'Se for True, busca também dentro dos scripts, inclusive ASP
	Private pMaxResults			  'Número máximo de resultados, se for zero retorna todos possíveis
	Private pIncludeSubFolders	   'Se for True, SearchFolder busca também dentro das subpastas
	Private pTotalMatches			'Read-only, total de resultados encontrados
	Private pCharsLeft			   'Número de caracteres a serem copiados do lado esquerdo da ocorrência
	Private pCharsRight			  'Número de caracteres a serem copiados do lado direito da ocorrência
	Private pTotalFolders			'Read-only, número de pastas buscadas
	Private pTotalFiles			  'Read-only, número de arquivos buscados
	Private pMatch				   'Array de resultados, ver objeto SearchItem abaixo
	Private pIndex
	Private pSubstr
	Private pFilterArray
	Private pFilterBnd
	Private pTime
	Private pWholeWord				 'Se for True, a rotina trata a substring buscada como uma palavra inteira.
	Private pREG_WORD
	
	
	Private Sub Class_Initialize()
	
		pMatch			 = Array()
		pIndex			 = -1
		
		pREG_WORD		  = "[a-z0-9áéíóúàèìòùâêîôûãõñýäëïöüç]"
		pFilter			= "htm,html,asp"
		pFolder			= "."
		pFiles			 = ""
		
		pGlobal			= True
		pIgnoreCase		= True
		pIgnoreHTML		= True
		pFullText		  = False
		pIncludeSubFolders = False
		pWholeWord		 = True
		
		pMaxResults		= 0
		pTotalMatches	  = 0
		pCharsLeft		 = 80
		pCharsRight		= 80
		pTotalFolders	  = 0
		pTotalFiles		= 0
		
	End Sub
	
	
	Public Property Get Filter()
		Filter = pFilter
	End Property
	Public Property Let Filter(ByVal s)
		If Not ereg("^[a-zA-Z0-9~$@.]+(,[a-zA-Z0-9~$@.]+)*$", s) Then
			Err.Raise 1003, "SiteSearch Class", "Filter property: Invalid argument: " & s
		End If
		pFilter = s
	End Property
	
	Public Property Get Folder()
		Folder = pFolder
	End Property
	Public Property Let Folder(ByVal s)
		pFolder = s & ""
	End Property
	
	Public Property Get Files()
		Files = pFiles
	End Property
	Public Property Let Files(ByVal s)
		pFiles = s & ""
	End Property
	
	Public Property Get Global()
		Global = pGlobal
	End Property
	Public Property Let Global(ByVal s)
		If s Then pGlobal = True Else pGlobal = False
	End Property
	
	Public Property Get IgnoreCase()
		IgnoreCase = pIgnoreCase
	End Property
	Public Property Let IgnoreCase(ByVal s)
		If s Then pIgnoreCase = True Else pIgnoreCase = False
	End Property
	
	Public Property Get IgnoreHTML()
		IgnoreHTML = pIgnoreHTML
	End Property
	Public Property Let IgnoreHTML(ByVal s)
		If s Then pIgnoreHTML = True Else pIgnoreHTML = False
	End Property
	
	Public Property Get FullText()
		FullText = pFullText
	End Property
	Public Property Let FullText(ByVal s)
		If s Then pFullText = True Else pFullText = False
	End Property
	
	Public Property Get MaxResults()
		MaxResults = pMaxResults
	End Property
	Public Property Let MaxResults(ByVal s)
		pMaxResults = CInt(s)
	End Property
	
	Public Property Get IncludeSubFolders()
		IncludeSubFolders = pIncludeSubFolders
	End Property
	Public Property Let IncludeSubFolders(ByVal s)
		If s Then pIncludeSubFolders = True Else pIncludeSubFolders = False
	End Property
	
	Public Property Get TotalMatches()
		TotalMatches = pTotalMatches
	End Property
	
	Public Property Get CharsLeft()
		CharsLeft = pCharsLeft
	End Property
	Public Property Let CharsLeft(ByVal s)
		pCharsLeft = CInt(s)
	End Property
	
	Public Property Get CharsRight()
		CharsRight = pCharsRight
	End Property
	Public Property Let CharsRight(ByVal s)
		pCharsRight = CInt(s)
	End Property
	
	Public Property Get TotalFolders()
		TotalFolders = pTotalFolders
	End Property
	
	Public Property Get TotalFiles()
		TotalFiles = pTotalFiles
	End Property
	
	Public Property Get Match(ByVal i)
		Set Match = pMatch(i)
	End Property
	
	Public Property Get Substr()
		Substr = pSubstr
	End Property
	Public Property Let Substr(ByVal s)
		pSubstr = s & ""
	End Property
	
	Public Property Get TimeSecs()
		TimeSecs = pTime
	End Property
	
	Public Property Get WholeWord()
	  WholeWord = pWholeWord
	End Property
	Public Property Let WholeWord(ByVal p)
	  If p Then pWholeWord = True Else pWholeWord = False
	End Property
	
	
	'Chame esta sub para fazer a busca na pasta especificada
	'pela propriedade Folder	
	Public Sub SearchFolder(ByVal Substr)
		
		Dim t_ini, t_fim, f, Obj
		Call InitConfig(Substr)
		
		Substr = Substr & ""
		If Trim(Substr) = "" Then
			Exit Sub
		End If
		
		If pFolder = "." Then
			f = CurrentFolder()
		Else
			f = pFolder
		End If
		
		On Error Resume Next
		Set Obj = GetFolder(f)
		If Err Then
			Err.Clear
			On Error GoTo 0
			Err.Raise 1004, "SiteSearch Class", "Search method: Invalid folder path: " & f
		End If
		On Error GoTo 0
		
		t_ini = Now()
		DoSearchFolder Obj
		Set Obj = Nothing
		t_fim = Now()
		
		pTime = CLng((t_fim - t_ini) / VB_SECOND)
		
	End Sub
	
	
	Public Sub SearchFile(ByVal Substr)
		
		Dim t_ini, t_fim
		Dim a, Obj, i
		
		Call InitConfig(Substr)
		
		Substr = Substr & ""
		If Trim(Substr) = "" Then
			Exit Sub
		End If
		
		a = Split(pFiles, ",")
		
		t_ini = Now()
		
		For i = 0 To UBound(a)
			If GoodFile(GetFileExt(a(i))) Then
				On Error Resume Next
				Set Obj = GetFile(Server.MapPath(a(i)))
				On Error GoTo 0
				If Err Then
					Err.Clear
				Else
					MainSearch Obj
				End If
			End If
		Next
		
		t_fim = Now()
		pTime = CLng((t_fim - t_ini) / VB_SECOND)
		
	End Sub
	
	
	Private Sub InitConfig(ByRef Substr)
		
		pIndex = -1
		pMatch = Array()
		pTotalFiles = 0
		pTotalFolders = 1
		pTotalMatches = 0
		pTime = 0
		
		Dim s, f, obj, i
		
		If IsNull(Substr) Then s = pSubstr Else s = Substr
		If pIgnoreHTML Then s = HTMLDecode(s)
		pSubstr = s
		
		If pFilter <> "" Then
			pFilterArray = Split(pFilter, ",")
			pFilterBnd = UBound(pFilterArray)
			For i = 0 To pFilterBnd
				pFilterArray(i) = Trim(LCase(pFilterArray(i)))
			Next
		End If

	End Sub
	
	
	Private Sub DoSearchFolder(ByRef F)
	
		Dim Item, Str
		Dim i, j, k, ln, lm
		Dim Arr(2)
		
		For Each Item In F.Files
			If GoodFile(GetFileExt(Item.Path)) Then
				MainSearch Item				
			End If
		Next
		
		If pIncludeSubFolders Then
			For Each Item In F.SubFolders
				pTotalFolders = pTotalFolders + 1
				DoSearchFolder Item
			Next
		End If				
	
	End Sub
	
	
	Private Function GoodFile(ByVal Ext)
		If pFilter = "" Then
			GoodFile = True
			Exit Function
		End If
		Dim i
		Ext = LCase(Ext)
		For i = 0 To pFilterBnd
			If pFilterArray(i) = Ext Then
				GoodFile = True
				Exit Function
			End If
		Next
		GoodFile = False
	End Function
	
	
	Private Sub MainSearch(ByRef Item)
		
		Dim Str, ln, lm
		Dim i, j, k, bCase
		Dim mTitle, mPath, mText, mm
		Dim bProceed, c, bk
		
		pTotalFiles = pTotalFiles + 1
		Str = ReadFile(Item.Path)
		
		If pIgnoreHTML Then Str = HTMLDecode(Str)
		
		mTitle = GetTitle(Str)
		If mTitle = "" Then mTitle = Item.Name
		mPath = GetRelativePath(Item.Path)
		
		If Not pFullText Then Str = StripTags(NoScripts(Str))
		Str = TrimChop(Str)
		
		ln = Len(Str)
		lm = Len(pSubstr)
		i = 1
		If pIgnoreCase Then bCase = 1 Else bCase = 0
		
		
		Do While pTotalMatches < pMaxResults Or pMaxResults = 0
		
			i = InStr(i, Str, pSubstr, bCase)
			If i = 0 Then Exit Do
			
			bProceed = True
			
			If pWholeWord Then
			  If i > 1 Then
				c = Mid(Str, i - 1, 1)
				If eregi(pREG_WORD, c) Then
				  bProceed = False
				End If
			  End If
			  If bProceed And (i + lm) < ln Then
				c = Mid(Str, i + lm, 1)
				If eregi(pREG_WORD, c) Then
				  bProceed = False
				End If
			  End If
			End If
			
			If bProceed Then
			
			  pTotalMatches = pTotalMatches + 1
			
			  j = i - pCharsLeft
			  k = i + lm + pCharsRight
			  If j < 1 Then j = 1
			  If k > ln Then k = ln
				
				bk = j
				Do While j >= 1
					c = Mid(Str, j, 1)
					If Not eregi(pREG_WORD, c) Then
						Exit Do
					End If
					j = j - 1
					If j < 1 Then
						j = bk
						Exit Do
					End If
				Loop				
				bk = k
				For k = bk To ln
					c = Mid(Str, k, 1)
					If Not eregi(pREG_WORD, c) Then
						Exit For
					End If
					If k = ln Then
						k = bk
						Exit For
					End If
				Next
				
			  
			  mText = Mid(Str, j, k - j)
			  mText	= BoldSubstr(mText, pSubstr, bCase)	
			  
			  pIndex = pIndex + 1
			  ReDim Preserve pMatch(pIndex)
			  Set pMatch(pIndex) = New SearchItem
			  
			  pMatch(pIndex).Title = mTitle
			  pMatch(pIndex).Path = mPath
			  pMatch(pIndex).Text = mText
			  
			  If Not pGlobal Then Exit Do
			  i = i + (k - j)
			  
			Else
			
			  i = i + lm
				
			End If
						
		Loop  'Main loop

	End Sub
	
	
	Private Function BoldSubstr(ByVal Str, ByVal Substr, ByVal bCase)
		
		Dim ln, ls, i, c
		Dim a, b, x
		Dim bProceed
		
		ln = Len(Substr)
		ls = Len(Str)
		i = 1
		
		Do
			
			i = InStr(i, Str, Substr, bCase)
			If i = 0 Then Exit Do
			
			bProceed = True
			
			If pWholeWord Then
			
				If i > 1 Then
					x = Mid(Str, i - 1, 1)
					If eregi(pREG_WORD, x) Then
						bProceed = False
					End If
				End If
				
				If bProceed And i < ls Then
					x = Mid(Str, i + ln, 1)
					If eregi(pREG_WORD, x) Then
						bProceed = False
					End If
				End If
				
			End If
			
			If Not bProceed Then
			
				i = i + 1
				
			Else
				
				c = "<b>" & Mid(Str, i, ln) & "</b>"
				a = i + ln
				b = ls - a + 1
				
				If b < 0 Then b = 0
				
				Str = Left(Str, i - 1) & c & Mid(Str, a, b)
				ls = ls + 7
				i = i + 4
				
			End If
			
			If i > ls Then Exit Do
			
		Loop
		
		BoldSubstr = Str
		
	End Function
	
	
	'Salva o resultado da busca em um arquivo
	Public Function WriteToFile(ByVal FileName)
		
		Dim oFile, i, Bnd
		Set oFile = OpenFile(FileName, 2, True)
		
		If oFile Is Nothing Then
			WriteToFile = False
			Exit Function
		End If
		
		Bnd = pTotalMatches - 1
		
		For i = 0 To Bnd
		
			oFile.Write pMatch(i).Title & Chr(16)
			oFile.Write pMatch(i).Path & Chr(16)
			oFile.Write pMatch(i).Text
			
			If i < Bnd Then
				oFile.Write Chr(17)
			End If
			
		Next
		
		oFile.Close
		Set oFile = Nothing
		
		WriteToFile = True
		
	End Function
	
	
	'Lê um resultado escrito por WriteToFile
	Public Function ReadFromFile(ByVal FileName)
		
		Dim oFile, aData, iBnd
		Dim sData, aItem, i
		
		Set oFile = OpenFile(FileName, 1, False)
		If oFile Is Nothing Then
			ReadFromFile = False
			Exit Function
		End If
		
		sData = oFile.ReadAll
		oFile.Close
		Set oFile = Nothing
		
		aData = Split(sData, Chr(17))
		sData = ""
		iBnd = UBound(aData)
		
		pIndex = -1
		pMatch = Array()
		pTotalMatches = iBnd + 1
		pTime = 0
		pTotalFolders = 0
		pTotalFiles = 0
		
		On Error Resume Next
		
		For i = 0 To iBnd
		
			aItem = Split(aData(i), Chr(16))
			
			pIndex = pIndex + 1
			ReDim Preserve pMatch(pIndex)
			Set pMatch(pIndex) = New SearchItem
			
			pMatch(pIndex).Title = aItem(0)
			pmatch(pIndex).Path = aItem(1)
			pMatch(pIndex).Text = aItem(2)
			
			If Err Then
				Err.Clear
				On Error GoTo 0
				Err.Raise 1001, "SiteSearch Class", "ReadFromFile method: File is corrupted [" & FileName & "]"
			End If
			
		Next
		
		On Error GoTo 0
		ReadFromFile = True
		
	End Function
	
	
	
End Class



'Objeto SearchItem

Class SearchItem

	Private pTitle  'Texto contido na tag <TITLE>, ou o nome do arquivo se não existir a tag
	Private pPath   'Caminho relativo mapeado a partir da pasta atual, pode ser usado como link
	Private pText   'Fragmento de texto onde a ocorrência foi encontrada
	
	Private Sub Class_Initialize()
		pTitle = ""
		pPath = ""
		pText = ""
	End Sub
	
	Public Property Get Title()
		Title = pTitle
	End Property
	Public Property Let Title(ByRef s)
		pTitle = s
	End Property
	
	Public Property Get Path()
		Path = pPath
	End Property
	Public Property Let Path(ByRef s)
		pPath = s
	End Property
	
	Public Property Get Text()
		Text = pText
	End Property
	Public Property Let Text(ByRef s)
		pText = s
	End Property
	
End Class




%>

jrcardozo · Dezembro 22, 2008

achei interessante, mas parece que estão faltando duas funções:

ereg e eregi

se tiver posta ai pois vai ser bem util esse code

xanburzum · Dezembro 24, 2008

tenho sim, mas como estou de férias, esta em outro micro.

jrcardozo · Dezembro 25, 2008

opa, beleza

fico no aguardo então

abraço

Entrar

Arquivado

Classe para pesquisa

Recommended Posts

xanburzum 169

Compartilhar este post

Link para o post

Compartilhar em outros sites

jrcardozo 4

Compartilhar este post

Link para o post

Compartilhar em outros sites

xanburzum 169

Compartilhar este post

Link para o post

Compartilhar em outros sites

jrcardozo 4

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