[新手上路]批处理新手入门导读[视频教程]批处理基础视频教程[视频教程]VBS基础视频教程[批处理精品]批处理版照片整理器
[批处理精品]纯批处理备份&还原驱动[批处理精品]CMD命令50条不能说的秘密[在线下载]第三方命令行工具[在线帮助]VBScript / JScript 在线参考
返回列表 发帖
batman

Rank: 8Rank: 8

帖子
2702 
积分
14559 
技术
176  
捐助
630  
注册时间
2008-6-16 
1楼 跳转到 » 倒序看帖
打印
tT
发表于 2013-1-25 23:30 | 只看该作者

[原创] 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

Rank: 5Rank: 5

帖子
766 
积分
1451 
技术
117  
捐助
0  
注册时间
2010-5-12 
2楼
发表于 2013-1-26 00:12 | 只看该作者
本帖最后由 Demon 于 2013-1-26 00:16 编辑

粗略看了一下，挑点骨头：

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

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

3、没有考虑制表符\t

4、论坛可以使用discuz code

5、EditPlus自带Copy as HTML功能

6、暂时没想到

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

TOP

batman

Rank: 8Rank: 8

帖子
2702 
积分
14559 
技术
176  
捐助
630  
注册时间
2008-6-16 
3楼
发表于 2013-1-26 21:32 | 只看该作者
感谢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

batman

Rank: 8Rank: 8

帖子
2702 
积分
14559 
技术
176  
捐助
630  
注册时间
2008-6-16 
4楼
发表于 2013-1-27 00:28 | 只看该作者
稍做修改后的实际应用：
http://user.qzone.qq.com/8416151 ... &pos=1359215037
ps:qq空间太水了，连HTML的PRE标签都不识别，搞得代码都没了格式
＊＊＊共同提高＊＊＊

TOP

batman

Rank: 8Rank: 8

帖子
2702 
积分
14559 
技术
176  
捐助
630  
注册时间
2008-6-16 
5楼
发表于 2013-1-29 00:27 | 只看该作者
本帖最后由 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. 

  29. Function GetHtmlCode(Str)

  30.    Dim objReg, objMaches, objMache

  31.    Set objReg = New RegExp

  32.    objReg.Global = True

  33.    objReg.IgnoreCase = True

  34.    objReg.Pattern = "([\s\S]+?)([^\s&,\(\.\):]*)"

  35.    Set objMaches = objReg.Execute(Str)

  36.    Dim Arr, SubStr, OK, objStr

  37.    For Each objMache In objMaches

  38.      OK = vbNullString

  39.      For i = 0 To UBound(objArray)

  40.        Arr = Split(objArray(i), ",")

  41.        For Each SubStr In Arr

  42.          If LCase(objMache.Submatches(1)) = LCase(SubStr) Then 

  43.            OK = "a"

  44.            WriteStr = WriteStr & objMache.Submatches(0) & "<font color=" & ColorArray(i) & ">" & SubStr & "</font>"

  45.          End If 

  46.        Next

  47.      Next

  48.      If OK = vbNullString Then WriteStr = WriteStr & objMache.Submatches(0) & objMache.Submatches(1)

  49.    Next

  50.    Set objReg = Nothing

  51. End Function
复制代码
＊＊＊共同提高＊＊＊

TOP

yu2n

Rank: 5Rank: 5

帖子
715 
积分
1295 
技术
150  
捐助
0  
注册时间
2012-11-1 
6楼
发表于 2013-7-7 17:06 | 只看该作者
嘿嘿，挑骨头就是舒服。
我也提一个，没有考虑读取VBS文件时，编码的问题。
还有 代码看得我头晕啊。
『千江有水千江月』千江有水，月映千江；万里无云，万里青天。    http://yu2n.qiniudn.com/

TOP

PowerShell

Rank: 5Rank: 5

帖子
437 
积分
1319 
技术
27  
捐助
0  
注册时间
2013-6-30 
7楼
发表于 2013-7-7 18:23 | 只看该作者
谁会把代码格式化程序写成逻辑原理，即文字说明
脚本是写给人看的,是写给用户看的,而不是写给机子看的
用户能看懂、会修改的脚本,才是好脚本。
写易懂的powershell脚本帮人解决问题,进而让用户学会自渔,吾所愿也

TOP

返回列表