服务器之家:专注于服务器技术及软件下载分享
分类导航

PHP教程|ASP.NET教程|JAVA教程|ASP教程|

服务器之家 - 编程语言 - ASP教程 - VBS、ASP代码语法加亮显示的类

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

2019-10-30 15:49asp教程网 ASP教程

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

代码如下:


<% 
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, "<", "&lt;") 
workString = replace(workString, ">", "&gt;") 
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 & "&quot;" 
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, "<", "&lt;") 
workString = replace(workString, ">", "&gt;") 
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 
%> 





<!--#include file="token.asp"--> 
<% ' ************************************************************************* 
' 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 
%> 

延伸 · 阅读

精彩推荐