%@ Language=VBScript %>
<% Option Explicit %>
<%
Const adUseClient = 3
Const adOpenStatic = 3
Const adLockReadOnly = 1
Const sSearchImagePath = "/ISsearch/"
Dim sErrorMsg, sNavBtnHTML, sSearchHTML, nSearchCount, nSearchScope, sScopePath, sSearchString, sSearchStats, nRankBase, nPageNum, nPageSize, nPageCount, sFormAction
Dim gPageNum1, gPageNum2
Dim gRowNum1, gRowNum2
Main()
Sub Main()
nSearchScope = 1
nPageSize = 10
GetUIData()
If sSearchString <> "" Then
WindowsSearch(sSearchString)
SetVariables()
End If
End Sub
Sub GetUIData()
' nSearchScope Legend
' 1 = "www"
' 2 = "baremetal"
' 3 = "t-encrypt"
sFormAction = Request.ServerVariables("PATH_INFO")
sSearchString = GetRequestValue(Request.Form, "SearchString", "")
nSearchScope = CLng(GetRequestValue(Request.Form, "SearchScope", nSearchScope))
nRankBase = CLng(GetRequestValue(Request.Form, "RankBase", 1000))
nPageNum = CLng(GetRequestValue(Request.Form, "Page", 1))
nPageCount = CLng(GetRequestValue(Request.Form, "PageCount", 1))
Select Case nSearchScope
Case 1
sScopePath = "E:\Inetpub\Unylogix.com\www"
Case 2
sScopePath = "E:\Inetpub\Unylogix.com\baremetal"
Case 3
sScopePath = "E:\Inetpub\Unylogix.com\t-encrypt"
Case Else
sScopePath = "E:\Inetpub\Unylogix.com\www"
End Select
' Uncomment for Testing
' If sSearchString = "" Then
' sSearchString = "sanbox"
' End If
sSearchString = RemoveQuotes(sSearchString)
sSearchString = TrimWhiteSpace(sSearchString)
If GetRequestValue(Request.Form, "btnFirst", "") <> "" Then
nPageNum = 1
ElseIf GetRequestValue(Request.Form, "btnPrev", "") <> "" Then
nPageNum = nPageNum - 1
ElseIf GetRequestValue(Request.Form, "btnNext", "") <> "" Then
nPageNum = nPageNum + 1
ElseIf GetRequestValue(Request.Form, "btnLast", "") <> "" Then
nPageNum = nPageCount
Else
nPageNum = 1
Session("SearchConnection") = ""
Session("SearchRecordSet") = ""
End If
End Sub
Sub SetVariables()
sNavBtnHTML = GetNavBtnHTML()
End Sub
Function WindowsSearch(sSearchText)
Dim oConnection, oRecordSet, sSQL
On Error Resume Next
If IsObject(Session("SearchConnection")) And IsObject(Session("SearchRecordSet")) Then
Set oConnection = Session("SearchConnection")
Set oRecordSet = Session("SearchRecordSet")
If oRecordSet.RecordCount > 0 And nPageNum > 0 Then
oRecordSet.AbsolutePage = nPageNum
End If
Else
Set oConnection = Server.CreateObject("ADODB.Connection")
Set oRecordSet = Server.CreateObject("ADODB.Recordset")
oRecordSet.CursorLocation = adUseClient
oRecordSet.CursorType = adOpenStatic
oRecordSet.LockType = adLockReadOnly
Call oConnection.Open("Provider=Search.CollatorDSO;Extended Properties='Application=Windows';")
' Replace all single quotes with double single quotes to prevent SQL injection
sSearchText = Replace(sSearchText, "'", "''")
sSQL = "SELECT System.Title, System.Search.AutoSummary, System.FileExtension, System.ItemName, System.ItemDate, System.ItemPathDisplay, System.KindText, System.Size, System.Search.Rank " & _
"FROM SystemIndex " & _
"WHERE SCOPE = 'file:<@ScopePath@>'" & _
" AND SYSTEM.KINDTEXT != 'Folder'" & _
" AND (System.FileExtension = '.html' OR System.FileExtension = '.asp')" & _
" AND FREETEXT(*, '<@SearchText@>')" & _
" ORDER BY System.Search.Rank DESC"
sSQL = Replace(sSQL, "<@ScopePath@>", sScopePath, 1, -1, vbTextCompare)
sSQL = Replace(sSQL, "<@SearchText@>", sSearchText, 1, -1, vbTextCompare)
Call oRecordSet.Open(sSQL, oConnection)
oRecordSet.PageSize = nPageSize
If Not oRecordSet.BOF And Not oRecordSet.EOF Then
oRecordSet.MoveFirst
End If
End If
' CheckIsError(oConnection)
nSearchCount = oRecordSet.RecordCount
nPageCount = oRecordSet.PageCount
sSearchHTML = GetSearchHTML(oRecordSet)
If oRecordSet.RecordCount > 0 Then
Set Session("SearchConnection") = oConnection
Set Session("SearchRecordSet") = oRecordSet
WindowsSearch = oRecordSet.RecordCount
Else
oRecordSet.Close()
oConnection.Close()
Set oRecordSet = Nothing
Set oConnection = Nothing
Set Session("SearchConnection") = Nothing
Set Session("SearchRecordSet") = Nothing
End If
End Function
Function GetNavBtnHTML()
GetNavBtnHTML = " "
If nPageCount > 1 Then
GetNavBtnHTML = "
" & _
" >" & _
" >" & _
" >" & _
" >" & _
"Page: <@PageNum@> of <@PageCount@> " & _
"
"
If nPageNum > 1 Then
GetNavBtnHTML = Replace(GetNavBtnHTML, "<@DisableP@>", "", 1, -1, vbTextCompare)
Else
GetNavBtnHTML = Replace(GetNavBtnHTML, "<@DisableP@>", "disabled", 1, -1, vbTextCompare)
End If
If nPageNum < nPageCount Then
GetNavBtnHTML = Replace(GetNavBtnHTML, "<@DisableN@>", "", 1, -1, vbTextCompare)
Else
GetNavBtnHTML = Replace(GetNavBtnHTML, "<@DisableN@>", "disabled", 1, -1, vbTextCompare)
End If
GetNavBtnHTML = Replace(GetNavBtnHTML, "<@PageNum@>", nPageNum, 1, -1, vbTextCompare)
GetNavBtnHTML = Replace(GetNavBtnHTML, "<@PageCount@>", nPageCount, 1, -1, vbTextCompare)
sSearchStats = "Results: <@SearchCount@>
"
sSearchStats = Replace(sSearchStats, "<@SearchCount@>", nSearchCount, 1, -1, vbTextCompare)
End If
End Function
Function GetSearchHTML(ByRef oRecordSet)
Dim sTemplateT1, sTemplateT2, sTemplateR1, sTemplateR2, sTemplateR3
Dim nRowNum, nRowNumLast
Dim sHTML, sTemp, sValue, nRank, nNormRank, sStars
On Error Resume Next
sTemplateT1 = "" & vbCrLf
sTemplateT2 = "
" & vbCrLf
sTemplateR1 = "" & _
" <@RowNum@> " & _
" <@Title@> " & _
" " & vbCrLf
sTemplateR2 = "" & _
"" & _
" <@Stars@>"" width=""90"" height=""20"">" & _
" " & _
" " & _
"<@Abstract@>" & _
" "" class=""clsRecordStats"" style=""color:blue;"">http://<@ServerName@><@VPath@> " & _
"
<@Size@> bytes - <@ItemDate@> GMT
" & _
" " & _
" " & vbCrLf
sTemplateR3 = "" & _
" Sorry, no matches were found. " & _
" " & vbCrLf
If Not oRecordSet.BOF And Not oRecordSet.EOF Then
nRowNum = oRecordSet.AbsolutePosition
nRowNumLast = nRowNum + oRecordSet.PageSize - 1
nPageNum = oRecordSet.AbsolutePage
If oRecordSet.RecordCount <> -1 And oRecordSet.RecordCount < nRowNumLast Then
nRowNumLast = oRecordSet.RecordCount
End If
' This is the detail portion for Title, Abstract, URL, Size, and Modification Date.
' If there is a title, display it, otherwise display the filename.
Do Until oRecordSet.EOF OR nRowNum > nRowNumLast
sTemp = sTemplateR1
sTemp = Replace(sTemp, "<@RowNum@>", nRowNum, 1, -1, vbTextCompare)
sValue = oRecordSet.Fields("System.Title").Value
If VarType(sValue) = vbNull Or sValue = "" Then
sValue = oRecordSet.Fields("System.ItemName").Value
End If
sTemp = Replace(sTemp, "<@Title@>", sValue, 1, -1, vbTextCompare)
sHTML = sHTML & sTemp
' Graphically indicate rank of document with list of stars (*'s).
nRank = CLng(oRecordSet.Fields("System.Search.Rank").Value)
If nRowNum = 1 Then
nRankBase = nRank
If nRankBase > 1000 Then
nRankBase = 1000
ElseIf nRankBase < 1 Then
nRankBase = 1
End If
End If
nNormRank = nRank / nRankBase
If nNormRank > 0.80 Then
sStars = "rankbtn5.gif"
ElseIf nNormRank > 0.60 Then
sStars = "rankbtn4.gif"
ElseIf nNormRank > 0.40 Then
sStars = "rankbtn3.gif"
ElseIf nNormRank > 0.20 Then
sStars = "rankbtn2.gif"
Else
sStars = "rankbtn1.gif"
End If
sTemp = sTemplateR2
sTemp = Replace(sTemp, "<@ImagePath@>", sSearchImagePath, 1, -1, vbTextCompare)
sTemp = Replace(sTemp, "<@Stars@>", sStars, 1, -1, vbTextCompare)
sTemp = Replace(sTemp, "<@ServerName@>", LCase(Request.ServerVariables("SERVER_NAME")), 1, -1, vbTextCompare)
sTemp = Replace(sTemp, "<@Abstract@>", oRecordSet.Fields("System.Search.AutoSummary").Value, 1, -1, vbTextCompare)
sTemp = Replace(sTemp, "<@VPath@>", MapURL(oRecordSet.Fields("System.ItemPathDisplay").Value), 1, -1, vbTextCompare)
sTemp = Replace(sTemp, "<@ItemDate@>", oRecordSet.Fields("System.ItemDate").Value, 1, -1, vbTextCompare)
sTemp = Replace(sTemp, "<@Size@>", oRecordSet.Fields("System.Size").Value, 1, -1, vbTextCompare)
' Construct the URL for hit highlighting
' WebHitsQuery = "CiWebHitsFile=" & Server.URLEncode( oRS("vpath") )
' WebHitsQuery = WebHitsQuery & "&CiRestriction=" & Server.URLEncode( oQuery.Query )
' WebHitsQuery = WebHitsQuery & "&CiBeginHilite=" & Server.URLEncode( "" )
' WebHitsQuery = WebHitsQuery & "&CiEndHilite=" & Server.URLEncode( " " )
' WebHitsQuery = WebHitsQuery & "&CiUserParam3=" & QueryForm
' WebHitsQuery = WebHitsQuery & "&CiLocale=" & oQuery.LocaleID
sHTML = sHTML & sTemp
oRecordSet.MoveNext
nRowNum = nRowNum + 1
Loop
End If
If sHTML = "" Then
sHTML = sTemplateR3
End If
GetSearchHTML = sTemplateT1 & sHTML & sTemplateT2
End Function
' --------------------------------------------------------------------------
' Name: GetRequestValue(ByRef oColl, ByVal sName, ByVal vDefaultValue)
' Return: Variant
' Description: Returns value from Request collection, if empty default value returned.
' --------------------------------------------------------------------------
Function GetRequestValue(ByRef oColl, ByVal sName, ByVal vDefaultValue)
If TypeName(oColl) = "IRequestDictionary" And VarType(sName) = vbString Then
GetRequestValue = oColl.Item(sName)
End If
If IsEmpty(GetRequestValue) Then
GetRequestValue = vDefaultValue
End If
End Function
Function MapURL(sPath)
' Opposite of server.mappath - takes a filesystem path and turns it into a url
Dim sAppPath
sAppPath = Server.MapPath("/")
sPath = Replace(sPath, sAppPath, "", 1, -1, vbTextCompare)
MapURL = Replace(sPath, "\", "/", 1, -1, vbTextCompare)
End Function
Function TrimWhiteSpace(sValue)
TrimWhiteSpace = sValue
On Error Resume Next
Dim RegEx
Set RegEx = New RegExp
RegEx.Pattern = "(^\s+)|(\s+$)"
RegEx.IgnoreCase = True
RegEx.Global = True
TrimWhiteSpace = RegEx.Replace(sValue, "")
End Function
Function RemoveQuotes(sValue)
RemoveQuotes = sValue
On Error Resume Next
Dim RegEx
Set RegEx = New RegExp
RegEx.Pattern = """+"
RegEx.IgnoreCase = True
RegEx.Global = True
RemoveQuotes = RegEx.Replace(sValue, "")
End Function
Function CheckIsError(ByRef r_oConnection)
Dim bIsError
bIsError = False
sErrorMsg = ""
If Not IsNull(r_oConnection) Then
If TypeName(r_oConnection) = "Connection" Then
If IsAdoError(r_oConnection) Then
bIsError = True
End If
End If
End If
If IsAspError() Or IsVbsError() Then
bIsError = True
End If
If bIsError Then
Response.Write(sErrorMsg & VbCrLf)
End If
CheckIsError = bIsError
End Function
Function IsAdoError(ByRef r_oConnection)
IsAdoError = False
Dim Idx, nErrorCount, oADOConnection, sTemp, sErrTemplate
Set oADOConnection = r_oConnection
sErrTemplate = "ADO Error Object, " & _
"Error Number: <@ErrNum@>, " & _
"Description: <@Description@>, " & _
"NativeError: <@NativeError@>, " & _
"Source: <@Source@>, " & _
"SQLState: <@SQLState@>, " & _
" , " & vbCrLf
nErrorCount = oADOConnection.Errors.Count
If nErrorCount > 0 Then
For Idx = 0 To nErrorCount - 1
With oADOConnection.Errors.Item(Idx)
If .Number <> 0 Then
IsAdoError = True
sTemp = sErrTemplate
sTemp = Replace(sTemp, "<@ErrNum@>", .Number, 1, -1, vbTextCompare)
sTemp = Replace(sTemp, "<@Description@>", .Description, 1, -1, vbTextCompare)
sTemp = Replace(sTemp, "<@NativeError@>", .NativeError, 1, -1, vbTextCompare)
sTemp = Replace(sTemp, "<@Source@>", .Source, 1, -1, vbTextCompare)
sTemp = Replace(sTemp, "<@SQLState@>", .SQLState, 1, -1, vbTextCompare)
End If
End With
Next
If sTemp <> "" Then
sErrorMsg = sErrorMsg & sTemp
End If
oADOConnection.Errors.Clear()
End If
Set oADOConnection = Nothing
End Function
' IsAspError -----------------------------
Function IsAspError()
IsAspError = False
Dim oASPError, sTemp, sErrTemplate
sErrTemplate = "ASPError Object, " & _
"ASPCode: <@ASPCode@>, " & _
"ASPDescription: <@ASPDescription@>, " & _
"Description: <@Description@>, " & _
"Number: <@Number@>, " & _
"Source: <@Source@>, " & _
"Category: <@Category@>, " & _
"File: <@File@>, " & _
"Line: <@Line@>, " & _
"Column: <@Column@>, " & _
" , " & vbCrLf
Set oASPError = Server.GetLastError()
With oASPError
If .ASPCode > "" Or _
.ASPDescription > "" Or _
.Number <> 0 Or _
.Description > "" Or _
.File <> "" And _
.File <> "?" Then
IsAspError = True
sTemp = sErrTemplate
sTemp = Replace(sTemp, "<@ASPCode@>", .ASPCode, 1, -1, vbTextCompare)
sTemp = Replace(sTemp, "<@ASPDescription@>", .ASPDescription, 1, -1, vbTextCompare)
sTemp = Replace(sTemp, "<@Description@>", .Description, 1, -1, vbTextCompare)
sTemp = Replace(sTemp, "<@Number@>", .Number, 1, -1, vbTextCompare)
sTemp = Replace(sTemp, "<@Source@>", .Source, 1, -1, vbTextCompare)
sTemp = Replace(sTemp, "<@Category@>", .Category, 1, -1, vbTextCompare)
sTemp = Replace(sTemp, "<@File@>", .File, 1, -1, vbTextCompare)
sTemp = Replace(sTemp, "<@Line@>", .Line, 1, -1, vbTextCompare)
sTemp = Replace(sTemp, "<@Column@>", .Column, 1, -1, vbTextCompare)
If sTemp <> "" Then
sErrorMsg = sErrorMsg & sTemp
End If
End If
End With
Set oASPError = Nothing
End Function
' IsVbsError -----------------------------
Function IsVbsError()
IsVbsError = False
Dim sTemp, sErrTemplate
sErrTemplate = "Error (Err) Object, " & _
"Number: <@Number@>, " & _
"Description: <@Description@>, " & _
"Source: <@Source@>, " & _
" , " & vbCrLf
With Err
If .Number <> 0 Then
IsVbsError = True
sTemp = sErrTemplate
sTemp = Replace(sTemp, "<@Number@>", .Number, 1, -1, vbTextCompare)
sTemp = Replace(sTemp, "<@Description@>", .Description, 1, -1, vbTextCompare)
sTemp = Replace(sTemp, "<@Source@>", .Source, 1, -1, vbTextCompare)
If sTemp <> "" Then
sErrorMsg = sErrorMsg & sTemp
End If
.Clear()
End If
End With
End Function
%>
Search for a keyword in Unylogix pages
Search the Unylogix Web site
<%=sSearchStats%>
<%=sSearchHTML%>