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
|
0 件のコメント:
コメントを投稿
注: コメントを投稿できるのは、このブログのメンバーだけです。