VBS、ASP代码语法加亮显示的类

作者:admin 日期:2009-05-15

字体大小: 小中大

<% 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

  Private Sub Class_Initialize()
  TableBGColor = "white"
  CodeColor = "Blue"
  CommentColor = "Green"
  StringColor = "Gray"
  TabSpaces = " "
  PathToFile = ""

  m_StartTime = 0
  m_EndTime = 0
  m_LineCount = 0

  KeyMin = 2
  KeyMax = 8

  Set objDict = server.CreateObject("Scripting.Dictionary")
  objDict.CompareMode = 1

  CreateKeywords

  Set objFSO = server.CreateObject("Scripting.FileSystemObject")
  End Sub

  Private Sub Class_Terminate()
  Set objDict = Nothing
  Set objFSO = Nothing
  End Sub


  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 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

  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

  Private Function Min(x, y)
  Dim tempMin
  If x < y Then tempMin = x Else tempMin = y
  Min = tempMin
  End Function

  Private Function Max(x, y)
  Dim tempMax
  If x > y Then tempMax = x Else tempMax = y
  Max = tempMax
  End Function

  Public Sub AddKeyword(inKeyword, inToken)
  KeyMin = Min(Len(inKeyword), KeyMin)
  KeyMax = Max(Len(inKeyword), KeyMax)

  objDict.Add LCase(inKeyword), inToken
  End Sub

  Public Sub ParseFile(blnOutputHTML)
  Dim m_strReadLine, tempString, blnInScriptBlock, blnGoodExtension, i
  Dim blnEmptyLine

  m_LineCount = 0

  If Len(PathToFile) = 0 Then
  Err.Raise 5, "cBuffer: PathToFile Length Zero"
  Exit Sub
  End If

  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

  Set objFile = objFSO.OpenTextFile(server.MapPath(PathToFile))

  Response.Write "<table nowrap bgcolor=" & TableBGColor & " cellpadding=0 cellspacing=0>"
  Response.Write "<tr><td><PRE>"

  m_StartTime = Time()

  Do While Not objFile.AtEndOfStream
  m_strReadLine = objFile.ReadLine

  blnEmptyLine = False
  If Len(m_strReadLine) = 0 Then
  blnEmptyLine = True
  End If

  m_strReadLine = Replace(m_strReadLine, vbTab, TabSpaces)
  m_LineCount = m_LineCount + 1
  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>%gt;</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 Class
  %>

  使用前把里面的全角字符转换成半角的

    
  <% ' *************************************************************************
  ' This is all test/example code showing the calling syntax of the
  ' cBuffer class ... the interface to the cBuffer object is quite simple.
  '
  ' Use it for reference ... delete it ... whatever.
  ' *************************************************************************

  REM This is a rem type comment just for testing purposes!

  ' This variable will hold an instance of the cBuffer class
  Dim objBuffer

  ' Set up the error handling
  On Error Resume Next

  ' create the instance of the cBuffer class
  Set objBuffer = New cBuffer

  ' Set the PathToFile property of the cBuffer class
  '
  ' Just for kicks we'll use the asp file that we created
  ' in the last installment of this article series for testing purposes
  objBuffer.PathToFile = "../081899/random.asp" '这是文件名啦。

  ' Here's an example of how to add a new keyword to the keyword array
  ' You could add a list of your own function names, variables or whatever...cool!
  ' NOTE: You can add different HTML formatting if you like, the <strong>
  ' attribute will applied to all keywords ... this is likely to change
  ' in the near future.
  '
  'objBuffer.AddKeyword "response.write", "<font color=Red>Response.Write</font>"

  ' Here are examples of changing the table background color, code color,
  ' comment color, string color and tab space properties
  '
  'objBuffer.TableBGColor = "LightGrey" ' or
  'objBuffer.TableBGColor = "#ffffdd" ' simple right?
  'objBuffer.CodeColor = "Red"
  'objBuffer.CommentColor = "Orange"
  'objBuffer.StringColor = "Purple"
  'objBuffer.TabSpaces = " "

  ' Call the ParseFile method of the cBuffer class, pass it true if you want the
  ' HTML contained in the page output or false if you don't
  objBuffer.ParseFile False '注意：显示代码的response.write已经在class中。这里调用方法就可以了。



  ' Check for errors that may have been raised and write them out
  If Err.number <> 0 Then
  Response.Write Err.number & ":" & Err.description & ":" & Err.source & "<br>"
  End If

  ' Output the processing time and number of lines processed by the script
  Response.Write "<strong>Processing Time:</strong> " & objBuffer.ProcessingTime & " seconds<br>"
  Response.Write "<strong>Lines Processed:</strong> " & objBuffer.LineCount & "<br>"

  ' Destroy the instance of our cBuffer class
  Set objBuffer = Nothing
  %>

'引用自http://www.jscode.cn/arthtml/art4445.htm