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
intTotalFilesSearched = 0
%>
<html>
<head>
</style>
</head>
<body bgcolor="#FFFFFF">
<form method="get" name="frmSiteSearch" action="search.asp">
<table cellpadding="0" cellspacing="0" width="90%" align="center">
<tr>
<td class="normal" height="2" width="571">
<b><font size="1">Søg på min site: </font></b>
<input name="search" maxlength="50" size="36" value="<% =Request.QueryString("search") %>" class="box" style="font-family: Verdana; font-size: 10px; font-weight:bold">
<input type="submit" value="Find" name="submit" class="box">
</td>
</tr>
<tr>
<td class="normal" height="34" width="571" valign="top"><font size="1">Specifik
søgning </font>:
<input type="radio" name="mode" value="anywords" CHECKED></font><font size="1">Nogle af ordene
<input type="radio" name="mode" value="allwords">
Alle ord
<input type="radio" name="mode" value="phrase">
Sætningen </font></td>
</tr>
</table>
</form>
<%
strSearchWords = Trim(Request.QueryString("search"))
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
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=""#e7e3db"">"
Response.Write vbCrLf & " <tr>"
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 & " </tr>"
Response.Write vbCrLf & " </table>"
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 & " <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
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 & " <a>Antal sider med valgte søgning: </font>"
If intNumFilesShown > intRecordsPerPage Then
Response.Write vbCrLf & " <a><a href=""search.asp?FileNumPosition=" & intFileNum - intRecordsPerPage & "&search=" & Replace(strSearchWords, " ", "+") & "&mode=" & Request.QueryString("mode") & """ target=""_self""><b><< Sidste</b></a></font> "
End If
If intTotalFilesFound > intRecordsPerPage Then
For intPageLinkLoopCounter = 1 to CInt((intTotalFilesFound / intRecordsPerPage) + 0.5)
If intFileNum = (intPageLinkLoopCounter * intRecordsPerPage) - intRecordsPerPage Then
Response.Write vbCrLf & " <font size=1 color=#CC3300><b>" & intPageLinkLoopCounter & "</b></font>"
Else
Response.Write vbCrLf & " <font size=1><a href=""search.asp?FileNumPosition=" & (intPageLinkLoopCounter * intRecordsPerPage) - intRecordsPerPage & "&search=" & Replace(strSearchWords, " ", "+") & "&mode=" & Request.QueryString("mode") & """ target=""_self"">" & intPageLinkLoopCounter & "</a></font> "
End If
Next
End If
If intTotalFilesFound > intNumFilesShown then
Response.Write vbCrLf & " <a><a href=""search.asp?FileNumPosition=" & intNumFilesShown & "&search=" & Replace(strSearchWords, " ", "+") & "&mode=" & Request.QueryString("mode") & """ target=""_self""><b>Næste >></b></a></font>"
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
%>
<br>
<div align="center">
<table width="98%" border="0" cellspacing="1" cellpadding="1" align="center">
<tr>
<td width="47%" height="18"> </td>
<td width="53%" align="right" height="18"><br>
</td>
</tr>
</table>
</div>
</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 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
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)
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 = "<b>Siden har ingen titel!</b>"
If strPageDescription = "" Then strPageDescription = "Der er ikke lavet en beskrivelse af denne side.</font>"
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"">" & "<b>" & strPageTitle & "</b></a>"
Else
sarySearchResults(intResultsArrayPosition,1) = "<a href=""./" & strFileURL & fldObject.Name & "/" & filObject.Name & """ target=""_self"">" & "<b>" & strPageTitle & "</b></a>"
End If
sarySearchResults(intResultsArrayPosition,1) = sarySearchResults(intResultsArrayPosition,1) & vbCrLf & " <font size=1><br>" & strPageDescription & "</font>"
sarySearchResults(intResultsArrayPosition,1) = sarySearchResults(intResultsArrayPosition,1) & vbCrLf & " <font size=""1"" color=""#808080""><br>Søgningen machede " & intNumMatches & " - Sidst opdateret " & FormatDateTime(filObject.DateLastModified, VbLongDate) & " - Side størelse " & CInt(filObject.Size / 1024) & "kb</font><font size=1 color=#000000>"
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 '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
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
%>
