批处理之家 - Powered by Discuz! Board

Dim File
On Error Resume Next
File = WScript.Arguments.Item(0)
If File = vbNullString Then WScript.Quit
Dim Codes, FCTs, VBstrs, Values, objArray, ColorArray
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"
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"
VBstrs = "vbcrlf,vbcr,vblf,vbtab,vbyesno,vbtrue,vbfalse,vbnullstring,vbformfeed,vbnewline,vbnullchar,vbnull,vbyes,vbno,vbok,vbcancle,vbokcancle,nothing"
objArray = Array(Codes, FCTs, VBstrs)
ColorArray = Array("darkorchid","blue","green")
Dim objFSO, objStr, HeadStr, EndStr, Temp
Set objFSO = CreateObject("Scripting.FileSystemObject")
Temp = objFSO.GetSpecialFolder(2) & "\"
HeadStr = "<html>" & vbCrLf _
& "<body bgcolor=""black"">" & vbCrLf _
& "<pre>" & vbCrLf _
& ""
EndStr = "" & vbCrLf _
& "</pre>" & vbCrLf _
& "</body>" & vbCrLf _
& "</html>"
Dim Arr, subArr, Arr1, subArr1, Arr2, subArr2, Str, WriteStr, Var
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
If i = 1 Then
If InStr(LCase(subArr1), subArr2 & "(") Or _
InStr(LCase(subArr1), subArr2 & " ") Or _
InStr(LCase(subArr1), subArr2 & ".") Then
Var = UCase(Left(subArr2, 1)) & LCase(Mid(subArr2, 2, Len(subArr2)))
Var = "" & Var & ""
Str = Replace(LCase(subArr1), subArr2, Var)
End If
Else
If LCase(subArr1) = subArr2 Then
Str = UCase(Left(subArr1, 1)) & LCase(Mid(subArr1, 2, Len(subArr1)))
Str = "" & Str & ""
End If
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

复制代码

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 _
& ""
EndStr = "" & 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 = "" & Var & ""
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

复制代码

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"
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")
Dim objFSO, ReadStr, HeadStr, EndStr, Temp
Set objFSO = CreateObject("Scripting.FileSystemObject")
Temp = objFSO.GetSpecialFolder(2) & "\"
HeadStr = "<html>" & vbCrLf _
& "<body bgcolor=""black"">" & vbCrLf _
& "<pre>" & vbCrLf _
& ""
EndStr = "" & vbCrLf _
& "</pre>" & vbCrLf _
& "</body>" & vbCrLf _
& "</html>"
ReadStr = vbCrLf & objFSO.OpenTextFile(File).ReadAll()
Dim WriteStr
GetHtmlCode ReadStr
objFSO.OpenTextFile(Temp & "temp.html", 2, True).Write HeadStr & WriteStr & EndStr
Set objFSO = Nothing
CreateObject("Wscript.Shell").Run Temp & "temp.html", True, False
Function GetHtmlCode(Str)
Dim objReg, objMaches, objMache
Set objReg = New RegExp
objReg.Global = True
objReg.IgnoreCase = True
objReg.Pattern = "([\s\S]+?)([^\s&,\(\.\):]*)"
Set objMaches = objReg.Execute(Str)
Dim Arr, SubStr, OK, objStr
For Each objMache In objMaches
OK = vbNullString
For i = 0 To UBound(objArray)
Arr = Split(objArray(i), ",")
For Each SubStr In Arr
If LCase(objMache.Submatches(1)) = LCase(SubStr) Then
OK = "a"
WriteStr = WriteStr & objMache.Submatches(0) & "" & SubStr & ""
End If
Next
Next
If OK = vbNullString Then WriteStr = WriteStr & objMache.Submatches(0) & objMache.Submatches(1)
Next
Set objReg = Nothing
End Function

复制代码