25. oktober 2002 - 23:58Der er
8 kommentarer og 1 løsning
Er der noget der har mod på denne her?
Jeg har fundet en ganske fin søge maskine til egen site på nettet. Den virker fint. Men jeg ville grne have at den ikke viser sites som ikke har nogen beskrivelse eller titel.
Er nogen der har mod på denne her?
/Thomas
Here goes:
<% 'Option Explicit %> <%
Response.Buffer = True
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
Const intRecordsPerPage = 8 'change this to the number of results to show on each page
strFilesTypesToSearch = "htm,html,asp,shtml,aspx"
strBarredFolders = "cgi_bin,_bin" 'cgi_bin and _bin have been put in here as examples, but you can put any folders in here
strBarredFiles = "adminstation.htm,no_allowed.asp,admin.asp" 'adminstration.htm and not_allowed.asp have been put in as an examples
blnEnglishLanguage = True 'True = HTML Encode best for English sites \ False = no Emcoding best for non English sites
If blnEnglishLanguage = True Then strSearchWords = Server.HTMLEncode(strSearchWords)
Else 'Just replace the script tag <> with HTML encoded < and > strSearchWords = Replace(strSearchWords, "<", "<", 1, -1, 1) strSearchWords = Replace(strSearchWords, ">", ">", 1, -1, 1) End If
If blnSearchResultsFound = False Then Response.Write vbCrLf & " <td> Søgte på sider efter <b>" & strSearchWords & "</b>. Desvære der var ingen resultater.</font></td>"
Else Response.Write vbCrLf & " <td> Søgte på sider efter <b>" & strSearchWords & "</b>. Viser resultater " & intFileNum + 1 & " - " & intNumFilesShown & " af " & intTotalFilesFound & ".</font></td>" End If
Response.Write vbCrLf & " <br>" Response.Write vbCrLf & " <a>Dit søgeord var - <b>" & strSearchWords & "</b> - Der var desvære ingen resultat/resultater af søgningen.</font>" Response.Write vbCrLf & " <br><br>" Response.Write vbCrLf & " <a><b>Muligheder:</b></font>" Response.Write vbCrLf & " <br>" Response.Write vbCrLf & " <a><ul><li>Har du stavet det rigtigt?<li>Prøv uden special tegn.<li>Prøv med et andet keyword.<li>Prøv med fære keywords.</ul></font>"
Else
For intDisplayResultsLoopCounter = (intFileNum + 1) to intNumFilesShown
Response.Write vbCrLf & " <br>" Response.Write vbCrLf & " " & sarySearchResults(intDisplayResultsLoopCounter,1) Response.Write vbCrLf & " <br>" Next End If
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 Resume Next
Err.Number = 0
Set objRegExp = New RegExp
If Err.Number <> 0 Then Response.Write("<br>FEJL! Serveren understøtter ikke extension<br>")
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
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 'Holds the part of the array being sorted Dim intIndexPosition 'Holds the Array index position being sorted Dim intTempResultsHold 'Temperary hold for the results if they need swapping array positions Dim intTempNumMatchesHold 'Temperary hold for the number of matches for the result if they need swapping array positions Dim intPassNumber 'Holds the pass number for the sort
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 'Holds the start position in the file Dim intEndPositionInFile 'Holds the end position in the file
Teknologi, AI og forretning er i centrum på Computerworlds Cloud og AI Festival i København d. 18. og 19. september. Se hele programmet for den store konference om strategisk brug af Cloud og AI på: www.cloud-festival.dk
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
Const intRecordsPerPage = 8 'change this to the number of results to show on each page
strFilesTypesToSearch = "htm,html,asp,shtml,aspx"
strBarredFolders = "cgi_bin,_bin" 'cgi_bin and _bin have been put in here as examples, but you can put any folders in here
strBarredFiles = "adminstation.htm,no_allowed.asp,admin.asp" 'adminstration.htm and not_allowed.asp have been put in as an examples
blnEnglishLanguage = True 'True = HTML Encode best for English sites \ False = no Emcoding best for non English sites
If blnEnglishLanguage = True Then strSearchWords = Server.HTMLEncode(strSearchWords)
Else 'Just replace the script tag <> with HTML encoded < and > strSearchWords = Replace(strSearchWords, "<", "<", 1, -1, 1) strSearchWords = Replace(strSearchWords, ">", ">", 1, -1, 1) End If
If blnSearchResultsFound = False Then Response.Write vbCrLf & " <td> Søgte på sider efter <b>" & strSearchWords & "</b>. Desvære der var ingen resultater.</font></td>"
Else Response.Write vbCrLf & " <td> Søgte på sider efter <b>" & strSearchWords & "</b>. Viser resultater " & intFileNum + 1 & " - " & intNumFilesShown & " af " & intTotalFilesFound & ".</font></td>" End If
Response.Write vbCrLf & " <br>" Response.Write vbCrLf & " <a>Dit søgeord var - <b>" & strSearchWords & "</b> - Der var desvære ingen resultat/resultater af søgningen.</font>" Response.Write vbCrLf & " <br><br>" Response.Write vbCrLf & " <a><b>Muligheder:</b></font>" Response.Write vbCrLf & " <br>" Response.Write vbCrLf & " <a><ul><li>Har du stavet det rigtigt?<li>Prøv uden special tegn.<li>Prøv med et andet keyword.<li>Prøv med fære keywords.</ul></font>"
Else
For intDisplayResultsLoopCounter = (intFileNum + 1) to intNumFilesShown
Response.Write vbCrLf & " <br>" Response.Write vbCrLf & " " & sarySearchResults(intDisplayResultsLoopCounter,1) Response.Write vbCrLf & " <br>" Next End If
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 Resume Next
Err.Number = 0
Set objRegExp = New RegExp
If Err.Number <> 0 Then Response.Write("<br>FEJL! Serveren understøtter ikke extension<br>")
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
strPageDescription = GetFileMetaTag("<meta name=""description"" content=""", """>", strFileContents) '----- Egen linie If strPageTitle<>"" or strPageDescription<>"" then '----- Slut egen linie strPageKeywords = GetFileMetaTag("<meta name=""keywords"" content=""", """>", strFileContents)
tsObject.Close End If '----- Egen linie End If '----- Slut egen linie 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 'Holds the part of the array being sorted Dim intIndexPosition 'Holds the Array index position being sorted Dim intTempResultsHold 'Temperary hold for the results if they need swapping array positions Dim intTempNumMatchesHold 'Temperary hold for the number of matches for the result if they need swapping array positions Dim intPassNumber 'Holds the pass number for the sort
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 'Holds the start position in the file Dim intEndPositionInFile 'Holds the end position in the file
Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links. Der sættes "nofollow" på alle links.