人生のプチ美学を教えてください!!

VBScriptのプログラムについて、
度々の内容ですみません。
解決していませんので、質問させてください。

・vbsファイルにテキストファイルをドラッグする
・InputBoxに任意の文字列を入力する
・変換しますか?と問われるため、
「はい」を押したらTextStreamオブジェクトを1行ごとに読み込む
・見つかった文字列を置換し、その文字列が含まれた全ての行を
別名のテキストファイルに抽出する

例:(ファイルA)
asdfghjk.vbs
1:あいうえお
2:かきくけこ
3:あいうえお

⇒ (ファイルB)
asdfghjk_20151217.vbs
1:をふうえお
2:をふうえお

・「いいえ」を押したら変換しないで別名のテキストファイルに
見つかった文字列が含む行をそのまま抽出する
・見つからなかった場合、何もしない
(別名のテキストファイルを作成しない)

<プラグラム>
Option Explicit

'引数の取得
Function GetArg()

Dim objParm

GetArg = ""
Set objParm = Wscript.Arguments

If objParm.Count = 0 Then
WScript.Echo "引数が指定されていません。"
ElseIf objParm.Count >= 2 Then
WScript.Echo "2つ以上のファイルが指定されています。"
Else
GetArg = objParm(0)
End If

End Function

'文字列入力
Function Search(Msg)

Search = InputBox(Msg, "整形処理")

If IsEmpty(Search) Then
MsgBox ("キャンセルされました。")
Search = ""
ElseIf Search = "" Then
MsgBox "文字列が入力されていません。" & vbCr _
& "入力し直してください。", vbOKOnly, "Error"
Search = ""
ElseIf Search = " " or Search = " " Then
MsgBox "空白が入力されています。" & vbCr _
& "入力し直してください。", vbOKOnly, "Error"
Search = ""
End If

End Function

'メイン処理
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Dim strFile, strSearch, strChange, strMsgBox
Dim objFSO, strText, objRead, objWrite, strNewText
Dim lonDate, strWork, strBuffer

strFile = GetArg()

If strFile = "" Then
WScript.Quit
End If

Set objFSO = CreateObject("Scripting.FileSystemObject")

If LCase(objFSO.GetExtensionName(strFile)) <> "txt" Then
MsgBox "テキストファイル以外が指定されています。" & vbCr _
& "指定し直してください。", vbExclamation, "Error"
WScript.Quit
End If

strSearch = Search("抽出したい文字列を入力してください。")
If strSearch = "" Then
WScript.Quit
End If

strMsgBox = MsgBox("『" & strSearch & "』" & "を抽出します。" & vbCr _
& "変換しますか?", vbYesNo + vbQuestion, "確認")

If strMsgBox <> vbYes Then
MsgBox ("変換をスキップします。")
Else
strChange = Search("どの文字列に変換しますか?")
End If

lonDate = "_" & Year(Now()) & right( "00" & Month(Now()),2) & right( "00" & Day(Now()),2)
Set objRead = objFSO.OpenTextFile(strFile, 1)
strBuffer = ""

Do Until objRead.AtEndOfStream = True
strText = objRead.ReadLine
If InStr(1, strText, strSearch, vbTextCompare) > 0 Then
If strMsgBox <> vbNo Then
strWork = Replace(strText, strSearch, strChange, vbTextCompare)
strBuffer = strBuffer & strWork & vbCrLf
End If
End If
Loop

objRead.Close
Set objRead = Nothing

If strBuffer <> "" Then
If strMsgBox = vbNo Then
strNewText = objFSO.BuildPath( _
objFSO.GetParentFolderName(strFile), _
objFSO.GetBaseName(strFile) & _
lonDate & "." & objFSO.GetExtensionName(strFile))
Set objWrite = objFSO.OpenTextFile(strNewText, 2, True)
objWrite.Close
Else
strNewText = objFSO.BuildPath( _
objFSO.GetParentFolderName(strFile), _
objFSO.GetBaseName(strFile) & _
lonDate & "." & objFSO.GetExtensionName(strFile))
Set objWrite = objFSO.OpenTextFile(strNewText, 2, True)
objWrite.Write(strBuffer)
objWrite.Close
End If
Else
MsgBox "『" & strSearch & "』" & "が見つかりませんでした。"
WScript.Quit
End If

Set objWrite = Nothing
Set objFSO = Nothing

WScript.Sleep 1000
MsgBox ("文字列の抽出が完了しました。")

現状の動作として、抽出したい文字列を入力した後に
変換しますか?の問いで「いいえ」を押すと、
見つかりませんでした、という結果を返してしまいます。
※実際はテキストファイルにその文字列は存在しています。

「いいえ」を押すと、変換をスキップして以降の処理を行いたいのですが、
どのように記述すればよろしいでしょうか?

A 回答 (2件)

スキップ後の処理を書いてfunctionからexitしては?



test()
function test()
strSearch="テスト文字列"
strMsgBox = MsgBox("『" & strSearch & "』" & "を抽出します。" & vbCr _
& "変換しますか?", vbYesNo + vbQuestion, "確認")
If strMsgBox <> vbYes Then
msgbox "変換をスキップします。・・・変換スキップ処理"
exit function
Else
msgbox "変換を続けます。"
End If
msgbox "その後の処理"
end function
    • good
    • 0
この回答へのお礼

ご丁寧に回答いただき、有難うございます。
今回はfunctionは使いませんでしたが、
カスタマイズでもう少しコードを短くしていきたいと思います。

お礼日時:2015/12/28 16:54

Option Explicit



'引数の取得
Function GetArg()
Dim objParm

GetArg = ""
Set objParm = Wscript.Arguments

If objParm.Count = 0 Then
WScript.Echo "引数が指定されていません。"
ElseIf objParm.Count >= 2 Then
WScript.Echo "2つ以上のファイルが指定されています。"
Else
GetArg = objParm(0)
End If
End Function

'文字列入力
Function Search(Msg)
Search = InputBox(Msg, "整形処理")

If IsEmpty(Search) Then
MsgBox ("キャンセルされました。")
Search = ""
ElseIf Search = "" Then
MsgBox "文字列が入力されていません。" & vbCr _
& "入力し直してください。", vbOKOnly, "Error"
Search = ""
ElseIf Search = " " or Search = " " Then
MsgBox "空白が入力されています。" & vbCr _
& "入力し直してください。", vbOKOnly, "Error"
Search = ""
End If
End Function

'メイン処理
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Dim strFile, strSearch, strChange, strMsgBox
Dim objFSO, strText, objRead, objWrite, strNewText
Dim lonDate, strWork, strBuffer

strFile = GetArg()

If strFile = "" Then
WScript.Quit
End If

Set objFSO = CreateObject("Scripting.FileSystemObject")

If LCase(objFSO.GetExtensionName(strFile)) <> "txt" Then
MsgBox "テキストファイル以外が指定されています。" & vbCr _
& "指定し直してください。", vbExclamation, "Error"
WScript.Quit
End If

strSearch = Search("抽出したい文字列を入力してください。")
If strSearch = "" Then
WScript.Quit
End If

strMsgBox = MsgBox("『" & strSearch & "』" & "を抽出します。" & vbCr _
& "変換しますか?", vbYesNo + vbQuestion, "確認")

If strMsgBox <> vbYes Then
MsgBox ("変換をスキップします。")
Else
strChange = Search("どの文字列に変換しますか?")
End If

Set objRead = objFSO.OpenTextFile(strFile, 1)
strBuffer = ""

Do Until objRead.AtEndOfStream = True
strText = objRead.ReadLine
If InStr(1, strText, strSearch, vbTextCompare) > 0 Then
If strMsgBox <> vbYes Then
strWork = strText
Else
strWork = Replace(strText, strSearch, strChange, vbTextCompare)
End If
strBuffer = strBuffer & strWork & vbCrLf
End If
Loop

objRead.Close
Set objRead = Nothing

If strBuffer <> "" Then
lonDate = "_" & Year(Now()) & right( "00" & Month(Now()),2) & right( "00" & Day(Now()),2)
strNewText = objFSO.BuildPath( _
objFSO.GetParentFolderName(strFile), _
objFSO.GetBaseName(strFile) & _
lonDate & "." & objFSO.GetExtensionName(strFile))
Set objWrite = objFSO.OpenTextFile(strNewText, 2, True)
objWrite.Write(strBuffer)
objWrite.Close
Else
MsgBox "『" & strSearch & "』" & "が見つかりませんでした。"
WScript.Quit
End If

Set objWrite = Nothing
Set objFSO = Nothing

WScript.Sleep 1000
MsgBox ("文字列の抽出が完了しました。")
    • good
    • 0
この回答へのお礼

ご丁寧に回答いただき、有難うございます。
想定の動作になり、こちらの問題は解決することができました。

お礼日時:2015/12/28 16:54

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!