这类程序在网上很多，但拿来练练“正则表达式”也不错的，所以就随手写了这个，现在只能对代码（函数，关键字，对象，字符串）进行着色，下一步想对函数块加入折叠效果（.NET代码编辑器的效果）。
演示效果代码：（ChangeVBToColor函数即是重点函数）
---------------------------------------------------------------------------------------------------------------
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN"
"http://www.w3.org/TR/html4/loose.dtd">
<html>
<head>
<meta http-equiv="Content-Type" content="text/html; charset=gb2312">
<title>无标题文档</title>
<style type="text/css">
<!--
body {
font-family: "宋体";
font-size: 12px;
color: #333333;
}
.Text {
font-family: "宋体";
font-size: 12px;
border: 1px solid #333333;
}
td {
font-family: "宋体";
font-size: 12px;
}
-->
</style>
</head>
<body>
<table width="760" height="399" border="0" cellpadding="0" cellspacing="2">
<tr>
<td height="302" valign="top"><form name="form1" method="post" action="">
<div align="center">
<textarea name="Content" cols="120" rows="25" class="Text" id="Content"></textarea>
<br>
<input name="btnShow" type="button" class="Text" id="btnShow" value="显 示" OnClick="GetHtmlContent()">
</div>
</form></td>
</tr>
<tr>
<td height="91"><span id="sHtml"></span></td>
</tr>
</table>
<SCRIPT LANGUAGE="VBScript">
Sub GetHtmlContent
'GGG form1.Content.value
document.all.sHtml.innerHTML=ChangeVbToColor(HtmlEncode(form1.Content.value))
End Sub
Function ChangeVbToColor(ByVal sText)
Dim re,Matches,i
Dim oneReg
Set re=new RegExp
re.IgnoreCase =true
re.Global=true
'转换函数块
're.Pattern="Function (\w+)(\([^\)]*\))?([^End Function]*)End Function"
'sText=re.Replace(sText,"<font color=red>$1</font>")
'sText=re.Replace(sText,"<img src=http://www.cnblogs.com/Images/OutliningIndicators/ExpandedSubBlockStart.gif>$3")
'alert sText
'转换保留字为[蓝色]
re.Pattern="(\bAnd\b|\bByRef\b|\bByVal\b|\bCall\b|\bCase\b|\bClass\b|\bConst\b|\bDim\b|\bDo\b|\bEach\b|\bElse\b|\bElseIf\b|\bEmpty\b|\bEnd\b|\bEqv\b|\bErase\b|\bError\b|\bExit\b|\bExplicit\b|\bFalse\b|\bFor\b|\bFunction\b|\bGet\b|\bIf\b|\bImp\b|\bIn\b|\bIs\b|\bLet\b|\bLoop\b|\bMod\b|\bNext\b|\bNot\b|\bNothing\b|\bNull\b|\bOn\b|\bOption\b|\bOr\b|\bPrivate\b|\bProperty\b|\bPublic\b|\bRandomize\b|\bReDim\b|\bRem\b|\bResume\b|\bSelect\b|\bSet\b|\bStep\b|\bSub\b|\bThen\b|\bTo\b|\bTrue\b|\bUntil\b|\bWend\b|\bWhile\b|\bXor\b)"
sText=re.Replace(sText,"<font color=blue>$1</font>")
'转换函数和对象为[红色]
re.Pattern="(\bAnchor\b|\bArray\b|\bAsc\b|\bAtn\b|\bCBool\b|\bCByte\b|\bCCur\b|\bCDate\b|\bCDbl\b|\bChr\b|\bCInt\b|\bCLng\b|\bCos\b|\bCreateObject\b|\bCSng\b|\bCStr\b|\bDate\b|\bDateAdd\b|\bDateDiff\b|\bDatePart\b|\bDateSerial\b|\bDateValue\b|\bDay\b|\bDictionary\b|\bDocument\b|\bElement\b|\bErr\b|\bExp\b|\bFileSystemObject \b|\bFilter\b|\bFix\b|\bInt\b|\bForm\b|\bFormatCurrency\b|\bFormatDateTime\b|\bFormatNumber\b|\bFormatPercent\b|\bGetObject\b|\bHex\b|\bHistory\b|\bHour\b|\bInputBox\b|\bInStr\b|\bInstrRev\b|\bIsArray\b|\bIsDate\b|\bIsEmpty\b|\bIsNull\b|\bIsNumeric\b|\bIsObject\b|\bJoin\b|\bLBound\b|\bLCase\b|\bLeft\b|\bLen\b|\bLink\b|\bLoadPicture\b|\bLocation\b|\bLog\b|\bLTrim\b|\bRTrim\b|\bTrim\b|\bMid\b|\bMinute\b|\bMonth\b|\bMonthName\b|\bMsgBox\b|\bNavigator\b|\bNow\b|\bOct\b|\bReplace\b|\bRight\b|\bRnd\b|\bRound\b|\bScriptEngine\b|\bScriptEngineBuildVersion\b|\bScriptEngineMajorVersion\b|\bScriptEngineMinorVersion\b|\bSecond\b|\bSgn\b|\bSin\b|\bSpace\b|\bSplit\b|\bSqr\b|\bStrComp\b|\bString\b|\bStrReverse\b|\bTan\b|\bTime\b|\bTextStream\b|\bTimeSerial\b|\bTimeValue\b|\bTypeName\b|\bUBound\b|\bUCase\b|\bVarType\b|\bWeekday\b|\bWeekDayName\b|\bWindow\b|\bYear\b)"
sText=re.Replace(sText,"<font color=red>$1</font>")
'转换字符串为[紫色]
re.Pattern="(""[^""]*"")"
sText=re.Replace(sText,"<font color=#FF33FF>$1</font>")
sText = Replace(sText, CHR(34), """)
sText = Replace(sText, CHR(39), "'")
ChangeVbToColor=sText
End Function
Function HTMLEncode(fString)
If Not isnull(fString) Then
fString = replace(fString, "&", "&")
fString = replace(fString, ">", ">")
fString = replace(fString, "<", "<")
fString = replace(fString, CHR(32), " ")
fString = replace(fString, CHR(9), " ")
fString = Replace(fString, CHR(13), "")
fString = Replace(fString, CHR(10) & CHR(10), "</P><P> ")
fString = Replace(fString, CHR(10), "<BR> ")
HTMLEncode = fString
Else
HTMLEncode=""
End If
End Function
Function GGG(ByVal sText)
dim re,name,strTemplate,Matches,i
Dim oneReg
set re=new RegExp
re.IgnoreCase =true
re.Global=true
're.Pattern= "<(.*)>.*<\/\1>"
re.Pattern="Function (\w+)(\([^\)]*\))?(.[^(End Function)]*)End Function"
Set Matches=re.Execute(sText)
alert sText
alert Matches.Count
For i =0 to Matches.Count-1
alert Matches(i).SubMatches(0)&"<br>"
Next
End Function
</SCRIPT>
</body>
</html>
