ファイル名の一部のリストをテキストで指定してフォルダからファイルを移動する(VBScript)

movingFiles.vbs

Option Explicit

Private Const LIST_FILE_NAME = "targetList.txt" '移動するファイルのチェック文字リスト
Private Const OUT_FOLDER_NAME = "out"           '移動先フォルダ名

Private Const FILENAME_DELIMITER = "_"  'ファイル名をこの区切り文字で区切った時
Private Const FILENAME_CHECKINDEX = 2   '何番目の要素を対象にチェックするか（1始まりで指定）

Call main

Sub main()
    Dim baseFolderPath
     
    baseFolderPath = selectForder
    If baseFolderPath = "" Then
        Exit Sub
    End If
     
    If moveFiles(baseFolderPath) Then
        Call MsgBox("ファイル移動が完了しました。", vbInformation)
    End If
End Sub
 
Private Function selectForder()
    Dim objShell
    Dim objFolder
     
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(0, "ファイル移動を実施するフォルダを選択してください。", 0)
     
    selectForder = ""
    If Not objFolder Is Nothing Then
        selectForder = objFolder.Items.Item.Path
    End If
     
    Set objShell = Nothing
    Set objFolder = Nothing
End Function
 
Private Function moveFiles(baseFolderPath)
    Dim FSO         'FileSystemObject
    Dim TS          'TextStream
    Dim baseFolder
    Dim tempFile
    Dim outFolderPath
    Dim targetDictionary
     
    Set FSO = CreateObject("Scripting.FileSystemObject")
 
    outFolderPath = baseFolderPath & "\" & OUT_FOLDER_NAME
    If FSO.FolderExists(outFolderPath) Then
        MsgBox "移動先フォルダと同名のフォルダがすでに存在しているため、処理を終了します。" _
            & vbCrLf & outFolderPath
        Set FSO = Nothing
        Exit Function
    End If
      
    On Error Resume Next
    Set TS = FSO.OpenTextFile(baseFolderPath & "\" & LIST_FILE_NAME)
    On Error GoTo 0
    
    If IsEmpty(TS) Then
        MsgBox "指定されたフォルダの対象リストを開けないため、処理を終了します。" _
            & vbCrLf & baseFolderPath & "\" & LIST_FILE_NAME
        Set FSO = Nothing
        Exit Function
    End If
    
    Set targetDictionary = getDictionary(TS)
    
    Call FSO.CreateFolder(outFolderPath)
    
    Set baseFolder = FSO.getFolder(baseFolderPath)
    For Each tempFile In baseFolder.Files
        If isTargetFileName(targetDictionary, FSO.GetBaseName(tempFile.Name)) Then
            Call tempFile.Move(outFolderPath & "\" & tempFile.Name)
        End If
    Next
    
    moveFiles = True
    
    Set FSO = Nothing
    Set TS = Nothing
    Set tempFile = Nothing
    Set baseFolder = Nothing
    Set targetDictionary = Nothing
End Function

Private Function getDictionary(TS)
    Dim tempString
    Dim retDic
    
    Set retDic = CreateObject("Scripting.Dictionary")
    Do Until TS.AtEndOfStream
        tempString = TS.ReadLine
        If Not retDic.Exists(tempString) Then
            Call retDic.Add(CStr(tempString), "")
        End If
    Loop
    
    Set getDictionary = retDic
    Set retDic = Nothing
End Function

Private Function isTargetFileName(targetDictionary, fileBaseName)
    Dim fileNameArray
    Dim tempString
    
    If fileBaseName = LIST_FILE_NAME Then
        isTargetFileName = False
        Exit Function
    End If
    
    fileNameArray = Split(fileBaseName, FILENAME_DELIMITER)

    If UBound(fileNameArray) < FILENAME_CHECKINDEX - 1 Then
        isTargetFileName = False
        Exit Function
    End If
    
    tempString = CStr(fileNameArray(FILENAME_CHECKINDEX - 1))
    
    isTargetFileName = targetDictionary.Exists(tempString)
End Function