ASP 101 - Active Server Pages 101 - Web01
The Place ASP Developers Go!



Windows Technology Windows Technology
15 Seconds
4GuysFromRolla.com
ASP 101
ASP Wire
VB Forums
VB Wire
WinDrivers.com
internet.commerce internet.commerce
Partners & Affiliates
ASP 101 is an
internet.com site
ASP 101 is an internet.com site
IT
Developer
Internet News
Small Business
Personal Technology

Search internet.com
Advertise
Corporate Info
Newsletters
Tech Jobs
E-mail Offers

ASP 101 News Flash ASP 101 News Flash



 Top ASP 101 Stories Top ASP 101 Stories
What is Adovbs.inc and Why Do I Need It?
An Overview of ASP.NET
Connections, Commands, And Procedures

QUICK TIP:
Handling "File In Use" Errors when Updating an Access DB
Show All Tips >>
ASP 101 RSS Feed ASP 101 Updates


<%
'****************************************************************************** ' ********************** DO NOT DELETE **************************************** ' ' COPYRIGHT NOTICE: Copyright 1999 Jon M. Gohr, NetTech Development Inc. ' ' This code is free for non-commercial use. Any commercial usage or ' duplication requires a licensing agreement from the author who may be ' contacted at the following email address: jongohr@yahoo.com ' ' The author assumes no responsibility for any damage caused by the ' proper or inproper use of this code. ' ' ********************** DO NOT DELETE **************************************** '******************************************************************************
%>
<%
Class cBuffer Private objFSO, objFile, objDict Private m_strPathToFile, m_TableBGColor, m_StartTime Private m_EndTime, m_LineCount, m_intKeyMin, m_intKeyMax Private m_CodeColor, m_CommentColor, m_StringColor, m_TabSpaces '************************************************************************** ' BEGIN EVENT HANDLERS '************************************************************************** Private Sub Class_Initialize() ' Set the intial table background color TableBGColor = "white" ' Set the intial color for the code keywords CodeColor = "Blue" ' Set the intial color for comments CommentColor = "Green" ' Set the intial color for quoted strings StringColor = "Gray" ' Set the number of spaces we will use to replace tab characters TabSpaces = " " ' Set the File Path to an empty string PathToFile = "" ' Zero these out, hopefully their use is obvious? m_StartTime = 0 m_EndTime = 0 m_LineCount = 0 ' 2 is the size of the smallest known keyword KeyMin = 2 ' 8 is the size of the largest known keyword KeyMax = 8 ' Create an instance of the dictionary object Set objDict = server.CreateObject("Scripting.Dictionary") ' Set the dictionary object compare mode to text objDict.CompareMode = 1 CreateKeywords ' Create an instance of the FileSystemObject Set objFSO = server.CreateObject("Scripting.FileSystemObject") End Sub Private Sub Class_Terminate() ' Destroy the objects created in the intialize event Set objDict = Nothing Set objFSO = Nothing End Sub '************************************************************************** ' END EVENT HANDLERS '************************************************************************** '************************************************************************** ' BEGIN PROPERTIES '************************************************************************** ' PROPERTIES WITH SOME PUBLIC EXPOSURE ************************************ Public Property Let CodeColor(inColor) m_CodeColor = "<font color=" & inColor & "><Strong>" End Property Private Property Get CodeColor() CodeColor = m_CodeColor End Property Public Property Let CommentColor(inColor) m_CommentColor = "<font color=" & inColor & ">" End Property Private Property Get CommentColor() CommentColor = m_CommentColor End Property Public Property Let StringColor(inColor) m_StringColor = "<font color=" & inColor & ">" End Property Private Property Get StringColor() StringColor = m_StringColor End Property Public Property Let TabSpaces(inSpaces) m_TabSpaces = inSpaces End Property Private Property Get TabSpaces() TabSpaces = m_TabSpaces End Property Public Property Let TableBGColor(inColor) m_TableBGColor = inColor End Property Private Property Get TableBGColor() TableBGColor = m_TableBGColor End Property Public Property Get ProcessingTime() ProcessingTime = Second(m_EndTime - m_StartTime) End Property Public Property Get LineCount() LineCount = m_LineCount End Property Public Property Get PathToFile() PathToFile = m_strPathToFile End Property Public Property Let PathToFile(inPath) m_strPathToFile = inPath End Property ' PRIVATE PROPERTIES ****************************************************** Private Property Let KeyMin(inMin) m_intKeyMin = inMin End Property Private Property Get KeyMin() KeyMin = m_intKeyMin End Property Private Property Let KeyMax(inMax) m_intKeyMax = inMax End Property Private Property Get KeyMax() KeyMax = m_intKeyMax End Property '************************************************************************** ' END PROPERTIES '************************************************************************** '************************************************************************** ' BEGIN METHODS '************************************************************************** ' subroutine to add all of the known language keywords to the dictionary Private Sub CreateKeywords() objDict.Add "abs", "Abs" objDict.Add "and", "And" objDict.Add "array", "Array" objDict.Add "call", "Call" objDict.Add "cbool", "CBool" objDict.Add "cbyte", "CByte" objDict.Add "ccur", "CCur" objDict.Add "cdate", "CDate" objDict.Add "cdbl", "CDbl" objDict.Add "cint", "CInt" objDict.Add "class", "Class" objDict.Add "clng", "CLng" objDict.Add "const", "Const" objDict.Add "csng", "CSng" objDict.Add "cstr", "CStr" objDict.Add "date", "Date" objDict.Add "dim", "Dim" objDict.Add "do", "Do" objDict.Add "loop", "Loop" objDict.Add "empty", "Empty" objDict.Add "eqv", "Eqv" objDict.Add "erase", "Erase" objDict.Add "exit", "Exit" objDict.Add "false", "False" objDict.Add "fix", "Fix" objDict.Add "for", "For" objDict.Add "next", "Next" objDict.Add "each", "Each" objDict.Add "function", "Function" objDict.Add "global", "Global" objDict.Add "if", "If" objDict.Add "then", "Then" objDict.Add "else", "Else" objDict.Add "elseif", "ElseIf" objDict.Add "imp", "Imp" objDict.Add "int", "Int" objDict.Add "is", "Is" objDict.Add "lbound", "LBound" objDict.Add "len", "Len" objDict.Add "mod", "Mod" objDict.Add "new", "New" objDict.Add "not", "Not" objDict.Add "nothing", "Nothing" objDict.Add "null", "Null" objDict.Add "on", "On" objDict.Add "error", "Error" objDict.Add "resume", "Resume" objDict.Add "option", "Option" objDict.Add "explicit", "Explicit" objDict.Add "or", "Or" objDict.Add "private", "Private" objDict.Add "property", "Property" objDict.Add "get", "Get" objDict.Add "let", "Let" objDict.Add "set", "Set" objDict.Add "public", "Public" objDict.Add "redim", "Redim" objDict.Add "select", "Select" objDict.Add "case", "Case" objDict.Add "end", "End" objDict.Add "sgn", "Sgn" objDict.Add "string", "String" objDict.Add "sub", "Sub" objDict.Add "true", "True" objDict.Add "ubound", "UBound" objDict.Add "while", "While" objDict.Add "wend", "Wend" objDict.Add "with", "With" objDict.Add "xor", "Xor" End Sub ' Simple function to return the smaller of two numbers Private Function Min(x, y) Dim tempMin If x < y Then tempMin = x Else tempMin = y Min = tempMin End Function ' simple function to return the larger of two numbers Private Function Max(x, y) Dim tempMax If x > y Then tempMax = x Else tempMax = y Max = tempMax End Function ' Public method to add keywords to the dictionary object Public Sub AddKeyword(inKeyword, inToken) KeyMin = Min(Len(inKeyword), KeyMin) KeyMax = Max(Len(inKeyword), KeyMax) objDict.Add LCase(inKeyword), inToken End Sub ' This is the primary method of the class. Public Sub ParseFile(blnOutputHTML) Dim m_strReadLine, tempString, blnInScriptBlock, blnGoodExtension, i Dim blnEmptyLine ' zero out the line count m_LineCount = 0 ' Check the length of the PathToFile property. If Len(PathToFile) = 0 Then Err.Raise 5, "cBuffer: PathToFile Length Zero" Exit Sub End If ' Check the file extension Select Case LCase(Right(PathToFile, 3)) Case "asp", "inc" blnGoodExtension = True Case Else blnGoodExtension = False End Select If Not blnGoodExtension Then Err.Raise 5, "cBuffer: File extension not asp or inc" Exit Sub End If ' Open the file Set objFile = objFSO.OpenTextFile(server.MapPath(PathToFile)) ' Start the outside table which will contain all the output Response.Write "<table nowrap bgcolor=" & TableBGColor & " cellpadding=0 cellspacing=0>" Response.Write "<tr><td><PRE>" ' Grab the time at the start of processing m_StartTime = Time() ' loop and read the file a line at a time Do While Not objFile.AtEndOfStream m_strReadLine = objFile.ReadLine ' Because of the line conversion we do below we need to catch ' blank lines up here right away. blnEmptyLine = False If Len(m_strReadLine) = 0 Then blnEmptyLine = True End If ' Replace all the tab characters with spaces m_strReadLine = Replace(m_strReadLine, vbTab, TabSpaces) ' Increment the line count m_LineCount = m_LineCount + 1 ' Trim all the spaces from the left side of the line ' so we can start doing evaluation of the content of the line tempString = LTrim(m_strReadLine) ' Check for the top script line that set's the default script language ' for the page. If left( tempString, 3 ) = Chr(60) & "%@" And right(tempString, 2) = "%" & Chr(62) Then Response.Write "<table><tr bgcolor=yellow><td>" Response.Write server.HTMLEncode(m_strReadLine) Response.Write "</td></tr></table>" blnInScriptBlock = False ' Check for an opening script tag ElseIf Left( tempString, 2) = Chr(60) & "%" Then ' Check for a closing script tag on the same line If right( RTrim(tempString), 2 ) = "%" & Chr(62) Then Response.Write "<table><tr><td bgcolor=yellow><%</td>" Response.Write "<td>" Response.Write CharacterParse(mid(m_strReadLine, 3, Len(m_strReadLine) - 4)) Response.Write "</td>" Response.Write "<td bgcolor=yellow>%></td></tr></table>" blnInScriptBlock = False Else Response.Write "<table><tr bgcolor=yellow><td><%</td></tr></table>" ' We've got an opening script tag so set the flag to true so ' that we know to start parsing the lines for keywords/comments blnInScriptBlock = True End If Else If blnInScriptBlock Then If blnEmptyLine Then Response.Write vbCrLf Else If right(tempString, 2) = "%" & Chr(62) Then Response.Write "<table><tr bgcolor=yellow><td>%></td></tr></table>" blnInScriptBlock = False Else Response.Write CharacterParse(m_strReadLine) & vbCrLf End If End If Else If blnOutputHTML Then If blnEmptyLine Then Response.Write vbCrLf Else Response.Write server.HTMLEncode(m_strReadLine) & vbCrLf End If End If End If End If Loop ' Grab the time at the completion of processing m_EndTime = Time() ' Close the outside table Response.Write "</PRE></td></tr></table>" ' Close the file and destroy the file object objFile.close Set objFile = Nothing End Sub ' This function parses a line character by character Private Function CharacterParse(inLine) Dim charBuffer, tempChar, i, outputString Dim insideString, workString, holdChar insideString = False outputString = "" For i = 1 to Len(inLine) tempChar = mid(inLine, i, 1) Select Case tempChar Case " " If Not insideString Then charBuffer = charBuffer & " " If charBuffer <>" " Then If left(charBuffer, 1) = " " Then outputString = outputString & " " ' Check for a 'rem' style comment marker If LCase(Trim(charBuffer)) = "rem" Then outputString = outputString & CommentColor outputString = outputString & "REM" workString = mid( inLine, i, Len(inLine)) workString = replace(workString, "<", "<") workString = replace(workString, ">", ">") outputString = outputString & workString & "</font>" charBuffer = "" Exit For End If outputString = outputString & FindReplace(Trim(charBuffer)) If right(charBuffer, 1) = " " Then outputString = outputString & " " charBuffer = "" End If Else outputString = outputString & " " End If Case "(" If left(charBuffer, 1) = " " Then outputString = outputString & " " End If outputString = outputString & FindReplace(Trim(charBuffer)) & "(" charBuffer = "" Case Chr(60) outputString = outputString & "<" Case Chr(62) outputString = outputString & ">" Case Chr(34) ' catch quote chars and flip a boolean variable to denote that ' whether or not we're "inside" a quoted string insideString = Not insideString If insideString Then outputString = outputString & StringColor outputString = outputString & """ Else outputString = outputString & """ outputString = outputString & "</font>" End If Case "'" ' Catch comments and output the rest of the line ' as a comment IF we're not inside a string. If Not insideString Then outputString = outputString & CommentColor workString = mid( inLine, i, Len(inLine)) workString = replace(workString, "<", "<") workString = replace(workString, ">", ">") outputString = outputString & workString outputString = outputString & "</font>" Exit For Else outputString = outputString & "'" End If Case Else ' We've dealt with special case characters so now ' we'll begin adding characters to our outputString ' or charBuffer depending on the state of the insideString ' boolean variable If insideString Then outputString = outputString & tempChar Else charBuffer = charBuffer & tempChar End If End Select Next ' Deal with the last part of the string in the character buffer If Left(charBuffer, 1) = " " Then outputString = outputString & " " End If ' Check for closing parentheses at the end of a string If right(charBuffer, 1) = ")" Then charBuffer = Left(charBuffer, Len(charBuffer) - 1) CharacterParse = outputString & FindReplace(Trim(charBuffer)) & ")" Exit Function End If CharacterParse = outputString & FindReplace(Trim(charBuffer)) End Function ' return true or false if a passed in number is between KeyMin and KeyMax Private Function InRange(inLen) If inLen >= KeyMin And inLen <= KeyMax Then InRange = True Exit Function End If InRange = False End Function ' Evaluate the passed in string and see if it's a keyword in the ' dictionary. If it is we will add html formatting to the string ' and return it to the caller. Otherwise just return the same ' string as was passed in. Private Function FindReplace(inToken) ' Check the length to make sure it's within the range of KeyMin and KeyMax If InRange(Len(inToken)) Then If objDict.Exists(inToken) Then FindReplace = CodeColor & objDict.Item(inToken) & "</Strong></Font>" Exit Function End If End If ' Keyword is either too short or too long or doesn't exist in the ' dictionary so we'll just return what was passed in to the function FindReplace = inToken End Function '************************************************************************** ' END METHODS '************************************************************************** End Class
%>
Processing Time: 0 seconds
Lines Processed: 487

Home |  News |  Samples |  Articles |  Lessons |  Resources |  Forum |  Links |  Search |  Feedback

Internet.com
The Network for Technology Professionals

Search:

About Internet.com

Legal Notices, Licensing, Permissions, Privacy Policy.
Advertise | Newsletters | E-mail Offers