Переместить файлы в определенные папки на основе 7-го символа имени файла

Question

Я пытаюсь переместить недавно переименованные файлы из папки Temp в папку назначения, основываясь на именах файлов 7-й символ.

Например, 7-й символ каждого имени файла является размером рисунка.Так что я пытаюсь сделать, если 7-й chr имени файла = A, а затем переместить файл в папку "... \ A-SIZE_8.5X11".

* Обратите внимание, что MainDir создается из autocadсценарий при печати PDF.

В настоящее время я получаю сообщение об ошибке If Mid(Dir(s, vbDirectory), x).Value = "A" Then Says Type Mismatch.Любая обратная связь приветствуется.

Sub MoveFiles()
Dim s As String, x As String
Dim LoginName As String, MainDir As String, 
SourceDir As String
Dim destDirA As String, destDirB As String, 
destDirC As String, destDirD As String

LoginName = UCase(GetUserID)
MainDir = "C:\Users\" & LoginName & "\Desktop\PDF\"
SourceDir = MainDir & "_Temp\"
destDirA = MainDir & "A-SIZE_8.5X11"
destDirB = MainDir & "B-SIZE_11X17"
destDirC = MainDir & "C-SIZE_17X22"
destDirD = MainDir & "D-SIZE_24X36"

s = (SourceDir & "\*.pdf?")
x = Mid(s, 7, 1) 'Find letter after S-000-

If Mid(Dir(s, vbDirectory), x).Value = "A" Then
    If Len(Dir(destDirA, vbDirectory)) = 0 Then MkDir destDirA
        Do
        Name SourceDir & s As destDirA & s & "\" & s
    Loop Until s = ""
End If

If Mid(Dir(s, vbDirectory), x).Value = "B" Then
    If Len(Dir(destDirB, vbDirectory)) = 0 Then MkDir destDirB
        Do
        Name SourceDir & s As destDirB & s & "\" & s
    Loop Until s = ""
End If

If Mid(Dir(s, vbDirectory), x).Value = "C" Then
    If Len(Dir(destDirC, vbDirectory)) = 0 Then MkDir destDirC
        Do
        Name SourceDir & s As destDirC & s & "\" & s
    Loop Until s = ""
End If

If Mid(Dir(s, vbDirectory), x).Value = "D" Then
    If Len(Dir(destDirD, vbDirectory)) = 0 Then MkDir destDirD
        Do
        Name SourceDir & s As destDirD & s & "\" & s
    Loop Until s = ""
End If
End Sub

Модифицировано Если операторы так завершают цикл, прежде чем Dir вызывается снова.Нашел часть этого кода в сети и попытался изменить его, чтобы он работал, но я не уверен, как это исправить.

Answer 1

Посмотрите на приведенный ниже пример:

Option Explicit

Sub TestShellApp()

    Dim sSourceFolder As String
    Dim sTargetFolder As String
    Dim sSourcePattern
    Dim sTargetPath As String
    Dim oShellApp
    Dim oSourceFolder
    Dim oSourceFolderItems
    Dim oTargetFolder
    Dim sKey

    sSourceFolder = "C:\Test\Source\"
    sTargetFolder = "C:\Test\Target\"

    Set oShellApp = CreateObject("Shell.Application")
    Set oSourceFolder = oShellApp.Namespace((sSourceFolder))
    Set oSourceFolderItems = oSourceFolder.Items()
    With CreateObject("Scripting.Dictionary")
        .Item("A") = "A-SIZE_8.5X11"
        .Item("B") = "B-SIZE_11X17"
        .Item("C") = "C-SIZE_17X22"
        .Item("D") = "D-SIZE_24X36"
        For Each sKey In .Keys
            sTargetPath = sTargetFolder & .Item(sKey)
            SmartCreateFolder sTargetPath
            Set oTargetFolder = oShellApp.Namespace((sTargetPath))
            For Each sSourcePattern In Array( _
                    "??????" & sKey & "*", _
                    "????????" & sKey & "*" _
                )
                oSourceFolderItems.Filter 32 + 64 + 128, sSourcePattern
                oTargetFolder.MoveHere oSourceFolderItems, 16 + 1024
            Next
        Next
    End With
    MsgBox "Files moved"

End Sub

Sub SmartCreateFolder(sFolder)

    Static oFSO As Object

    If oFSO Is Nothing Then Set oFSO = CreateObject("Scripting.FileSystemObject")
    With oFSO
        If Not .FolderExists(sFolder) Then
            SmartCreateFolder .GetParentFolderName(sFolder)
            .CreateFolder sFolder
        End If
    End With

End Sub