-PR-
  • 困ってます
  • 質問No.8672643
解決
済み

【VBS】 テキスト→HTML 自動作成

  • 閲覧数198
  • ありがとう数2
  • 気になる数0
  • 回答数2
  • コメント数0

お礼率 86% (306/354)

お世話になっております。
同じフォルダの中に入っているtxt全てを
自動的にHTML化しようと思っています。

分からないなりに考えて書いたのは下記コードです。
---------------------------------

Dim strScriptPath'自分の現在位置
strScriptPath = Replace(WScript.ScriptFullName,WScript.ScriptName,"")'フルネームから、スクリプトネームを削除!

' フォルダをオブジェクト取得
Set objFso = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFso.GetFolder(strScriptPath)

for each file in objFolder.Files
Set fileRead = objFSO.OpenTextFile(file)'ファイルを開く
If file.name<> WScript.ScriptName Then
'Msgbox objFso.GetBaseName(file)ファイル名
Msgbox objFso.GetBaseName(file)
Set HTMLOutPutData = objFso.CreateTextFile(objFso.GetBaseName(file) & ".html",True)
'If InStr(l, "本社") = 0 含んでない場合
'Replace(文字列,どれを、どれに)
'<font color="green">文字列</font>緑色に

If Err.Number = 0 Then
HTMLOutPutData.WriteLine "<html>"
HTMLOutPutData.WriteLine "<head>"
HTMLOutPutData.WriteLine "<title></title>"
HTMLOutPutData.WriteLine "</head>"
HTMLOutPutData.WriteLine "<body>"

HTMLOutPutData.WriteLine "<h1 align=""" &"center" &""">"& objFso.GetBaseName(file) & "</h1>"
HTMLOutPutData.WriteLine "<hr>"

Do Until fileRead.AtEndOfLine = true
LINEDATA = fileRead.ReadLine
If InStr(LINEDATA,"'") = 0 then'含んでない場合
HTMLOutPutData.WriteLine "<font color=""" &"black"&""">" & LINEDATA & "</font><br>"
Else
HTMLOutPutData.WriteLine Replace(LINEDATA,"'","<font color=""" &"green"&""">") & "</font><br>"

End if

Loop
HTMLOutPutData.WriteLine "</body>"
HTMLOutPutData.WriteLine "</html>"
fileRead.Close
Else
MsgBox "ファイルが開けません"
End If
End if
Next

Msgbox "終わり!"

-------------------------------------------

とりあえず、'の後全ては緑色に変更。
1行読み込み、1行ずつ改行。
元のファイル名と同じで、拡張子を.htmlにして保存。

これを目標にやっていましたが、
全ファイル思ったとおりに行くわけではなく
エラーの連続です。
プログラムが悪いのでしょうか?
1個目のファイルはどんどん重くなり、
300Kくらいのサイズになります。(他のファイルは2K程度です)
それを削除しようとすると、どんどんパソコンが重くなり…

どこかのループが悪さしているのでしょうか?
通報する
  • 回答数2

質問者が選んだベストアンサー

  • 回答No.1
レベル14

ベストアンサー率 91% (1611/1754)

「いつ,どんなときにそうなる(ファイルはどんどん重くなる)のか?」

この条件を探すのに少々手間取りましたが,
その VBS ファイルが存在するフォルダ内に
元から HTML ファイル(実際は拡張子 .html のファイル)が存在したときに
そうなるようですよ。

当たり前と言えば当たり前ですが,
VBS ファイルが存在するフォルダ内に
最初から拡張子 .html のファイルがあった場合,
「そのHTMLファイルを開いてはタグを付け加えて同じ名前で保存する。」
この作業を延々と繰り返すわけですから
巨大ファイルができてしまいます。
(できるというよりも,作ろうとして強制終了させない限り PC が重くなる。)



結局,制限のかけ方が間違っているのだと思います。
現時点では

If file.name <> WScript.ScriptName Then

という制限を付けて
VBS ファイル(つまり自分自身)以外のであれば
どんなファイルにでもタグを付けて行って HTML として保存させようとしています。


そうではなくて
同じ部分を

If Right(file.name,4) = ".txt" Then

のように変更して
拡張子 .txt のファイルに対してのみ
プログラムを実行させるとか,
せめて

If file.name <> WScript.ScriptName And Right(file.name,5) <> ".html" Then

のように変更して
自分自身以外と,拡張子 .html 以外のファイルに対して
プログラムを実行させるとかに変更する必要があると思います。

そうしないと
メモリ や CPU どころか
ドライブの全容量食いつくし現象が起きて
ハード自体も危ないことになるかもしれませんよ。
補足コメント
satoron666

お礼率 86% (306/354)

色々考えた結果、
.htmlがあった場合は削除する方法にしました。
無事、上手く動き始めた…気はしますが
まだまだ問題は山積みみたいです^^;
ありがとうございました^^
投稿日時 - 2014-07-14 09:59:10
お礼コメント
satoron666

お礼率 86% (306/354)

回答ありがとうございます。
>その VBS ファイルが存在するフォルダ内に
>元から HTML ファイル(実際は拡張子 .html のファイル)が
>存在したときにそうなるようですよ。
そうだったんですね!

色々調べてくださりありがとうございます!
If file.name <> WScript.ScriptName And Right(file.name,5) <> ".html" Then
この、拡張子がHTMLかどうか判別する方法を使わせて
頂きたいと思います。

ありがとうございました^^
投稿日時 - 2014-07-14 09:11:58
-PR-
-PR-

その他の回答 (全1件)

  • 回答No.2
レベル13

ベストアンサー率 59% (573/964)

回答ではありません。そもそもVBSじゃありませんし。話の種程度にご覧下さい。 今時<FONT>タグなんて使っていいのか(HTML5では廃止される)とか、HTMLエスケープしないで大丈夫とか思って試している内に、昔VBAコードのコメント行に色をつけたHTMLコードを生成してくれるアドインがあったのを思い出して、自分で作ってみてやろうと思ったのが泥沼にはまるきっかけでした... ・FileSyst ...続きを読む
回答ではありません。そもそもVBSじゃありませんし。話の種程度にご覧下さい。
今時<FONT>タグなんて使っていいのか(HTML5では廃止される)とか、HTMLエスケープしないで大丈夫とか思って試している内に、昔VBAコードのコメント行に色をつけたHTMLコードを生成してくれるアドインがあったのを思い出して、自分で作ってみてやろうと思ったのが泥沼にはまるきっかけでした...
・FileSystemObjectのOpenTextFileだと、エクスポートしたVBAコードのファイル読み込みを途中で打ち切ってしまう。
・CreateTextNodeのHTMLエスケープ機能が不十分(&と<>しかエスケープしない。やるなら徹底してやってくれよ...)
・IE9で動いたコードがIE8では動かない(Style sheetを動的に生成する際のIE8のバグ?方言?らしい)
おまけに同じWindows7Home(64bit)で動いていたRegExの置換のコードが、家のDesktopPCではOKで、NotePCだと実行時エラー
と、盛りだくさんでした。
なお、VBAコードのエクスポートをVBAで制御するには、xl2003以降のバージョンは、[Visual Basic プロジェクトへのアクセスを信頼する] チェック ボックスをオンにする必要があります。在処はバージョンにより異なります。

Win7Home(64bit)、xl2010(32bit)、IE8で動いたコードです。

Sub displayCode()
Dim objIE As Object, doc As Object
Dim myheader As Object, mybody As Object
Dim cssElement As Object, pElement As Object, emElement As Object
Dim objFSO As Object, fileRead As Object, fileWrite As Object
Dim lineData As String, buf As String
Dim outputFilePath As String

Set objIE = CreateObject("InternetExplorer.Application")
objIE.Visible = True
'お約束
objIE.navigate "about:blank"
Set doc = objIE.document
'WebPageの基本形を与える
doc.Write "<html><head></head><body></body></html>"

Set myheader = doc.getElementsByTagName("head")(0)
Set mybody = doc.getElementsByTagName("body")(0)
'CSSの設定
'emはデフォルトで斜体になる様です。
Set cssElement = doc.createElement("style")
cssElement.Type = "text/css"
'IE8
cssElement.styleSheet.cssText = "em.comment{color:green;}"
'IE9
'cssElement.innerText = "em.comment{color:green;}"
myheader.appendchild cssElement

'htmlエスケープが必要と思ったが、createTextNodeの中途半端な仕様の所為で思わぬ苦労をした
'createTextNodeは「&<>」のみescape
'これはTextNodeのオブジェクトを操作しても同様
'なお、s/w-quatationはIEのDOMで内部的に自動で変換している様に思える
Set pElement = doc.createElement("p")
Set objFSO = CreateObject("Scripting.FileSystemObject")
'なぜかobjFSO.OpenTextFileだと2行位読み込んで打ち切ってしまう
Set fileRead = objFSO.GetFile(GetDesktopPath & "\Module1.bas").OpenAsTextStream
outputFilePath = GetDesktopPath & "\Module1.html"

Do Until fileRead.AtEndOfStream
lineData = fileRead.ReadLine
If Left(Trim(lineData), 1) <> "'" Then
buf = Replace(lineData, vbTab, " ")
pElement.appendchild (doc.createTextnode(buf))
pElement.appendchild (doc.createElement("br"))
'コメントの時
Else
Set emElement = doc.createElement("em")
emElement.className = "comment"
buf = Replace(lineData, vbTab, " ")
emElement.appendchild (doc.createTextnode(buf))
pElement.appendchild emElement
pElement.appendchild (doc.createElement("br"))
End If
Loop
fileRead.Close
pElement.innerHTML = htmlEscape(pElement.innerHTML)
'bodyにpタグとして書き出す
mybody.appendchild pElement

Set fileWrite = objFSO.CreateTextFile( _
Filename:=outputFilePath, Overwrite:=True)
fileWrite.Write doc.getElementsByTagName("html")(0).outerHTML
fileWrite.Close

Set objFSO = Nothing
End Sub

Function htmlEscape(srcString As String) As String
Dim regEx As Variant, Matches As Variant, match As Variant
Dim buf As String

buf = srcString
Set regEx = CreateObject("VBScript.RegExp")
regEx.MultiLine = True
'> <で囲まれた部分のみ抽出して、その中のスペースを置換した文字列で更に置換する
regEx.Pattern = ">.*?<"
regEx.IgnoreCase = True
regEx.Global = True
Set Matches = regEx.Execute(buf)
For Each match In Matches
buf = Replace(buf, CStr(match), Replace(CStr(match), " ", "&nbsp;"))
Next match
Set Matches = Nothing
Set regEx = Nothing
htmlEscape = buf
End Function

実装してないですがModuleのエクスポート
'http://okwave.jp/qa/q5167092.html
Sub CodeExport()
Dim A, B
Set A = ThisWorkbook.VBProject.VBComponents
For Each B In A
If B.Type = 1 Then B.Export GetDesktopPath & "\" & B.Name & ".bas"
Next
End Sub

Private Function GetDesktopPath() As String
Dim wScriptHost As Object, strInitDir As String
Set wScriptHost = CreateObject("Wscript.Shell")
GetDesktopPath = wScriptHost.SpecialFolders("Desktop")
Set wScriptHost = Nothing
End Function
補足コメント
satoron666

お礼率 86% (306/354)

色々考えた結果、
.htmlがあった場合は削除する方法にしました。
無事、上手く動き始めた…気はしますが
まだまだ問題は山積みみたいです^^;
ありがとうございました^^
投稿日時 - 2014-07-14 09:59:18
お礼コメント
satoron666

お礼率 86% (306/354)

回答ありがとうございます。
VBAとVBS、プログラムの流れ?は同じですものね!
参考になります^^
試してみます! ありがとうございました!
投稿日時 - 2014-07-14 09:58:24
  • 回答数2
このQ&Aで解決しましたか?
関連するQ&A
-PR-
-PR-
こんな書き方もあるよ!この情報は知ってる?あなたの知識を教えて!
このQ&Aにはまだコメントがありません。
あなたの思ったこと、知っていることをここにコメントしてみましょう。

その他の関連するQ&A、テーマをキーワードで探す

キーワードでQ&A、テーマを検索する
-PR-
-PR-
-PR-

特集


関連するQ&A

-PR-

ピックアップ

-PR-
ページ先頭へ