その他

VBScriptでファイル・フォルダ操作でエラーになってもエラー解決するまでループ(繰り返し)するコード[No59]

投稿日:2020年8月25日 更新日:

スポンサーリンク

vbsプログラムでファイル操作・フォルダ操作をすると、エラーになることがあります。Windowsの場合、ファイル名・フォルダ名に「\ / : ? " < > |」を使うと『ファイル名には次の文字は使えません』とエラーになります。また、予約語を使うと『指定されたデバイス名は無効です』と、「.(ドット、ピリオド)だけだと「パラメーターが間違っています。』とエラーになります。

この記事では、フォルダの作成時に「フォルダ名に使えない文字」でエラーを発生しても、エラーが発生しなくなる(解消する)まで、新しいフォルダ名の入力画面をループする処理を紹介します。

プログラムも2種類用意しています。

プログラム1

準備

新しいフォルダに「createFolder01.vbs」(以下コード)と「text.html」(必ずエラーが発生する文字をファイル内に記載)を作成。

処理内容

フォルダ作成時、エラーが発生すると再処理を促される。フォルダ作成時に同じフォルダが存在する場合は処理を終了する。

「createFolder01.vbs」の「'Dim folderName :folderName = curDir & "\" & record」のコメントアウトを外すなどすると、「text.html」の中の文字を読み込んでその名前をフォルダ名に使えるようになります。


投稿 < ABC?

Option Explicit

'*********************************************************
'用途:カレントディレクトリのパスを取得する
'*********************************************************
Function GetCurDir()
	Dim ObjFSO : Set ObjFSO = WScript.CreateObject("Scripting.FileSystemObject")
	GetCurDir               = ObjFSO.getParentFolderName(WScript.ScriptFullName)
End Function

'*********************************************************
'用途:ファイルを読み込み(テキスト、UTF-8、全行)、値を返す
'引数:filePath(読み込みするファイルの場所)
'戻り値:読み込みをした文字列
'*********************************************************
Function ReadFile_ADODBStream(ByVal filePath)
	Dim inStream : Set inStream = CreateObject("ADODB.Stream")
	With inStream
		.charset = "UTF-8"
		.type = 2
		.open
		.LoadFromFile filePath
	End With

	Dim tempString : tempString = inStream.ReadText(-1) 'adReadAll

	inStream.Close : Set inStream = Nothing
	ReadFile_ADODBStream = tempString
End Function

'*********************************************************
'用途:フォルダを作成する(存在チェックでなければ)
'引数:folderPath(作成するフォルダの場所)
'*********************************************************
Sub CreateFolder(ByVal folderPath)
	Dim ObjFSO : Set ObjFSO = WScript.CreateObject("Scripting.FileSystemObject")
	
	If ObjFSO.FolderExists(folderPath) = True Then
		Dim strText : strText = "フォルダ「" & folderPath & "」は既にあります。削除してから実行して下さい"
		WScript.Echo strText
		WScript.Quit
	Else
		ObjFSO.CreateFolder(folderPath)
		If Err.Number = 0 Then
		End If
	End If
	
	Set ObjFSO = Nothing
End Sub

'*********************************************************
'------------------------------------------------------------------------
'カレントディレクトリのパスを取得する
'------------------------------------------------------------------------
Dim CurDir : CurDir = GetCurDir()
'------------------------------------------------------------------------
'htmlファイルを読み込む
'------------------------------------------------------------------------
Dim inputFilePath : inputFilePath = curDir & "\" & "text.html"
Dim record : record = ReadFile_ADODBStream(inputFilePath)

Dim folderName :folderName = curDir & "\" & "投稿 > ABC?"
'Dim folderName :folderName = curDir & "\" & record
Dim cancelFlg

MsgBox "【" & folderName & "】"

On Error Resume Next
CreateFolder(curDir & "\" & folderName)
If Err.Number <> 0 Then
	Dim errFlg : errFlg = true
	cancelFlg = false
	Dim strText
	
	'Whileは条件が真の間だけループする
	Do While errFlg = true
		strText = ""
		strText = strText & "<入力文字>"						& Chr(13) & Chr(10)
		strText = strText & "---------------------------------" & Chr(13) & Chr(10)
		strText = strText & "【" & folderName & "】"			& Chr(13) & Chr(10)
		strText = strText & "---------------------------------" & Chr(13) & Chr(10) & Chr(13) & Chr(10)
		strText = strText & "<案内>"							& Chr(13) & Chr(10)
		strText = strText & "---------------------------------" & Chr(13) & Chr(10)
		strText = strText & "エラーになりました。考えられる原因は「入力文字の文字コードに問題がある」か「予約語が入力されている」、「未入力」です。正しくなるよう入力してください。" & Chr(13) & Chr(10)
		strText = strText & "---------------------------------" & Chr(13) & Chr(10) & Chr(13) & Chr(10)
		strText = strText & "<Err詳細>"						& Chr(13) & Chr(10)
		strText = strText & "---------------------------------" & Chr(13) & Chr(10)
		strText = strText & "Number:" 		& Err.Number 		& Chr(13) & Chr(10)
		strText = strText & "Source:" 		& Err.Source 		& Chr(13) & Chr(10)
		strText = strText & "Description:" 	& Err.Description 	& Chr(13) & Chr(10)
		strText = strText & "Helpfile:" 	& Err.Helpfile 		& Chr(13) & Chr(10)
		strText = strText & "HelpContext:" 	& Err.HelpContext 	& Chr(13) & Chr(10)
		strText = strText & "LastDllError:" & Err.LastDllError	& Chr(13) & Chr(10)
		strText = strText & "---------------------------------"
		Err.Clear
		
		folderName = inputbox(strText)
		
		If IsEmpty(folderName) = true Then
			MsgBox "キャンセルが選択されました"
			cancelFlg = True
			errFlg = false
		ElseIF folderName = "" Then
			MsgBox "未入力です。"
		Else
   			CreateFolder(curDir & "\" & folderName)
   			errFlg = false
   			If Err.Number <> 0 Then
				errFlg = True
   			End If
		End If
   	Loop
End If
On Error Goto 0

If cancelFlg = True Then
	MsgBox "キャンセルを選択した場合の処理"
End If

スポンサーリンク

プログラム2

準備

新しいフォルダに「createFolder02.vbs」(以下コード)と「text.html」(必ずエラーが発生する文字をファイル内に記載)を作成。

処理内容

フォルダの存在チェックを行い、ない場合にフォルダ作成を行う。存在チェックであるとなった場合は、再処理を促す。

「createFolder02.vbs」の「'Dim folderName :folderName = curDir & "\" & record」のコメントアウトを外すなどすると、「text.html」の中の文字を読み込んでその名前をフォルダ名に使えるようになります。


Option Explicit

'************************************************************************
'用途:カレントディレクトリのパスを取得する
'************************************************************************
Function GetCurDir()
	Dim ObjFSO : Set ObjFSO = WScript.CreateObject("Scripting.FileSystemObject")
	GetCurDir               = ObjFSO.getParentFolderName(WScript.ScriptFullName)
End Function

'************************************************************************
'用途:ファイルを読み込み(テキスト、UTF-8、全行)、値を返す
'引数:filePath(読み込みするファイルの場所)
'戻り値:読み込みをした文字列
'************************************************************************
Function ReadFile_ADODBStream(ByVal filePath)
	Dim inStream : Set inStream = CreateObject("ADODB.Stream")
	With inStream
		.charset = "UTF-8"
		.type = 2
		.open
		.LoadFromFile filePath
	End With

	Dim tempString : tempString = inStream.ReadText(-1) 'adReadAll

	inStream.Close : Set inStream = Nothing
	ReadFile_ADODBStream = tempString
End Function

'************************************************************************
'用途:フォルダを作成する(存在チェックでなければ)
'引数:folderPath(作成するフォルダの場所)
'************************************************************************
Sub CreateFolder(ByVal folderPath)
	Dim ObjFSO : Set ObjFSO = WScript.CreateObject("Scripting.FileSystemObject")
	ObjFSO.CreateFolder(folderPath)	
	Set ObjFSO = Nothing
End Sub

'************************************************************************
'用途:フォルダの存在チェック
'引数:folderPath(作成するフォルダの場所)
'************************************************************************
Function CheckExistsFolder(ByVal folderPath)
	Dim ObjFSO : Set ObjFSO = WScript.CreateObject("Scripting.FileSystemObject")
	
	If ObjFSO.FolderExists(folderPath) = True Then
		Set ObjFSO = Nothing
		CheckExistsFolder = True
	Else
		CheckExistsFolder = False
	End If
End Function

'************************************************************************
'------------------------------------------------------------------------
'カレントディレクトリのパスを取得する
'------------------------------------------------------------------------
Dim CurDir : CurDir = GetCurDir()
'------------------------------------------------------------------------
'htmlファイルを読み込む
'------------------------------------------------------------------------
Dim inputFilePath : inputFilePath = curDir & "\" & "text.html"
Dim record : record = ReadFile_ADODBStream(inputFilePath)

Dim folderName :folderName = curDir & "\" & "投稿 > ABC?"
'Dim folderName :folderName = curDir & "\" & record
Dim cancelFlg

MsgBox "【" & folderName & "】"

On Error Resume Next
Dim existsCheckFolderFlg
existsCheckFolderFlg = CheckExistsFolder(curDir & "\" & folderName)
IF existsCheckFolderFlg = False Then
	CreateFolder(folderName)
End If
If (Err.Number <> 0) OR (existsCheckFolderFlg = True) Then
	Dim errFlg : errFlg = true
	cancelFlg = false
	Dim strText
	
	'Whileは条件が真の間だけループする
	Do While errFlg = true
		strText = ""
		strText = strText & "<入力文字>"						& Chr(13) & Chr(10)
		strText = strText & "---------------------------------" & Chr(13) & Chr(10)
		strText = strText & "【" & folderName & "】"			& Chr(13) & Chr(10)
		strText = strText & "---------------------------------" & Chr(13) & Chr(10) & Chr(13) & Chr(10)
		strText = strText & "<案内>"							& Chr(13) & Chr(10)
		strText = strText & "---------------------------------" & Chr(13) & Chr(10)
		strText = strText & "エラーになりました。考えられる原因は「入力文字の文字コードに問題がある」か「予約語が入力されている」、「未入力」、「既に同名のフォルダがある」です。正しくなるよう入力してください。" & Chr(13) & Chr(10)
		strText = strText & "---------------------------------" & Chr(13) & Chr(10) & Chr(13) & Chr(10)
		strText = strText & "<Err詳細>"						& Chr(13) & Chr(10)
		strText = strText & "---------------------------------" & Chr(13) & Chr(10)
		strText = strText & "Number:" 		& Err.Number 		& Chr(13) & Chr(10)
		strText = strText & "Source:" 		& Err.Source 		& Chr(13) & Chr(10)
		strText = strText & "Description:" 	& Err.Description 	& Chr(13) & Chr(10)
		strText = strText & "Helpfile:" 	& Err.Helpfile 		& Chr(13) & Chr(10)
		strText = strText & "HelpContext:" 	& Err.HelpContext 	& Chr(13) & Chr(10)
		strText = strText & "LastDllError:" & Err.LastDllError	& Chr(13) & Chr(10)
		strText = strText & "---------------------------------"
		Err.Clear
		
		folderName = inputbox(strText)
		
		If IsEmpty(folderName) = true Then '「folderName = ""」は未入力。
			MsgBox "キャンセルが選択されました"
			cancelFlg = True
			errFlg = false
		ElseIf folderName = "" Then
			MsgBox "未入力です。"
		Else
			existsCheckFolderFlg = CheckExistsFolder(curDir & "\" & folderName)
			IF existsCheckFolderFlg = True Then
				MsgBox "既にフォルダが存在しています。"
			ElseIf existsCheckFolderFlg = False Then
   				CreateFolder(curDir & "\" & folderName)
   			End If
   			errFlg = false
   			If (Err.Number <> 0) OR (existsCheckFolderFlg = True) Then
				errFlg = True
   			End If
		End If
   	Loop
End If
On Error Goto 0

If cancelFlg = True Then
	MsgBox "キャンセルを選択した場合の処理"
End If

最後までお付き合いいただきありがとうございます!

この情報が誰かの役にたてれば幸いです。

スポンサーリンク

タグ

-その他

© 2021 BookALittle