VBScript版代碼高亮

更新時(shí)間：2006年06月26日 00:00:00 作者：

<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
<html>
<head>
<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
<title>VBScript版代碼高亮</title>
<link href="style.css" rel="stylesheet" type="text/css" />
</head>

<body>
<div class="menu_head">VBScript版代碼高亮</div>
<div class="content">
<script language="vbscript" type="text/vbscript">
'======================================
'代碼高亮類
'使用方法:
'Set HL = New Highlight '定義類
'HL.Language = "vb" '指定程序語言,支持 VBS ,JS ,XML, HTML, SQL, C#, Java...等
'還可通過直接設(shè)置下列屬性還設(shè)置相關(guān)關(guān)鍵字等
' Public Keywords  '關(guān)鍵字
' Public Objects  '對象
' Public SplitWords '分隔符
' Public LineComment '行注釋
' Public CommentOn '多行注釋
' Public CommentOff '多行注釋結(jié)束
' Public Ignore  '是否區(qū)分大小寫
' Public CodeContent '代碼內(nèi)容
' Public Tags   '標(biāo)記
' Public StrOn  '字符串標(biāo)記
' Public Escape  '字符串界定符轉(zhuǎn)義
' Public IsMultiple '允許多行引用
'HL.CodeContent = "要高亮的代碼內(nèi)容"
'Response.Write(Hl.Execute) '該方法返回高亮后的代碼
'=====================================

Class Highlight
Public Keywords  '關(guān)鍵字
Public Objects  '對象
Public SplitWords '分隔符
Public LineComment '行注釋
Public CommentOn '多行注釋
Public CommentOff '多行注釋結(jié)束
Public Ignore  '是否區(qū)分大小寫
Public CodeContent '代碼內(nèi)容
Public Tags   '標(biāo)記
Public StrOn  '字符串標(biāo)記
Public Escape  '字符串界定符轉(zhuǎn)義
Public IsMultiple '允許多行引用
Private Content

Private Sub Class_Initialize
  Keywords = "function,void,this,boolean,while,if,return,new,true,false,try,catch,throw,null,else,int,long,do,var"  '關(guān)鍵字
  Objects = "src,width,border,cellspacing,cellpadding,align,bgcolor,class,style,href,type,name,String,Number,Boolean,RegExp,Error,Math,Date" '對象
  SplitWords = " ,.?!;:\/<>(){}[]""'=+-|*%@#$^&"&VBCRLF&CHR(9) '分隔符
  LineComment = "http://" '行注釋
  CommentOn = "/*" '多行注釋
  CommentOff = "*/" '多行注釋結(jié)束
  Ignore = 0  '是否區(qū)分大小寫
  Tags = "a,img,html,head,body,title,style,script,language,input,select,div,span,button,img,iframe,frame,frameset,table,tr,td,caption,form,font,meta,textarea"  '標(biāo)記
  StrOn = """'"  '字符串標(biāo)記
  Escape = "\"  '字符串界定符轉(zhuǎn)義
  CodeContent = ""
End Sub

Public Function Execute
  Dim S
  Dim T, Key, X, Str
  Dim Flag
  Flag = 1: S = 1
  For i = 1 to Len(CodeContent)
   If Instr(1, SplitWords, Mid(CodeContent, i, 1) , 0)>0 Then
    If Flag = 1 Then
     Key = Mid(Codecontent, S, i - S)
     If Keywords<>"" And Instr(1, ","& Keywords &"," , ","&Key&"," , Ignore)>0 Then
      Content = Content& "<font color=""blue"">"&Key&"</font>"
     ElseIf Objects<>"" And Instr(1,","& Objects &",", ","&Key&"," , Ignore)>0 Then
      Content = Content & "<font color=""red"">"&Key&"</font>"
     ElseIf Tags <>"" And Instr(1, ","& Tags &",", ","&Key&"," , Ignore)>0 Then
      Content = Content & "<font color=""#996600"">"&Key&"</font>"
     Else
      Content = Content & Key
     End If
    End if
    Flag = 0
    X = Mid(CodeContent, i, 1)
    If LineComment<>"" And Mid(CodeContent, i, Len(LineComment)) = LineComment Then
     S = Instr(i ,CodeContent, VBCRLF)
     if S = 0 Then
      S = Len(CodeContent)
     End if
     Content = Content & "<font color=""Green"">"& HtmlEnCode(Mid(CodeContent,i ,S - i ))&"</font>"
     i = S
    ElseIf StrOn<>"" And Instr(StrOn,Mid(CodeContent, i, 1))>0 Then
     Str = Mid(CodeContent, i, 1)
     S = i
     Do
      S = Instr(S + 1 ,CodeContent, Str, 1)
      if S <> 0 Then
       T = S - 1
       Do While Mid(CodeContent, T, 1) = Escape
        T = T-1
       Loop
       If (S -T) Mod 2 = 1 Then
        Exit Do
       End If
      Else
       S = Len(CodeContent)
       Exit Do
      End If
     Loop While 1
     Content = Content & "<font color=""#FF00FF"">"& HtmlEnCode(Mid(CodeContent,i, S - i + 1))&"</font>"
     i = S
    ElseIf CommentOn<>"" And Mid(CodeContent, i, Len(CommentOn)) = CommentOn Then
     S = Instr(i ,CodeContent, CommentOff, 1)
     if S = 0 Then
      S = Len(CodeContent)
     End if
     Content = Content & "<font color=""Green"">"& HtmlEnCode(Mid(CodeContent,i, S - i + Len(CommentOff) ))&"</font>"
     i = S + Len(CommentOff)
    ElseIf X = "" Then
     Content = Content & " "
    ElseIf X = """" Then
     Content = Content & """
    ElseIf X = "&" Then
     Content = Content & "&"
    ElseIf X = "<" Then
     Content = Content & "<"
    ElseIf X = ">" Then
     Content = Content & ">"
    ElseIf X = Chr(9) Then
     Content = Content & "  "
    ElseIf X = VBLF Then
     Content = Content & "<br />"
    Else
     Content = Content & X
    End If
   Else
    If Flag = 0 Then
     S = i
     Flag = 1
    End if
   End If
  Next
  if Flag = 1 Then
   Execute = Content & Mid(CodeContent, S)
  Else
   Execute = content
  End If
End Function

Private Function HtmlEnCode(Str)
  If IsNull(Str) Then
   HtmlEnCode = "": Exit Function
  End if
  Str = Replace(Str ,"&","&")
  Str = Replace(Str ,"<","<")
  Str = Replace(Str ,">",">")
  Str = Replace(Str ,"""",""")
  Str = Replace(Str ,Chr(9),"  ")
  Str = Replace(Str ," "," ")
  Str = Replace(Str ,VBLF,"<br />")
  HtmlEnCode = Str
End Function

Public Property Let Language(Str)
  Dim S
  S = UCase(Str)
  Select Case true
   Case S = "VB" Or S = "VBS" OR S = "VBSCRIPT":
    Keywords = "And,ByRef,ByVal,Call,Case,Class,Const,Dim,Do,Each,Else,ElseIf,Empty,End,Eqv,Erase,Error,Exit,Explicit,False,For,Function,Get,If,Imp,In,Is,Let,Loop,Mod,Next,Not,Nothing,Null,On,Option,Or,Private,Property,Public,Randomize,ReDim,Resume,Select,Set,Step,Sub,Then,To,True,Until,Wend,While,Xor,Anchor,Array,Asc,Atn,CBool,CByte,CCur,CDate,CDbl,Chr,CInt,CLng,Cos,CreateObject,CSng,CStr,Date,DateAdd,DateDiff,DatePart,DateSerial,DateValue,Day,Dictionary,Document,Element,Err,Exp,FileSystemObject,Filter,Fix,Int,Form,FormatCurrency,FormatDateTime,FormatNumber,FormatPercent,GetObject,Hex,Hour,InputBox,InStr,InstrRev,IsArray,IsDate,IsEmpty,IsNull,IsNumeric,IsObject,Join,LBound,LCase,Left,Len,Link,LoadPicture,Location,Log,LTrim,RTrim,Trim,Mid,Minute,Month,MonthName,MsgBox,Navigator,Now,Oct,Replace,Right,Rnd,Round,ScriptEngine,ScriptEngineBuildVersion,ScriptEngineMajorVersion,ScriptEngineMinorVersion,Second,Sgn,Sin,Space,Split,Sqr,StrComp,String,StrReverse,Tan,Time,TextStream,TimeSerial,TimeValue,TypeName,UBound,UCase,VarType,Weekday,WeekDayName,Year,Function"
    Objects ="String,Number,Boolean,Date,Integert,Long,Double,Single"
    SplitWords = ",.?!;:\/<>(){}[]""'=+-|*%@#$^& "&VBCRLF&Chr(9)
    LineComment = "'"
    CommentOn = ""
    CommentOff = ""
    StrOn = """"
    Escape = ""
    Ignore = 1
    CodeContent = ""
    Tags = ""

   Case s = "C#":
    Keywords = "abstract,as,base,bool,break,byte,case,catch,char,checked,class,const,continue,decimal,default,delegate,do,double,else,enum,event,explicit,extern,false,finally,fixed,float,for,foreach,get,goto,if,implicit,in,int,interface,internal,is,lock,long,namespace,new,null,object,operator,out,override,params,private,protected,public,readonly,ref,return,sbyte,sealed,short,sizeof,stackalloc,static,set,string,struct,switch,this,throw,true,try,typeof,uint,ulong,unchecked,unsafe,ushort,using,value,virtual,void,volatile,while"  '關(guān)鍵字
    Objects = "String,Boolean,DateTime,Int32,Int64,Exception,DataTable,DataReader" '對象
    SplitWords = " ,.?!;:\/<>(){}[]""'=+-|*%@#$^&"&VBCRLF&CHR(9) '分隔符
    LineComment = "http://" '行注釋
    CommentOn = "/*" '多行注釋
    CommentOff = "*/" '多行注釋結(jié)束
    Ignore = 0  '是否區(qū)分大小寫
    Tags = ""  '標(biāo)記
    StrOn = """"  '字符串標(biāo)記
    Escape = "\"  '字符串界定符轉(zhuǎn)義

   Case S = "JAVA" :
    Keywords = "abstract,boolean,break,byte,case,catch,char,class,const,continue,default,do,double,else,extends,final,finally,float,for,goto,if,implements,import,instanceof,int,interface,long,native,new,package,private,protected,public,return,short,static,strictfp,super,switch,synchronized,this,throw,throws,transient,try,void,volatile,while"  '關(guān)鍵字
    Objects = "String,Boolean,DateTime,Int32,Int64,Exception,DataTable,DataReader" '對象
    SplitWords = " ,.?!;:\/<>(){}[]""'=+-|*%@#$^&"&VBCRLF&CHR(9) '分隔符
    LineComment = "http://" '行注釋
    CommentOn = "/*" '多行注釋
    CommentOff = "*/" '多行注釋結(jié)束
    Ignore = 0  '是否區(qū)分大小寫
    Tags = ""  '標(biāo)記
    StrOn = """"  '字符串標(biāo)記
    Escape = "\"  '字符串界定符轉(zhuǎn)義

   Case S = "JS" OR S = "JSCRIPT" OR S = "JAVASCRIPT":
    Keywords = "function,void,this,boolean,while,if,return,new,true,false,try,catch,throw,null,else,int,long,do,var"  '關(guān)鍵字
    Objects = "String,Number,Boolean,RegExp,Error,Math,Date" '對象
    SplitWords = " ,.?!;:\/<>(){}[]""'=+-|*%@#$^&"&VBCRLF&CHR(9) '分隔符
    LineComment = "http://" '行注釋
    CommentOn = "/*" '多行注釋
    CommentOff = "*/" '多行注釋結(jié)束
    Ignore = 0  '是否區(qū)分大小寫
    Tags = ""  '標(biāo)記
    StrOn = """"  '字符串標(biāo)記
    Escape = "\"  '字符串界定符轉(zhuǎn)義

Case S = "XML":
    Keywords = "!DOCTYPE,?xml,script,version,encoding"  '關(guān)鍵字
    Objects = "String,Number,Boolean,RegExp,Error,Math,Date" '對象
    SplitWords = " ,.?!;:\/<>(){}[]""'=+-|*%@#$^&"&VBCRLF&CHR(9) '分隔符
    LineComment = "http://" '行注釋
    CommentOn = "" '多行注釋結(jié)束
    Ignore = 0  '是否區(qū)分大小寫
    Tags = ""  '標(biāo)記
    StrOn = """"  '字符串標(biāo)記
    Escape = "\"  '字符串界定符轉(zhuǎn)義

   Case S = "HTML":
   Case S = "SQL":
    Keywords = "COMMIT,DELETE,INSERT,LOCK,ROLLBACK,SELECT,TRANSACTION,READ,ONLY,WRITE,USE,ROLLBACK,SEGMENT,ROLE,EXCEPT,NONE,UPDATE,DUAL,WORK,COMMENT,FORCE,FROM,WHERE,INTO,VALUES,ROW,SHARE,MODE,EXCLUSIVE,UPDATE,ROW,NOWAIT,TO,SAVEPOINT,UNION,UNION,ALL,INTERSECT,MINUS,START,WITH,CONNECT,BY,GROUP,HAVING,ORDER,UPDATE,NOWAIT,IDENTIFIED,SET,DROP,PACKAGE,CREATE,REPLACE,PROCEDURE,FUNCTION,TABLE,RETURN,AS,BEGIN,DECLARE,END,IF,THEN,ELSIF,ELSE,WHILE,CURSOR,EXCEPTION,WHEN,OTHERS,NO_DATA_FOUND,TOO_MANY_ROWS,CURSOR_ALREADY_OPENED,FOR,LOOP,IN,OUT,TYPE,OF,INDEX,BINARY_INTEGER,RAISE,ROWTYPE,VARCHAR2,NUMBER,LONG,DATE,RAW,LONG RAW,CHAR,INTEGER,MLSLABEL,CURRENT,OF,DEFAULT,CURRVAL,NEXTVAL,LEVEL,ROWID,ROWNUM,DISTINCT,ALL,LIKE,IS,NOT,NULL,BETWEEN,ANY,AND,OR,EXISTS,ASC,DESC,ABS,CEIL,COS,COSH,EXP,FLOOR,LN,LOG,MOD,POWER,ROUND,SIGN,SIN,SINH,SQRT,TAN,TANH,TRUNC,CHR,CONCAT,INITCAP,LOWER,LPAD,LTRIM,NLS_INITCAP,NLS_LOWER,NLS_UPPER,REPLACE,RPAD,RTRIM,SOUNDEX,SUBSTR,SUBSTRB,TRANSLATE,UPPER,ASCII,INSTR,INSTRB,LENGTH,LENGTHB,NLSSORT,ADD_MONTHS,LAST_DAY,MONTHS_BETWEEN,NEW_TIME,NEXT_DAY,ROUND,SYSDATE,TRUNC,CHARTOROWID,CONVERT,HEXTORAW,RAWTOHEX,ROWIDTOCHAR,TO_CHAR,TO_DATE,TO_LABEL,TO_MULTI_BYTE,TO_NUMBER,TO_SINGLE_BYTE,DUMP,GREATEST,GREATEST_LB,LEAST,LEAST_UB,NVL,UID,USER,USERENV,VSIZE,AVG,COUNT,GLB,LUB,MAX,MIN,STDDEV,SUM,VARIANCE"  '關(guān)鍵字
    Objects = "" '對象
    SplitWords = " ,.?!;:\\/<>(){}[]""'=+-|*%@#$^&"&VBCRLF&CHR(9) '分隔符
    LineComment = "--" '行注釋
    CommentOn = "/*" '多行注釋
    CommentOff = "*/" '多行注釋結(jié)束
    Ignore = 1  '是否區(qū)分大小寫
    Tags = ""  '標(biāo)記
    StrOn = "'"  '字符串標(biāo)記
    Escape = ""  '字符串界定符轉(zhuǎn)義
  End Select
End Property
End Class
</script>
<script language="vbscript" type="text/vbscript">
Function plaster()
document.form1.code.focus()
document.execCommand("Paste")
End Function

Function goit(stx)
Dim code,HL
code = Document.all.code.value
Set HL = New Highlight
HL.Language = stx
HL.CodeContent = code
document.getElementById("highlight").innerHTML = Hl.Execute
End Function
</script>