'==============================================================================
' Формирование списка отсутствующих в последовательности элементов
' Вид числовой последовательности определяется по первому элементу списка

' Параметры:
' 1 - Исходный файл-список (обязат.   )
' 2 - Выходный файл-список (не обязат.)
' 3 - Режим:               (не обязат.)
'     0 - вывести на экран - по умолчанию,
'     1 - записать в файл,
'     2 - по недостающим элементам создать папки,
'     3 - по недостающим элементам создать пустые файлы
'==============================================================================
Option Explicit
Dim Dic, FSO, List, l, i, Prefix, Postfix, LenPrefix, LenPostfix
Dim InFile, OutFile, Mode, Str, Value, Position, Digits, Num, Mess
Set Dic = CreateObject("Scripting.Dictionary")
Set FSO = CreateObject("Scripting.FileSystemObject")

'Задаем массив сообщений
MessDefine
'Проверяем параметры
CheckParams
'Читаем исходный список
List = Split(FSO.OpenTextFile(InFile).ReadAll, vbNewLine)
'Ищем в первом элементе число
Value  = Search(List(0), "\d+", Position)
Digits = Len(Value)
'Если первый элемент не содержит цифр, выходим
If Position = 0 Then Quit
'Определяем приставку и окончание
Prefix     = Left(List(0), Position - 1     )
Postfix    = Mid (List(0), Position + Digits)
LenPrefix  = Len (Prefix )
LenPostfix = Len (Postfix)
'Перебираем список
For Each l In List
  'Проверяем на совпадение приставки и окончания
  If (UCase(Left (l, LenPrefix )) = UCase(Prefix )) And _
     (UCase(Right(l, LenPostfix)) = UCase(Postfix)) Then
    'Средняя часть (цифры)
    Num = Mid(l, Position, Len(l) - LenPrefix - LenPostfix)
    'Проверяем среднюю часть на минимальное количество цифр
    If Len(Num) >= Digits And _
       IsNumeric(Num)     Then
      'Добавляем в искомый массив
      Dic.Add CInt(Num), l
    End If
  End If
Next
'Задаем числовую последовательность от минимума до максимума
For i = Min(Dic.Keys) To Max(Dic.Keys)
  'Проверяем наличие элемента с текущим числом
  If Not Dic.Exists(i) Then
    'Формируем среднюю часть с лидирующими нулями
    If Len(i) < Digits Then
      Num = Right(String(Digits, "0") & i, Digits)
    Else
      Num = i
    End If
    'Заполняем строковой массив
    Str = Str & vbNewLine & Prefix & Num & Postfix
  End If
Next
'Убираем лидирующий перенос строки
Str = Mid(Str, Len(vbNewLine) + 1)

'Результаты в зависимости от заданного режима
Select Case Mode
  Case 0  MsgBox Str, vbInformation + vbOKOnly, Mess(0)
  Case 1  FSO.CreateTextFile(OutFile, True).Write Str
  Case 2  CreateFolders Split(Str, vbNewLine)
  Case 3  CreateFiles   Split(Str, vbNewLine)
End Select

'Выход
Quit

'===== Процедуры и функции ====================================================
'Проверка входных параметров
Sub CheckParams
  With WScript
    If .Arguments.Count = 0 Then
      MsgBox Mess(1), vbCritical + vbOKOnly, Mess(0)
      Quit
    End If
    InFile = .Arguments(0)
    If Not FSO.FileExists(InFile) Then
      MsgBox Mess(2), vbCritical + vbOKOnly, Mess(0)
      Quit
    End If
    OutFile = ""
    If .Arguments.Count > 1 Then
      OutFile = .Arguments(1)
    End If
    Mode = 0
    If .Arguments.Count > 2 Then
      Mode = .Arguments(2)
      If IsNumeric(Mode) Then
        Mode = CInt(Mode)
        If (Mode < 0) Or (Mode > 3) Then Mode = 0
      Else
        Mode = 0
      End If
    End If
    If (Mode <> 0) And (OutFile = "") Then
      MsgBox Mess(3), vbCritical + vbOKOnly, Mess(0)
      Quit
    End If
  End With
End Sub

'Описание сообщений
Sub MessDefine
  Set Mess = CreateObject("Scripting.Dictionary")
  With Mess
    .Add 0,  "Отсутствующие элементы списка"
    .Add 1,  "Не указаны параметры!"
    .Add 2,  "Указанный файл-список не существует!"
    .Add 3,  "Для данного режима должен быть указан выходной файл-список!"
  End With
End Sub

'Поиск по маске первого значения в строке
'Функция возвращает значение, третий параметр - позицию
Function Search(pStr, pMask, byRef pPos)
  Dim REx, lMatch, lMatches
  Set REx        = New RegExp
  REx.Pattern    = pMask
  REx.IgnoreCase = True
  REx.Global     = True
  Set lMatches   = REx.Execute(pStr)
  If lMatches.Count > 0 Then Set lMatch = lMatches.Item(0)
  If IsObject(lMatch) Then
    Search = lMatch.Value
    pPos   = lMatch.FirstIndex + 1
  Else
    Search = ""
    pPos   = 0
  End If
End Function

'Создание папок по списку
Sub CreateFolders(pList)
  Dim l
  For Each l In pList
    If Not(FSO.FolderExists(l) And FSO.FileExists(l)) Then
      FSO.CreateFolder l
    End If
  Next
End Sub

'Создание пустых файлов по списку
Sub CreateFiles(pList)
  Dim l
  For Each l In pList
    If Not(FSO.FolderExists(l) And FSO.FileExists(l)) Then
      FSO.CreateTextFile l
    End If
  Next
End Sub

'Поиск максимального значения в массиве
Function Max(pArr)
  Dim lE, lM
  lM = pArr(0)
  For Each lE In pArr
    If lE > lM Then lM = lE
  Next
  Max = lM
End Function

'Поиск минимального значения в массиве
Function Min(pArr)
  Dim lE, lM
  lM = pArr(0)
  For Each lE In pArr
    If lE < lM Then lM = lE
  Next
  Min = lM
End Function

'Выход
Sub Quit
  Set Mess = Nothing
  Set Dic  = Nothing
  Set FSO  = Nothing
  WScript.Quit
End Sub

Строка: 47
Символ: 7
Ошибка: Запись уже связана с элементом данного семейства
Код: 800A01C9
Источник: Ошибка выполнения Microsoft VBScript

pre_10_post.test
pre_011_post.test
pre_13_post.test
pre_015_post.test

pre_10_post.test
pre_11_post.test
pre_011_post.test
pre_13_post.test
pre_015_post.test