Dim Parameters, WSHShell, Fs Set Parameters = WScript.Arguments If Parameters.Count <= 0 Then Wscript.Quit End If Set WSHShell = WScript.CreateObject("WScript.Shell") Set Fs = WScript.CreateObject("Scripting.FileSystemObject") Const vbWq = """" Dim vbSp, vbTc, vbCt, vbWt, vbTs, vbCs Dim sDt, iC, nS, rF, tN, tE, tSep, sF, tFile, sFile, rFile Dim sHs, sHe, sTops, sHeadders, sUnders Dim hColor, fColor, rL,ltc, sltc, fQp, iQp, isQp, isQpc, lrL, nrL, rrL, wL vbSp = " " vbTc = vbTab & vbCrlf vbCt = vbCrLf & vbTab vbWt = vbWq & vbTab vbTs = String(2,vbTab) vbCts = vbCrLf & vbTs vbCs = String(2,vbCrLf) ltc = Split("&,l,t,;",",") sltc = Join(ltc,"") sHs = "<html>" & vbCt & "<head>" & vbCts & "<link rel=" & vbWq & "stylesheet" & vbWq & " type=" & vbWq & "text/css" & vbWq & " href=" & vbWq & "http://www.okitsunesama.com/Okitsunesama.css" & vbWq & ">" & vbCts & "<!-- <link rel=" & vbWq & "stylesheet" & vbWq & " type=" & vbWq & "text/css" & vbWq & " href=" & vbWq & "OkitsunesamaLabo.css" & vbWq & "> -->" & vbCts & "<title>おきつねさまのろぐてすと " sHe = "</title>" & vbCt & "</head>" & vbCt & "<body class=" & vbWq & "CatalogView" & vbWq & ">" & vbCrLf sTops = vbCrLf & "<table class=" & vbWq & "ScriptExp" & vbWq & "><tr class=" & vbWq & "ScriptExp" & vbWq & "><td><pre>" sUnders = "</pre></td></tr></table>" & vbCrLf & vbCt & "</body>" & vbCrLf & "</html>" hColor = "<a class=" & vbWq & "ScriptComments" & vbWq & "><font color=" & vbWq & "#ffffff" & vbWq & ">" fColor = "</Font></a>" For iC = 0 To Parameters.count - 1 tFile = Parameters(iC) If Fs.FileExists(tFile) then sDt = iDT(""," ","",0) nS = Fs.GetFile(tFile).size If nS < 1 Then Else tE = Ucase(Fs.GetExtensionName(tFile)) If tE = "VBS" or tE = "TXT" or tE = "INI" or tE = "JS" Then If tE = "JS" Then tSep = "//" Else tSep = "'" End If rF = Fs.GetParentFolderName(tFile) tN = Fs.GetBaseName(tFile) sF = Fs.BuildPath(rF,tN & " t2H " & sDt & ".html") sHeadders = sHs & tn & "." & Lcase(tE) & sHe & sTops Set sFile = Fs.OpenTextFile(tFile,1) Set rFile = Fs.CreateTextFile(sF,0) WScript.Sleep 200 Do Until sFile.AtEndOfStream rL = sFile.ReadLine rL = Replace(rL,"<",sltc) fQp = InStr(1,rL,tSep) iQp = 0 isQp= 1 isQpc = 1 If fQp > 0 Then If fQp = 1 Then rL = hColor & rL & fColor Else Do iQp = InStr(isQp + 1,rL,tSep) isQp = InStr(isQpc + 1,rL,vbWq & tSep & vbWq) + 1 If isQp = 0 Then Exit Do End If isQpc = isQp Loop While iQp = isQp If iQp > 0 Then lrL = Left(rL,iQp - 1) nrL = Len(rL) - iQp rrL = Right(rL,nrL + 1) rL = lrL & hColor & rrL & fColor End If End If End If If sHeadders <> "" And rL = "" Then Else wL = sHeadders & " " & Replace(rL,vbTab,vbSp) & " " rFile.WriteLine wL sHeadders = "" End If Loop rFile.WriteLine sUnders WScript.Sleep 200 sFile.Close rFile.Close TextViewer tTV If tTV = "NotSetting" Then MsgBox "Converted",vbYesNo,"Script to HTML Converter" Else WSHShell.Run tTV & vbWq & sF & vbWq, 1 Wscript.Sleep 1000 End If End If End If End If Next Set Parameters = Nothing Set Fs = Nothing Set WSHShell = Nothing Wscript.Quit Function TextViewer(ResultKey) Dim sTV Const RegKey = "HKCR\txtfile\shell\open\command\" sTV = WSHShell.RegRead(RegKey) sTV = Replace(sTV, " " & vbWq & "%1" & vbWq, "") If Fs.FileExists(sTV) Then ResultKey = sTv & " " Else ResultKey = "NotSetting" End If End Function Public Function iDT(dSplitter,dtSeparater,tSplitter,Control) Dim nX, nD, nS, strHMS, sResult nX = Now() nD = FormatDateTime(Date(),0) nS = ":" & Split(CStr(FormatDateTime(nX,3)),":")(2) strHMS = FormatDateTime(nX,4) & nS If tSplitter = ":" Then Else strHMS = Replace(strHMS,":",tSplitter) End If sResult = Cstr(Replace(nD,"/",dSplitter)) & "*" & strHMS If Control = 1 Then iDT = Split(sResult,"*") Else iDT = Replace(sResult,"*",dtSeparater) End If End Function
|