感谢Demon的帮助，先修改如下：
1、补充了大量关键词
2、对字符串中的关键词进行了筛选判断（同时效率降低不少）
3、关键词大小写定位
4、语法分析暂无时间和能力去做
5、欢迎大家测试和批评指正- Dim File
- On Error Resume Next
- File = WScript.Arguments.Item(0)
- If File = vbNullString Then WScript.Quit
- Dim Codes, FCTs, VBstrs, Values, objArray, ColorArray, HeadArray, EndArray
- Codes = "Xor,Mod,Private,And,Or,For,Each,To,Step,Next,If,Then,Else,End,Set,Dim,ReDim,Do,While,Wend,Until,Loop,Exit,With,Function,Sub,In,Select,Case,Class"
- FCTs = "Year,Wsh,Wscript,WeekdayName,Weekday,VarType,Unescape,UCase,UBound,TypeName,Trim,TimeValue,TimeSerial,Timer,Time,Tan,StrReverse,string,StrComp,Sqr,Split,Space,Sin,Sgn,Second,ScriptEngineMinorVersion,ScriptEngineMajorVersion,ScriptEngineBuildVersion,ScriptEngine,RTrim,Round,Rnd,RightB,Right,RGB,Replace,Randomize,Oct,Now,MsgBox,MonthName,Month,Minute,MidB,Mid,LTrim,Log,LoadPicture,LenB,Len,LeftB,Left,LCase,LBound,Join,IsObject,IsNumeric,IsNull,IsEmpty,IsDate,IsArray,Int,InStrRev,InStrB,InStr,InputBox,Hour,Hex,GetRef,GetObject,FormatPercent,FormatNumber,FormatDateTime,FormatCurrency,Fix,Filter,Exp,ExecuteGlobal,Execute,Eval,Escape,Erase,Day,DateValue,DateSerial,DatePart,DateDiff,DateAdd,Date,CStr,CSng,CreateObject,Cos,CLng,CInt,ChrW,ChrB,Chr,CDbl,CDate,CCur,CByte,CBool,Atn,AscW,AscB,Asc,Array,Abs"
- VBstrs = "vbYesNoCancel,vbYesNo,vbYes,vbYellow,vbWhite,vbWednesday,vbVerticalTab,vbVariant,vbUseSystemDayOfWeek,vbUseSystem,vbUseDefault,vbTuesday,vbTrue,vbThursday,vbTextCompare,vbTab,vbSystemModal,vbSunday,vbString,vbSingle,vbShortTime,vbShortDate,vbSaturday,vbRetryCancel,vbRetry,vbRed,vbQuestion,vbOKOnly,vbOKCancel,vbOK,vbObjectError,vbObject,vbNullString,vbNullChar,vbNull,vbNo,vbNewLine,VbMsgBoxSetForeground,vbMsgBoxRtlReading,vbMsgBoxRight,vbMsgBoxHelpButton,vbMonday,vbMagenta,vbLongTime,vbLongDate,vbLong,vbLf,vbInteger,vbInformation,vbIgnore,vbGreen,vbGeneralDate,vbFriday,vbFormFeed,vbFirstJan1,vbFirstFullWeek,vbFirstFourDays,vbFalse,vbExclamation,vbError,vbEmpty,vbDouble,vbDefaultButton4,vbDefaultButton3,vbDefaultButton2,vbDefaultButton1,vbDecimal,vbDate,vbDataObject,vbDatabaseCompare,vbCyan,vbCurrency,vbCrLf,vbCritical,vbCr,vbCancel,vbByte,vbBoolean,vbBlue,vbBlack,vbBinaryCompare,vbArray,vbApplicationModal,vbAbortRetryIgnore,vbAbort,True,Nothing,False"
- objArray = Array(Codes, FCTs, VBstrs)
- ColorArray = Array("darkorchid","blue","green")
- HeadArray = Array("&", "(", ".", ",", "")
- EndArray = Array(".", "(", "")
- Dim objFSO, objStr, HeadStr, EndStr, Temp
- Set objFSO = CreateObject("Scripting.FileSystemObject")
- Temp = objFSO.GetSpecialFolder(2) & "\"
- HeadStr = "<html>" & vbCrLf _
- & "<body bgcolor=""black"">" & vbCrLf _
- & "<pre>" & vbCrLf _
- & "<font color=""white"" size=4>"
- EndStr = "</font>" & vbCrLf _
- & "</pre>" & vbCrLf _
- & "</body>" & vbCrLf _
- & "</html>"
- Dim Arr, subArr, Arr1, subArr1, Arr2, subArr2, Str, WriteStr, Var, Hstr, Estr, OK
- objStr = objFSO.OpenTextFile(File).ReadAll()
- Arr = Split(objStr, vbCrLf)
- For Each subArr In Arr
- Arr1 = Split(subArr, " ")
- For Each subArr1 In Arr1
- Str = subArr1
- For i = 0 To UBound(objArray)
- Arr2 = Split(objArray(i), ",")
- For Each subArr2 In Arr2
- OK = "b"
- If i = 1 Then
- For Each Hstr In HeadArray
- For Each Estr In EndArray
- If Hstr = "" And Estr <> "" Then
- If InStr(1, Str, Hstr & subArr2 & Estr, 1) = 1 Then OK = "a"
- Else
- If Estr = "" Then
- If InStr(1, Str, Hstr & subArr2 & Estr, 1) And _
- LCase(Right(Str, Len(subArr2))) = LCase(subArr2) And _
- Hstr <>"" Then OK = "a"
- Else
- If InStr(1, Str, Hstr & subArr2 & Estr, 1) Or _
- LCase(Str) = LCase(subArr2) Then OK = "a"
- End If
- End If
- Next
- Next
- Else
- If i = 2 Then
- If LCase(Str) = LCase(subArr2) Or _
- InStr(1, Str, "&" & subArr2, 1) Or _
- InStr(1, Str, subArr2 & "&", 1) Or _
- InStr(1, Str, "&" & subArr2 & "&", 1) Then OK = "a"
- Else
- If LCase(Str) = LCase(subArr2) Then OK = "a"
- End If
- End If
- If OK = "a" Then
- Var = subArr2
- Var = "<font color=""" & ColorArray(i) & """>" & Var & "</font>"
- Str = Replace(Str, subArr2, Var, 1, -1, 1)
- End If
- Next
- Next
- WriteStr = WriteStr & Str & " "
- Next
- WriteStr = WriteStr & vbCrLf
- Next
- '本可以用IE对象直接写的，但考虑IE浏览器不一定靠谱，所以还是用临时文件来输出
- objFSO.OpenTextFile(Temp & "temp.html", 2, True).Write HeadStr & WriteStr & EndStr
- Set objFSO = Nothing
- CreateObject("Wscript.Shell").Run Temp & "temp.html", True, False
附本人测试的实际可能出现的一些代码组合情况： |
发表于 2013-1-25 23:30
| 
