<%@LANGUAGE=VBScript%> <%Option Explicit Response.Buffer = True Response.CacheControl = "Private" Response.Expires = -1 'We don't want this to be cached anywhere '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 'Printer friendly script is essentially the textonly script but with some 'processing left out and some extra processing added. 'Graphics are left in but all href links are removed. 'A width option is added to allow different widths to be defined. 'Version 1.0 based on version 1.5 31-October-2002 of textonly script '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 'Globals Dim STRTHISDIR, STRCONTENT, STRSERVERNAME Dim tagStart, tagEnd, strEmailTo, strEmailFrom Dim strImportance, strSubject, strText Dim strFileID, strHomePage, strHomeRoot, strHomeRoot1 Dim strRefer 'the referer Dim strWidth 'Uses the XMLHTTP Module 'Search for 'XMLHTTP Module' in www.microsoft.com '------------------------------------------- 'SET UP CONFIGURATIONS strEmailTo = "paulgibbs@o2.co.uk" 'The to address strEmailFrom = "textonly@webconcerns.co.uk" 'the from address strImportance = "2" ' ' tagStart = "" tagEnd = "" ' ' 'tagStart = "" 'tagEnd = "" 'To define the menu use : ' ' 'define the home site 'these are needed because you can call a web site by 'http://www.server.com/ and it assumes default.asp 'this can confuse the program later on strHomePage = "http://www.webconcerns.co.uk/default.asp" 'the home page strHomeRoot = "http://www.webconcerns.co.uk/" 'the root directory with '/' strHomeRoot1 = "http://www.webconcerns.co.uk" 'the root directory without '/' '------------------------------------------- '------------------------------------- sub main() Dim xml_http, post_item Dim MyItem, strPostInfo, i Dim strType, url strWidth = Request.QueryString ("width") if strWidth = "" then strWidth = 650 end if 'Response.Write Request.ServerVariables ("ALL_HTTP") 'Response.End strRefer = Request.ServerVariables("HTTP_REFERER") 'Response.Write strRefer 'Response.End If strRefer <> "" Then 'If this didn't come from anywhere, ignore. if strRefer = strHomeRoot or strRefer = strHomeRoot1 then strRefer = strHomePage end if strType = Request.ServerVariables ("REQUEST_METHOD") 'this will be POST or GET strPostInfo = "" i = 0 For Each MyItem in Request.Form if i = 0 then strPostInfo = MyItem & "=" & Request.Form(MyItem).Item i = i + 1 else strPostInfo = strPostInfo & "&" & MyItem & "=" & Request.Form(MyItem).Item end if Next For Each MyItem in Request.QueryString if i = 0 then strPostInfo = MyItem & "=" & Request.QueryString(MyItem).Item i = i + 1 else strPostInfo = strPostInfo & "&" & MyItem & "=" & Request.QueryString(MyItem).Item end if Next if instr(1,strPostInfo,"?") > 0 then strPostInfo = mid(strPostInfo,instr(1,strPostInfo,"?") + 1) end if STRSERVERNAME = Request.ServerVariables ("SERVER_NAME") Set xml_http = Server.CreateObject("Microsoft.XMLHTTP") url = Request.QueryString ("url") 'if this is a query string then reconstruct the url with any gets. if instr(1,url,"?") > 0 then url = mid(url,1,instr(1,url,"?") - 1) end if if url <> "" then STRTHISDIR = mid(url,1,inStrRev(url,"/") ) if strType = "POST" then xml_http.Open "POST", url, False else xml_http.Open "GET", url & "?" & strPostInfo, False strFileID = url & "?" & strPostInfo end if else STRTHISDIR = mid(strRefer,1,inStrRev(strRefer,"/")) if strType = "POST" then xml_http.Open "POST", strRefer, False else xml_http.Open "GET", strRefer, False end if end if 'This is needed to overcome the problem with .htm pages which give an error 'if do xml_http.Send (strPostInfo) Don't understand it though. if strType = "POST" then xml_http.setRequestHeader "Content-Type", "application/x-www-form-urlencoded" if strPostInfo <> "" then xml_http.Send (strPostInfo) else xml_http.Send end if else xml_http.Send end if STRCONTENT = xml_http.responseText Set xml_http = Nothing '---------------------- 'Handle Response.Status '200 or 401 is not an error, anything else is an error '3xx is a redirect if instr(STRCONTENT, "404 Error") > 0 then %> Printer friendly version

The page cannot be found or there is a bug
in the text only display script

Back
<% strSubject = "Error in Text Only Version" strText = "Error in " & Request.ServerVariables("HTTP_REFERER") call sendmail(strEMailTo, strEMailFrom, "", "", strSubject, strImportance, strText) Response.End end if call process() end if end sub '---------------------------------------------- sub process() Dim strBody, strMenu, strTitle, strHead, strJavascript strBody = getBody() strMenu = getMenu() strTitle = getTitle() strHead = getHead() strJavascript = getJavascript(strHead) strBody = Exclude(strBody) 'remove text which has to be excluded strBody = Comments(strBody) 'remove comments strBody = fonts(strBody) 'remove strBody = span(strBody) 'remove and strBody = applets(strBody) 'remove applets strBody = shockwave(strBody) 'remove shockwave strBody = map(strBody) 'deal with strBody = JSRollOver(strBody) 'JScript rollover strBody = removeHrefs(strBody) 'delete all hrefs and strBody = mailto(strBody) 'correct mailto links strBody = bgcolor(strBody) 'Remove bgcolor strBody = background(strBody) 'Remove background image strBody = divs(strBody) 'Remove divs strBody = blanks(strBody) 'Remove blanks strBody = tables(strBody) 'Remove table if strMenu <> "" then strMenu = Exclude(strMenu) 'remove text which has to be excluded strMenu = Comments(strMenu) 'remove comments strMenu = fonts(strMenu) 'remove strMenu = JSRollOver(strMenu) 'Remove JScript strMenu = removeHrefs(strMenu) 'delete all hrefs and strMenu = divs(strMenu) 'Remove divs strMenu = blanks(strMenu) 'remove blanks strMenu = tables(strMenu) 'remove tables end if call display(strTitle, strMenu, strBody, strJavascript) end sub '---------------------------------------------- 'Get the body 'objRegExp.Pattern = "(.|\n)*" 'objRegExp.Pattern = "(.|\n)*" 'If comments are not in the page then only extract between Function getBody() Dim objRegExp, reg_matches Set objRegExp = New RegExp objRegExp.IgnoreCase = True objRegExp.Global = True objRegExp.Pattern = tagStart & "(.|\n)*" & tagEnd Set reg_matches = objRegExp.Execute(STRCONTENT) If reg_matches.Count > 0 Then getBody = reg_matches.Item(0).Value Set reg_matches = Nothing else objRegExp.Pattern = "" Set reg_matches = objRegExp.Execute(STRCONTENT) if reg_matches.Count > 0 then getBody = reg_matches.Item(0).Value end if Set reg_matches = Nothing End If Set objRegExp = Nothing End Function '---------------------------------------------- 'Get the menu Function getmenu() Dim bolMenuExists, objRegExp, reg_matches bolMenuExists = false 'First check if exists in the file Set objRegExp = New RegExp objRegExp.Pattern = "" objRegExp.IgnoreCase = True objRegExp.Global = True Set reg_matches = objRegExp.Execute(STRCONTENT) If reg_matches.Count > 0 Then bolMenuExists = true End If Set objRegExp = Nothing Set reg_matches = Nothing if bolMenuExists = true then 'if it exists then continue Set objRegExp = New RegExp objRegExp.Pattern = "(.|\n)*" objRegExp.IgnoreCase = True objRegExp.Global = True Set reg_matches = objRegExp.Execute(STRCONTENT) If reg_matches.Count > 0 Then getmenu = reg_matches.Item(0).Value End If Set objRegExp = Nothing Set reg_matches = Nothing else getmenu = "" end if End Function '---------------------------------------------- 'Extract everything between and including ' and Function getTitle() Dim objRegExp, reg_matches Set objRegExp = New RegExp objRegExp.IgnoreCase = True objRegExp.Global = True objRegExp.Pattern = "(.|\n)*?<\/title>" Set reg_matches = objRegExp.Execute(STRCONTENT) If reg_matches.Count > 0 Then getTitle = reg_matches.Item(0).Value else getTitle = "" End If Set objRegExp = Nothing Set reg_matches = Nothing end function '---------------------------------------------- 'Extract everything between and including '<head> and </head> Function getHead() Dim objRegExp, reg_matches Set objRegExp = New RegExp objRegExp.IgnoreCase = True objRegExp.Global = True objRegExp.Pattern = "<head>(.|\n)*?<\/head>" Set reg_matches = objRegExp.Execute(STRCONTENT) If reg_matches.Count > 0 Then getHead = reg_matches.Item(0).Value else getHead = "" End If Set objRegExp = Nothing Set reg_matches = Nothing end function '---------------------------------------------- 'Extract everything between and including '"<script" and "</script>" 'This assumes that Javascript is in the head of the document 'First get the head of the document 'Then extract the Javascript code from the head ' 'For <SCRIPT language=JavaScript1.2 src="location.js"></SCRIPT> 'it is necessary to convert src="location.js" to src="http://www.server.com/learning/location.js" Function getJavascript(text) Dim objRegExp, reg_matches, i, TempJScript, strScript TempJScript = "" Set objRegExp = New RegExp objRegExp.IgnoreCase = True objRegExp.Global = True objRegExp.Pattern = "<script(.|\n)*?<\/script>" Set reg_matches = objRegExp.Execute(text) If reg_matches.Count > 0 Then for i = 0 to reg_matches.Count - 1 TempJScript = TempJScript + reg_matches.Item(i).Value next strScript = TempJScript else strScript = "" End If 'Deal with src="location.js" and convert to full path objRegExp.Pattern = "src=""(.*?)" getJavascript = objRegExp.Replace (strScript,"src=" & chr(34) & STRTHISDIR & "$1") Set objRegExp = Nothing Set reg_matches = Nothing End Function '---------------------------------------------- 'Delete the text from within this area '<!-- exclude_starts_here //--> '<!-- exclude_ends_here //--> Function Exclude(text) Dim objRegExp Set objRegExp = New RegExp objRegExp.IgnoreCase = True objRegExp.Global = True objRegExp.Pattern = "<!--\s+exclude_starts_here\s+\/\/-->(.|\n)*?<!--\s+exclude_ends_here\s+\/\/-->" Exclude = objRegExp.Replace (text,"") Set objRegExp = Nothing End Function '---------------------------------------------- 'Look for comments <! ... > and delete '(Comments are acutally <!-- ... --> but datamart uses <! ... > Function Comments(text) Dim objRegExp Set objRegExp = New RegExp objRegExp.IgnoreCase = True objRegExp.Global = True objRegExp.Pattern = "<!--(.*?)-->" Comments = objRegExp.Replace (text,"") Set objRegExp = Nothing End Function '---------------------------------------------- 'Look for <font ... > and delete 'Look for </font> and delete 'Look for <h1> <h2> etc tags and delete Function fonts(text) Dim objRegExp Set objRegExp = New RegExp objRegExp.IgnoreCase = True objRegExp.Global = True objRegExp.Pattern = "<font(.*?)>" text = objRegExp.Replace (text,"") objRegExp.Pattern = "</font>" text = objRegExp.Replace (text,"") objRegExp.Pattern = "<h\d>" text = objRegExp.Replace (text,"<b>") objRegExp.Pattern = "</h\d>" fonts = objRegExp.Replace (text,"</b><br><br>") Set objRegExp = Nothing End Function '---------------------------------------------- 'Look for comments <span ... > and delete 'Look for </span> and delete Function span(text) Dim objRegExp Dim temp Set objRegExp = New RegExp objRegExp.IgnoreCase = True objRegExp.Global = True objRegExp.Pattern = "<span(.*?)>" temp = objRegExp.Replace (text,"") objRegExp.Pattern = "</span>" span = objRegExp.Replace (temp,"") Set objRegExp = Nothing End Function '---------------------------------------------- 'This is the only additional function needed for 'printer friendly version which removes all href links Function removeHrefs(text) Dim objRegExp Set objRegExp = New RegExp objRegExp.IgnoreCase = True objRegExp.Global = True 'Look for href="..." and remove objRegExp.Pattern = "<a\s+href\s?=\s?(.*?)>" text = objRegExp.Replace (text,"") 'Look for </a> and remove objRegExp.Pattern = "</a>" text = objRegExp.Replace (text,"") removeHrefs = text Set objRegExp = Nothing End Function '---------------------------------------------- 'Removes Javascript from hrefs. This is normally used to 'clean up the menu bar of Javascript rollovers. 'Change <a href="learning_gateway.asp" target="_parent" onmouseout="rollImage('4','out')" onmouseover="rollImage('4','over')">link</a> Function JSRollOver(text) Dim objRegExp Set objRegExp = New RegExp objRegExp.IgnoreCase = True objRegExp.Global = True 'this assumes that the string is <a href="....." followed by one or more blank spaces objRegExp.Pattern = "<a href=" & chr(34) & "(.*?)" & chr(34) & "\s+" & "(.*?)" & ">" text = objRegExp.Replace(text, "<a href=" & chr(34) & "$1" & chr(34) & ">") Set objRegExp = Nothing JSRollOver = text End Function '---------------------------------------------- 'Need to deal with href="mailto:..." 'At the moment this puts in all the directory info etc 'infront of href. Need to remove all this Function mailto(text) Dim objRegExp Set objRegExp = New RegExp objRegExp.IgnoreCase = True objRegExp.Global = True objRegExp.Pattern = "<a href(\s*?)=(.*?)mailto:(.*?)>" mailto = objRegExp.Replace (text, "<a href=" & chr(34) & "mailto:$3>") Set objRegExp = Nothing End function '---------------------------------------------- 'Look for bgcolor^=^"#xxxxxx" and delete Function bgcolor(text) Dim objRegExp Set objRegExp = New RegExp objRegExp.IgnoreCase = True objRegExp.Global = True objRegExp.Pattern = "bgcolor(\s*?)=(\s*?)\" & chr(34) & "#" & "\w{6}" & "\" & chr(34) bgcolor = objRegExp.Replace (text,"") Set objRegExp = Nothing End Function '---------------------------------------------- 'Look for backgound image in '<body marginwidth="0" marginheight="0" background="bkgd_w_blue.gif" leftmargin="0" topmargin="0"> 'and remove it Function background(text) Dim objRegExp Set objRegExp = New RegExp objRegExp.IgnoreCase = True objRegExp.Global = True objRegExp.Pattern = "<body(.*?)background=" & chr(34) & "(.*?)" & chr(34) & "(.*?)>" background = objRegExp.Replace (text,"<body $1 $3>") Set objRegExp = Nothing End Function '---------------------------------------------- 'Remove <applet...> and </applet> Function applets(text) Dim objRegExp Set objRegExp = New RegExp objRegExp.IgnoreCase = True objRegExp.Global = True objRegExp.Pattern = "<applet(.*?)</applet>" applets = objRegExp.Replace (text,"") Set objRegExp = Nothing End Function '---------------------------------------------- 'Remove shockwave and other objects '<object...> and </object> Function shockwave(text) Dim objRegExp Set objRegExp = New RegExp objRegExp.IgnoreCase = True objRegExp.Global = True objRegExp.Pattern = "<object(.|\n)*?</object>" shockwave = objRegExp.Replace (text,"") Set objRegExp = Nothing End Function '---------------------------------------------- 'Deal with <map...></map> 'Dosn't work at the moment because the still have shape="" and coords="" within the <area > 'Not sure how to do this yet as it may interfere with other process 'Should I explicity look for shape="" and coords="" and remove Function map(text) Dim objRegExp '<area shape="rect" coords="145,139,228,218" href="/info/gen_info_menu.asp" alt="General Information menu" title="General Information menu"> Set objRegExp = New RegExp objRegExp.IgnoreCase = True objRegExp.Global = True objRegExp.Pattern = "<area(.*?)shape=" & chr(34) & "(.*?)" & chr(34) & "(.*?)>" text = objRegExp.Replace (text,"<area$1$3>") Set objRegExp = New RegExp objRegExp.IgnoreCase = True objRegExp.Global = True objRegExp.Pattern = "<area(.*?)coords=" & chr(34) & "(.*?)" & chr(34) & "(.*?)>" text = objRegExp.Replace (text,"<area$1$3>") 'remove <map name="map"> Set objRegExp = New RegExp objRegExp.IgnoreCase = True objRegExp.Global = True objRegExp.Pattern = "<map(.*?)>" text = objRegExp.Replace (text,"") 'remove </map> Set objRegExp = New RegExp objRegExp.IgnoreCase = True objRegExp.Global = True objRegExp.Pattern = "</map>" text = objRegExp.Replace (text,"") 'replace "<area href='xxx' alt='yyy'>" with "<a href='xxx'>yyy</a>" Set objRegExp = New RegExp objRegExp.IgnoreCase = True objRegExp.Global = True objRegExp.Pattern = "<area(.*?)alt(\s*?)=(\s*?)" & chr(34) & "(.*?)" & chr(34) & "(.*?)>" text = objRegExp.Replace (text,"<a$1>$4</a><br>") Set objRegExp = Nothing map = text End Function '---------------------------------------------- 'Remove <div...> and </div> Function divs(text) Dim objRegExp Set objRegExp = New RegExp objRegExp.IgnoreCase = True objRegExp.Global = True objRegExp.Pattern = "<div(.*?)>" text = objRegExp.Replace (text,"") objRegExp.Pattern = "</div>" divs = objRegExp.Replace (text,"") Set objRegExp = Nothing End Function '---------------------------------------------- 'Remove blank lines Function blanks(text) Dim objRegExp 'objRegExp.Pattern = "<br>(.|\n)*?<br>" 'objRegExp.Pattern = "<br>" 'strbody = objRegExp.Replace (strbody,"") Set objRegExp = New RegExp objRegExp.IgnoreCase = True objRegExp.Global = True objRegExp.Pattern ="<br>(\s+?)<br>" blanks = objRegExp.Replace (text,"") Set objRegExp = Nothing End Function '---------------------------------------------- 'Remove tables and replace </tr> with <br> Function tables(text) Dim objRegExp Set objRegExp = New RegExp objRegExp.IgnoreCase = True objRegExp.Global = True objRegExp.Pattern = "<table(.*?)>" text = objRegExp.Replace (text,"<br>") objRegExp.Pattern = "</table(.*?)>" text = objRegExp.Replace (text,"") objRegExp.Pattern = "<td(.*?)>" text = objRegExp.Replace (text,"") objRegExp.Pattern = "<tr(.*?)>" text = objRegExp.Replace (text,"") objRegExp.Pattern = "</tr>" text = objRegExp.Replace (text,"<br><br>") objRegExp.Pattern = "</td>" text = objRegExp.Replace (text,"  ") objRegExp.Pattern = "<thead>" text = objRegExp.Replace (text,"") objRegExp.Pattern = "</thead>" text = objRegExp.Replace (text,"") objRegExp.Pattern = "<tbody>" text = objRegExp.Replace (text,"") objRegExp.Pattern = "</tbody>" text = objRegExp.Replace (text,"") objRegExp.Pattern = "<tfoot>" text = objRegExp.Replace (text,"") objRegExp.Pattern = "</tfoot>" text = objRegExp.Replace (text,"") objRegExp.Pattern = "<caption>" text = objRegExp.Replace (text,"") objRegExp.Pattern = "</caption>" text = objRegExp.Replace (text,"") Set objRegExp = Nothing tables = text End Function '------------------------------------- Function sendmail(CDOTo, CDOFrom, CDOBcc, CDOReplyTo, CDOSubject, CDOImportance, CDOBody) Dim ObjNewmail Set ObjNewmail = Server.CreateObject("CDONTS.NewMail") ObjNewmail.To = CDOTo ObjNewmail.From = CDOFrom 'ObjNewmail.Bcc = CDOBcc 'ObjNewmail.Value("ReplyTo") = CDOReplyTo ObjNewmail.Subject = CDOSubject ObjNewmail.Importance = CDOImportance ObjNewmail.Body = CDOBody ObjNewmail.Send() Set ObjNewmail = Nothing sendmail=1 End Function '--------------------------------------------------------- 'display the page sub display(title, menu, body, javascript) 'Response.Write body 'Response.End %> <html> <head> <meta name="ROBOTS" content="NOINDEX, NOFOLLOW"> <%=title%> <link rel="stylesheet" href="printver.css"> <%=javascript%> </head> <body> <table border="1" width="650"> <tr class="text"> <td align="center">A printer friendly version of a page from <%=STRSERVERNAME%> <br> </td> </tr> </table> <br> <%if menu <> "" then%> <table border="0" width="650"> <tr class="text"> <td> <%=menu%> </td> </tr> </table> <%end if%> <table border="0" width="<%=strWidth%>"> <tr class="text"> <td> <%=body%> </td> </tr> </table> <table border="1" width="<%=strWidth%>"> <tr class="text"> <td> <center> <% if Request.QueryString("url") = "" then %><a href="<%=strRefer%>">Return to graphics version</a><% elseif strFileID <> "" then %><a href="<%=strFileID%>">Return to graphics version</a><% else %><a href="<%=Request.QueryString("url")%>">Return to graphics version</a><% end if %> </center> </td> </tr> </table> </body> </html> <% End sub '---------------------------------------------- call main() %>