<%@ LANGUAGE="VBSCRIPT" %><%
'Due to the high number of components, the script may run into Timeout -
increase this value then.
Server.ScriptTimeOut=240
Response.Expires = 0
Response.buffer=false
On Error Resume Next
'ObjCheck V0.27 by Kevin Kempfer
'contact me at objcheck@kevinkempfer.de
' This program is free software; you can redistribute it and/or modify
' it under the terms of the GNU General Public License as published by
' the Free Software Foundation; either version 2 of the License, or
' (at your option) any later version.
'
' This program is distributed in the hope that it will be useful,
' but WITHOUT ANY WARRANTY; without even the implied warranty of
' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
' GNU General Public License for more details.
'
' You should have received a copy of the GNU General Public License
' along with this program; if not, write to the Free Software
' Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
USA
'
'History:
'v0.27 - Changed handling of different methods to get the list of
components from my server. Now the script
' will test every method until one is successfull, because i.e.
ServerXMLHTTP.4.0 seems to be buggy when
' behind a firewall or proxy.
'v0.26 - if there's no link yet available for a component, Google's
number one search result will be provided.
' Updated daily, thanks to Google for this great web service.
' - added support for more components for automatic update downloads and
proxy support.
' As I don't use proxies, I can't test the proxy support. Please give
me some feedback on this.
' If you need to use a proxy, enter the proxy information below (line
55,56,57).
'v0.25 - added descriptions and links for components, now you'll get a
short description of the components
' as well as a link to both the authors of the component and google.
' - you can now edit descriptions and links if there's none yet
available.
' - enter your own new components! click on "Add new component"
' - all new descriptions/links/components will be reviewed before going
online.
' - changed some colors
'v0.24 - changed method for automatic updates to XML-Stream
'v0.23 - added detection for misspelled or incomplete ProgIDs
'v0.221 - this script is now under the GPL, see licence.txt
'v0.22 - added link to Google when a component is installed, so you can
get a little bit more
' information on how to work with it.
'v0.21 - added check for URLs in the input box, because people always
enter their URLs instead of
' downloading the script...
'v0.2 - fixed some bugs, now first display information, then try to fetch
the list. Sometimes
' the XMLHTTP-Object doesn't work, maybe due to high traffic on my site.
Should work on your site.
'v0.1 - inital release January 2002
'Set proxy here
ProxyAddress=""
proxyusername=""
proxypassword=""
'This is the current version. These values are used for update-checking
and to tell the list-server
'how to react, will be checked later.
objcheckversion=4
version="0.27"
Dim XMLHTTPError
Dim ServerXMLHTTPError
Dim classID
Dim UpdateDescription
if request.form("descriptions")="True" then
ShowDescriptionsWhenInstalled = true
end if
if trim(request("classID"))<>"" then
classID = cint(trim(request("classID")))
AddDescription=true
elseif trim(request("AddNew"))<>"" then
AddDescription=true
else
AddDescription=false
end if
sub SayError %>
Error: This script only works with the "MSXML2.ServerXMLHTTP" Component
or "Microsoft.XMLHTTP" Component installed on the server. This should be
done by default at IIS installation. So check your IIS or contact your
provider.
Maybe this Error was made by me, so please also contact me, the author: ">Kevin Kempfer. (Errormessage:
<%=ServerXMLHTTPError%>/<%=XMLHTTPError%>)
<%
end sub
Function IsObjInstalled(strClassString)
' initialize default values
IsObjInstalled = False
Err = 0
' testing code
Dim TestObj
Set TestObj = Server.CreateObject(strClassString)
If 0 = Err Then
IsObjInstalled = True
end if
' cleanup
Set TestObj = Nothing
Err = 0
End Function
function Alternatives(strList,arrList)
'This function is used to find alternative Component-Prog-IDs, maybe the
user input was incomplete
for i=0 to ubound(arrList,2)
item=trim(lcase(arrlist(1,i)))
strList=trim(lcase(strList))
if instr(item,strList)>0 and not item=strList and not
instr(arrlist(1,i),"KevinKempfer")>0 then
if not ThereAreAlternatives then
Output = Output & "
Did you
mean: "
end if
Output = Output & "" & "" & arrlist(1,i) & " "
ThereAreAlternatives=true
end if
next
if ThereAreAlternatives then
Output = Output & " Do you think " & strList & " should be
listed in the components list? Contact me!"
end if
end function
%>
Installed Objects Scanner
Component Check v<%=version%>
<%if not AddDescription then%>Components for IP <%= Request.ServerVariables("LOCAL_ADDR")
%><%else%>Add new description<%end if%>
<%if AddDescription then%>
Please enter a description, all fields but name are optional, so leave
them empty if you don't know everything. Thanks for your support!
<%else%>
Enter a component's ProgID or ClassID to check
if it's installed on this server (<%=
Request.ServerVariables("LOCAL_ADDR") %>).
Leave the input field empty to check all listed components.
<% End If %>
<%if not AddDescription then%>
If you want to check
your own server, you'll have to download the
script and run it from your site.
<% End If %>
<%
response.write("
Please wait... ")
Dim strList
Dim Output
Dim strClass
Dim myObjectReviewed
Dim myObject
Dim myObjectdesc
Dim myObjectID
Dim myObjectlink
'the following function gets the components names from my webserver
'Leave this URL as is!
ListURL = "http://www.bier-voting.de/objcheck/objects.asp"
Function GetURL(URL,method)
set xmlhttp = server.CreateObject(method)
if method="MSXML2.ServerXMLHTTP.4.0" and ProxyAddress<>"" then
xmlhttp.setProxy 0,ProxyAddress,""
if proxyusername<>"" then
xmlhttp.setProxyCredentials proxyusername, proxypassword
end if
end if
xmlhttp.open "GET", URL, false
if method="Microsoft.XMLHTTP" then
xmlhttp.send
else
xmlhttp.send()
end if
strList = xmlhttp.responseStream
if err.number <> 0 then
GetURL=false
XMLHTTPError=XMLHTTPError& "Using
"&method&" "&xmlhttp.parseError.URL & _
" " & xmlhttp.parseError.Reason
response.end
else
GetURL=true
end if
set xmlhttp = nothing
End Function
dim even
function trclass
if even then
trclass = "even"
even = false
else
trclass = "odd"
even = true
end if
end function
sub showDescription(myObjectID)
if myObjectReviewed=false and myObjectdesc<>"" then
Output = Output & " " & myObjectdesc & " (not
yet reviewed)"
elseif myObjectdesc<>"" then
Output = Output & " " & myObjectdesc
else
Output = Output & "
Write a description"
end if
if myObjectlink<>"" then
Output = Output & " details..."
if myObjectReviewed=false then
Output = Output & " (not yet reviewed)"
end if
else
Output=Output &" add link"
if myObjectGoogleLink<>"" then
Output = Output & " or try Google's #1"
end if
end if
end sub
'for adding new classnames to the list and for statistical things and to
deliver the right version, and for my pleasure ;-)
ListURL = ListURL & "?site=" &
Server.URLEncode(Request.ServerVariables("SERVER_NAME") &
Request.ServerVariables("URL"))
'Leave the version string as is! Otherwise, the server will return wrong
data
ListURL = ListURL & "&ver=" & version
if request("classname") <> "" then
ListURL = ListURL & "&classname=" & request("classname")
end if
randomize
'Fake the browser, so it doesn't display cached sites.
ListURL = ListURL & "&nocache=" & Server.URLEncode(rnd*10000)
Dim methods(3)
methods(0)="MSXML2.ServerXMLHTTP.4.0"
methods(1)="MSXML2.ServerXMLHTTP.3.0"
methods(2)="MSXML2.ServerXMLHTTP"
methods(3)="Microsoft.XMLHTTP"
success=false
Err = 0
for each method in methods
response.write("Getting list...(using " & method & ") ")
if GetURL(ListURL,method) then
If Not 0 = Err Then
response.write "Error while using "&method&":"&
Err.description&" "
else
Response.write "Success using "&method&"... "
success=true
exit for
end if
end if
Err=0
next
if not success then
sayerror
response.end
end if
if 0 = Err then
Set objRS = Server.CreateObject("ADODB.Recordset")
objRS.Open strList
AnzahlComponenten = objRS.RecordCount - 1
strClass = Trim(Request("classname"))
If "" <> strClass then
arrlist=objRS.getrows
response.write("Testing for " & strClass & " ...
")
If left(strClass, 7) = "http://" or (left(strClass,4)="www." and
(right(strClass,4)=".com" or right(strClass,4)=".net" or
right(strClass,4)=".org" or right(strClass,4)=".edu" or
right(strClass,3)=".de") or right(strClass,4)=".com" or
right(strClass,4)=".net" or right(strClass,4)=".org" or
right(strClass,4)=".edu" or right(strClass,3)=".br" or
right(strClass,3)=".de") then
Output = Output&"
" & strClass & " looks like an
URL! Remember, this script can only check the server it was started from.
If you want to test your own server, download the
script, run it from your server and enter a ProgID (no
URL!).
"
end if
Output = Output & "
" &
strClass & " is "
If Not IsObjInstalled(strClass) then
Output = Output & "not installed!"
if "" <> strClass then
Output = Output & Alternatives(strClass,arrList)
end if
Output = output & "
If you want to add "" &
strClass & "" to the database, please click
here."
Else
GoogleLink = " (try Google)"
objRS.MoveFirst
Do while not ObjRS.EOF
if (lcase(objRS("Object"))=lcase(strClass)) and
objRS("GoogleLink")<>"" then
GoogleLink = " (try Google)"
Exit Do
end if
objRS.MoveNext
loop
Output = Output & "installed!" & GoogleLink
End If
Output = Output & "
" & vbCrLf
Else
if not AddDescription then
response.write("Testing for " & AnzahlComponenten & " components...
(this may take a minute) ")
response.write("")
' Default: Check the whole list
icount = 0
Output = Output & "
"
Do while not objRS.EOF
myObject = objRS("Object")
myObjectdesc = objRS("Beschreibung")
myObjectlink = objRS("link")
myObjectID = objRS("ID")
myObjectGoogleLink = objRS("GoogleLink")
myObjectReviewed = objRS("Online")
response.write("u('"&myObject&"');")
If not (left(myObject,12) = "KevinKempfer") then
if myObjectdesc<>"" then
trid="desc"
else
trid="nodesc"
end if
Installed = IsObjInstalled(myObject)
If Not Installed Then
If Not Request.Form("nurpositiv") = "True" Then
Output = Output & "
" & myObject &
"
is not installed!"
if not ShowDescriptionsWhenInstalled then
showDescription myObjectID
end if
End If
Else
Output = Output & "
" & myObject &
"
is installed!"
showDescription myObjectID
icount = icount + 1
End If
Output = Output & "
" & vbCrLf
else
'check version
if cint(right(myObject,1)) > objcheckversion then
UpdateAvailable = true
UpdateDescription = myObjectdesc
end if
end if
Installed=false
objRS.MoveNext
loop
response.write("")
else
response.write("")
bingo=false
Do while not (objRS.EOF or bingo or request("AddNew")="true")
myObject = objRS("Object")
myObjectdesc = objRS("Beschreibung")
myObjectlink = objRS("link")
myObjectID = objRS("ID")
if myObjectID = classID then
bingo=true
else
objRS.MoveNext
bingo=false
end if
loop
end if
Set objRS=Nothing
End If
%>
<%if not AddDescription then%>
<% if UpdateAvailable or trim(request("Thank"))="you" then %>
<% If not trim(request("Thank"))="you" then
%>Webmaster! There's an available! Please check the
download-site!<%=UpdateDescription%><% Else %>Thank you! Your
submission will be reviewed as soon as possible.<% End If
%>