VBScript用于像文件一样移动 [英] VBScript for moving like files

问题描述

一旦有4个相似的文件，我需要一个脚本来移动具有相似名称的文件.

I need a script to be able to move files with like names once there are 4 like files.

示例:

Cust-12345.txt
Addr-12345.txt
Ship-12345.txt
Price-12345.txt

文件将始终以名称开头，-"后的数字将始终不同.我需要能够搜索一个文件夹，当所有4个文件都存在时，将它们移到完整的文件夹中.

The files will always start with those for names, the numbers after the "-" will always be different. I need to be able to search a folder and when all 4 files are there move them into a completed folder.

option explicit

dim objFS : dim strShareDirectory : dim strDumpStorageDir : dim objFolder : dim colFiles     :   dim re : dim objFile

dim dictResults ' dictionary of [filename] -> [matching substring]
dim dictResultsCount ' dictionary of [matching substring] -> [count]
dim dictResultsFinal ' only the valid entries from dictResults
dim keyItem 
dim strMatch

dim message

message = "Yes"

set dictResultsFinal = CreateObject("Scripting.Dictionary")
set dictResults = CreateObject("Scripting.Dictionary")
set dictResultsCount = CreateObject("Scripting.Dictionary")

Set objFS = CreateObject("Scripting.FileSystemObject")

strShareDirectory = "c:\Test"
strDumpStorageDir = "c\Test\Out"

Set objFolder = objFS.GetFolder(strShareDirectory)
Set colFiles = objFolder.Files

Set re = New RegExp
re.Global     = True
re.IgnoreCase = False
re.Pattern    = "-\d"

Dim curFile, matchValue
Dim i: i = 0

For Each objFile in colFiles
' test if the filename matches the pattern
if re.test(objFile.Name) then
    ' for now, collect all matches without further checks
    strMatch = re.execute(objFile.Name)(0)
    dictResults(objFile.Name) = strMatch
    ' and count
    if not dictResultsCount.Exists(strMatch) then
        dictResultsCount(strMatch) = 1
    else
        dictResultsCount(strMatch) = dictResultsCount(strMatch) +1
    end if
end if
next

' for testing: output all filenames that match the pattern
msgbox join(dictResults.keys(), vblf)

' now copy only the valid entries into a new dictionary
for each keyItem in dictResults.keys()
if dictResultsCount.Exists( dictResults(keyItem) ) then
    if dictResultsCount( dictResults(keyItem) ) = 4 then


      dictResultsFinal(keyItem) = 1
    end if
end if
next

推荐答案

在这里，我有一个涉及使用数组的答案，但是考虑一下，我什至不认为您甚至不需要数组.只需迭代每个文件并检查其他文件是否存在.

I had an answer here that involved using an array but, come to think of it, I don't think you even need an array. Just iterate each file and check for the existence of the others.

Set re = New RegExp
re.Global = True
re.IgnoreCase = True
re.Pattern = "\\(Cust|Addr|Ship|Price)-(\d+)\.txt"

For Each File In objFS.GetFolder(strShareDirectory).Files

    ' Test to make sure the file matches our pattern...
    If re.Test(File.Path) Then

        ' It's a match. Get the number...
        strNumber = re.Execute(File.Path)(0).SubMatches(1)

        ' If all four exist, move them...
        If AllFourExist(strNumber) Then
            For Each strPrefix In Array("Cust-", "Addr-", "Ship-", "Price-")
                objFS.MoveFile strShareDirectory & "\" & strPrefix & strNumber & ".txt", _
                               strDumpStorageDir & "\" & strPrefix & strNumber & ".txt"
            Next
        End If

    End If

Next

这是AllFourExist函数(我假设objFS是全局的):

And here's the AllFourExist function (I'm assuming objFS is global):

Function AllFourExist(strNumber)
    For Each strPrefix In Array("Cust-", "Addr-", "Ship-", "Price-")    
        If Not objFS.FileExists(strShareDirectory & "\" & strPrefix & strNumber & ".txt") Then Exit Function
    Next
    AllFourExist = True
End Function

我不确定FSO如何处理您将文件从当前正在迭代的文件夹中移出的事实.如果它抱怨，您可能最终需要诉诸数组.注意事项.

I'm not sure how the FSO will handle the fact that you're moving files out of a folder that you're currently iterating. If it complains, you may need to resort to an array after all. Something to keep in mind.

这篇关于VBScript用于像文件一样移动的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！