感谢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 | | | | objFSO.OpenTextFile(Temp & "temp.html", 2, True).Write HeadStr & WriteStr & EndStr | | Set objFSO = Nothing | | CreateObject("Wscript.Shell").Run Temp & "temp.html", True, FalseCOPY |
附本人测试的实际可能出现的一些代码组合情况： |
发表于 2013-1-25 23:30
| 
