批处理新手入门导读[视频教程]批处理基础视频教程[视频教程]VBS基础视频教程
[批处理文件精品]批处理版照片整理器[批处理文件精品]纯批处理备份&还原驱动在线第三方下载
返回列表 发帖

[原创] VBS实现代码关键词格式化书写以及颜色高亮排版功能

本帖最后由 batman 于 2013-1-29 08:04 编辑

没有什么技术含量,只是一时无聊之作,请将要排版的VBS拖放在本VBS上(因为暂时定义的是VBS语法关键词,想要排版批处理的请自行修改关键词),本来是想为论坛发帖时美化代码所写,可惜论坛现在的设置不支持HTML代码:
  1. Dim File
  2. On Error Resume Next
  3. File = WScript.Arguments.Item(0)
  4. If File = vbNullString Then WScript.Quit
  5. Dim Codes, FCTs, VBstrs, Values, objArray, ColorArray
  6. Codes = "and,or,for,each,to,step,next,if,then,else,end,set,dim,ReDim,do,while,wend,until,loop,exit,with,function,in,select,case,true,false"
  7. FCTs = "abs,array,asc,atn,cbool,cbyte,ccur,cdate,cdbl,chr,cint,class,clear,clng,const,cos,createobject,csng,cstr,date,dateadd,datediff,datepart,dateserial,datevalue,day,description,dictionary,empty,eqv,erase,err,eval,execute,execute,exp,filesystemobject,filter,firstindex,fix,formatcurrency,formatdatetime,formatnumber,formatpercent,function,getobject,getref,global,hex,helpcontext,helpfile,hour,ignorecase,imp,inputbox,instr,instrrev,int,isarray,isdate,isempty,isnull,isnumeric,isobject,join,lbound,lcase,left,len,length,loadpicture,log,ltrim,match,matches,mid,minute,mod,month,monthname,msgbox,msgbox,now,number,oct,option,pattern,private,propertyget,propertylet,propertyset,public,raise,randomize,redim,regexp,rem,replace,replace,rgb,right,rnd,round,rtrim,scriptengine,scriptenginebuildversion,scriptenginemajorversion,scriptengineminorversion,second,sgn,sin,source,space,split,sqr,strcomp,string,strreverse,sub,tan,test,time,timer,timeserial,timevalue,trim,typename,ubound,ucase,value,vartype,vartype,vbscript,weekday,weekdayname,wscript,xor,year"
  8. VBstrs = "vbcrlf,vbcr,vblf,vbtab,vbyesno,vbtrue,vbfalse,vbnullstring,vbformfeed,vbnewline,vbnullchar,vbnull,vbyes,vbno,vbok,vbcancle,vbokcancle,nothing"
  9. objArray = Array(Codes, FCTs, VBstrs)
  10. ColorArray = Array("darkorchid","blue","green")
  11. Dim objFSO, objStr, HeadStr, EndStr, Temp
  12. Set objFSO = CreateObject("Scripting.FileSystemObject")
  13. Temp = objFSO.GetSpecialFolder(2) & "\"
  14. HeadStr = "<html>" & vbCrLf _
  15.   & "<body bgcolor=""black"">" & vbCrLf _
  16.     & "<pre>" & vbCrLf _
  17.       & "<font color=""white"" size=4>"
  18. EndStr = "</font>" & vbCrLf _
  19.    & "</pre>" & vbCrLf _
  20.      &  "</body>" & vbCrLf _
  21.        & "</html>"
  22. Dim Arr, subArr, Arr1, subArr1, Arr2, subArr2, Str, WriteStr, Var
  23. objStr = objFSO.OpenTextFile(File).ReadAll()
  24. Arr = Split(objStr, vbCrLf)
  25. For Each subArr In Arr
  26.   Arr1 = Split(subArr, " ")
  27.   For Each subArr1 In Arr1
  28.     Str = subArr1
  29.     For i = 0 To UBound(objArray)
  30.       Arr2 = Split(objArray(i), ",")
  31.       For Each subArr2 In Arr2
  32.         If i = 1 Then
  33.           If InStr(LCase(subArr1), subArr2 & "(") Or _
  34.             InStr(LCase(subArr1), subArr2 & " ") Or _
  35.              InStr(LCase(subArr1), subArr2 & ".") Then
  36.             Var = UCase(Left(subArr2, 1)) & LCase(Mid(subArr2, 2, Len(subArr2)))
  37.             Var = "<font color=""" & ColorArray(i) & """>" & Var & "</font>"
  38.             Str = Replace(LCase(subArr1), subArr2, Var)
  39.           End If
  40.           Else
  41.           If LCase(subArr1) = subArr2 Then
  42.             Str = UCase(Left(subArr1, 1)) & LCase(Mid(subArr1, 2, Len(subArr1)))
  43.             Str = "<font color=""" & ColorArray(i) & """>" & Str & "</font>"
  44.           End If
  45.         End If
  46.       Next
  47.     Next
  48.     WriteStr = WriteStr & Str & " "
  49.   Next
  50.   WriteStr = WriteStr & vbCrLf
  51. Next
  52. '本可以用IE对象直接写的,但考虑IE浏览器不一定靠谱,所以还是用临时文件来输出
  53. objFSO.OpenTextFile(Temp & "temp.html", 2, True).Write HeadStr & WriteStr & EndStr
  54. Set objFSO = Nothing
  55. CreateObject("Wscript.Shell").Run Temp & "temp.html", True, False
复制代码
***共同提高***

本帖最后由 Demon 于 2013-1-26 00:16 编辑

粗略看了一下,挑点骨头:

1、没有包括所有VBS关键字、常量、函数(见《VBS关键字和保留字》、《VBS内置常量大全》、《VBS内置函数大全》、

2、没有考虑字符串中的高亮问题

3、没有考虑制表符\t

4、论坛可以使用discuz code

5、EditPlus自带Copy as HTML功能

6、暂时没想到

可以参考我写的VBS代码格式化工具,当然,我写的也并不完美,想要完美的话需要对脚本进行词法分析和语法分析,一直想写,但是一直没有时间,楼主有时间的话不妨研究一下。

TOP

本帖最后由 batman 于 2013-1-29 08:05 编辑

感谢Demon的帮助,先修改如下:
1、补充了大量关键词
2、对字符串中的关键词进行了筛选判断(同时效率降低不少)
3、关键词大小写定位
4、语法分析暂无时间和能力去做
5、欢迎大家测试和批评指正
  1. Dim File
  2. On Error Resume Next
  3. File = WScript.Arguments.Item(0)
  4. If File = vbNullString Then WScript.Quit
  5. Dim Codes, FCTs, VBstrs, Values, objArray, ColorArray, HeadArray, EndArray
  6. 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"
  7. 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"
  8. 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"
  9. objArray = Array(Codes, FCTs, VBstrs)
  10. ColorArray = Array("darkorchid","blue","green")
  11. HeadArray = Array("&", "(", ".", ",", "")
  12. EndArray = Array(".", "(", "")
  13. Dim objFSO, objStr, HeadStr, EndStr, Temp
  14. Set objFSO = CreateObject("Scripting.FileSystemObject")
  15. Temp = objFSO.GetSpecialFolder(2) & "\"
  16. HeadStr = "<html>" & vbCrLf _
  17.   & "<body bgcolor=""black"">" & vbCrLf _
  18.     & "<pre>" & vbCrLf _
  19.       & "<font color=""white"" size=4>"
  20. EndStr = "</font>" & vbCrLf _
  21.    & "</pre>" & vbCrLf _
  22.      &  "</body>" & vbCrLf _
  23.        & "</html>"
  24. Dim Arr, subArr, Arr1, subArr1, Arr2, subArr2, Str, WriteStr, Var, Hstr, Estr, OK
  25. objStr = objFSO.OpenTextFile(File).ReadAll()
  26. Arr = Split(objStr, vbCrLf)
  27. For Each subArr In Arr
  28.   Arr1 = Split(subArr, " ")
  29.   For Each subArr1 In Arr1
  30.     Str = subArr1
  31.     For i = 0 To UBound(objArray)
  32.       Arr2 = Split(objArray(i), ",")
  33.       For Each subArr2 In Arr2
  34.         OK = "b"
  35.         If i = 1 Then
  36.           For Each Hstr In HeadArray
  37.             For Each Estr In EndArray
  38.               If Hstr = "" And Estr <> "" Then
  39.                 If InStr(1, Str, Hstr & subArr2 & Estr, 1) = 1 Then OK = "a"
  40.                 Else
  41.                 If Estr = "" Then
  42.                   If InStr(1, Str, Hstr & subArr2 & Estr, 1) And _
  43.                     LCase(Right(Str, Len(subArr2))) = LCase(subArr2) And _
  44.                       Hstr <>"" Then OK = "a"
  45.                   Else
  46.                   If InStr(1, Str, Hstr & subArr2 & Estr, 1) Or _
  47.                     LCase(Str) = LCase(subArr2) Then OK = "a"
  48.                 End If
  49.               End If
  50.             Next
  51.           Next
  52.           Else
  53.           If i = 2 Then
  54.             If LCase(Str) = LCase(subArr2) Or _
  55.               InStr(1, Str, "&" & subArr2, 1) Or _
  56.                 InStr(1, Str, subArr2 & "&", 1) Or _
  57.                   InStr(1, Str, "&" & subArr2 & "&", 1) Then OK = "a"
  58.             Else
  59.             If LCase(Str) = LCase(subArr2) Then OK = "a"
  60.           End If
  61.         End If
  62.         If OK = "a" Then
  63.           Var = subArr2
  64.           Var = "<font color=""" & ColorArray(i) & """>" & Var & "</font>"
  65.           Str = Replace(Str, subArr2, Var, 1, -1, 1)
  66.         End If
  67.       Next
  68.     Next
  69.     WriteStr = WriteStr & Str & " "
  70.   Next
  71.   WriteStr = WriteStr & vbCrLf
  72. Next
  73. '本可以用IE对象直接写的,但考虑IE浏览器不一定靠谱,所以还是用临时文件来输出
  74. objFSO.OpenTextFile(Temp & "temp.html", 2, True).Write HeadStr & WriteStr & EndStr
  75. Set objFSO = Nothing
  76. CreateObject("Wscript.Shell").Run Temp & "temp.html", True, False
复制代码
附本人测试的实际可能出现的一些代码组合情况:
附件: 您需要登录才可以下载或查看附件。没有帐号?注册
***共同提高***

TOP

稍做修改后的实际应用:
http://user.qzone.qq.com/8416151 ... &pos=1359215037
ps:qq空间太水了,连HTML的PRE标签都不识别,搞得代码都没了格式
***共同提高***

TOP

本帖最后由 batman 于 2013-1-29 08:05 编辑

利用VBS正则解决关键词准确判断以及效率双问题,同时简化代码:
  1. Dim File
  2. On Error Resume Next
  3. File = WScript.Arguments.Item(0)
  4. If File = vbNullString Then WScript.Quit
  5. Dim Codes, FCTs, VBstrs, Values, objArray, ColorArray, HeadArray, EndArray
  6. 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"
  7. 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"
  8. 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"
  9. objArray = Array(Codes, FCTs, VBstrs)
  10. ColorArray = Array("darkorchid","blue","green")
  11. Dim objFSO, ReadStr, HeadStr, EndStr, Temp
  12. Set objFSO = CreateObject("Scripting.FileSystemObject")
  13. Temp = objFSO.GetSpecialFolder(2) & "\"
  14. HeadStr = "<html>" & vbCrLf _
  15.   & "<body bgcolor=""black"">" & vbCrLf _
  16.     & "<pre>" & vbCrLf _
  17.       & "<font color=""white"" size=4>"
  18. EndStr = "</font>" & vbCrLf _
  19.    & "</pre>" & vbCrLf _
  20.      &  "</body>" & vbCrLf _
  21.        & "</html>"
  22. ReadStr = vbCrLf & objFSO.OpenTextFile(File).ReadAll()
  23. Dim WriteStr
  24. GetHtmlCode ReadStr
  25. objFSO.OpenTextFile(Temp & "temp.html", 2, True).Write HeadStr &  WriteStr & EndStr
  26. Set objFSO = Nothing
  27. CreateObject("Wscript.Shell").Run Temp & "temp.html", True, False
  28. Function GetHtmlCode(Str)
  29.    Dim objReg, objMaches, objMache
  30.    Set objReg = New RegExp
  31.    objReg.Global = True
  32.    objReg.IgnoreCase = True
  33.    objReg.Pattern = "([\s\S]+?)([^\s&,\(\.\):]*)"
  34.    Set objMaches = objReg.Execute(Str)
  35.    Dim Arr, SubStr, OK, objStr
  36.    For Each objMache In objMaches
  37.      OK = vbNullString
  38.      For i = 0 To UBound(objArray)
  39.        Arr = Split(objArray(i), ",")
  40.        For Each SubStr In Arr
  41.          If LCase(objMache.Submatches(1)) = LCase(SubStr) Then
  42.            OK = "a"
  43.            WriteStr = WriteStr & objMache.Submatches(0) & "<font color=" & ColorArray(i) & ">" & SubStr & "</font>"
  44.          End If
  45.        Next
  46.      Next
  47.      If OK = vbNullString Then WriteStr = WriteStr & objMache.Submatches(0) & objMache.Submatches(1)
  48.    Next
  49.    Set objReg = Nothing
  50. End Function
复制代码
***共同提高***

TOP

嘿嘿,挑骨头就是舒服。
我也提一个,没有考虑读取VBS文件时,编码的问题。
还有 代码看得我头晕啊。
『千江有水千江月』千江有水,月映千江;万里无云,万里青天。    http://yu2n.qiniudn.com/

TOP

谁会把代码格式化程序写成逻辑原理,即文字说明
脚本是写给人看的,是写给用户看的,而不是写给机子看的
用户能看懂、会修改的脚本,才是好脚本。
写易懂的powershell脚本帮人解决问题,进而让用户学会自渔,吾所愿也

TOP

返回列表