Предлагаю создание папки выделить в отдельную процедуру, при этом при вызове указывать её полный путь
Вот пример применения функции, которая при необходимости создаст все папки в указанном пути, даже если папка более высокого уровня пока не существует
Код:
Option Explicit
Dim strRootFolder
Dim objFSO
Dim strSourceFolder
Dim strRelativeDestFolder
Dim intOut
Dim strFolderDate
strRootFolder = "C:\Реестр"
strSourceFolder = "C:\Реестр\реестр"
strRelativeDestFolder = "C:\Реестр\Итог"
strFolderDate = "C:\Реестр" + "\" + CStr(Year(Date)) + Right(CStr(Month(Date) + 100), 2) + Right(CStr(Day(Date) + 100), 2)
Set objFSO = CreateObject("Scripting.FileSystemObject")
intOut = MakeFold(objFSO, strFolderDate)
intOut = MakeFold(objFSO, strSourceFolder)
intOut = MakeFold(objFSO, strRelativeDestFolder)
intOut = MakeFold(objFSO, strRootFolder)
'----------------------------------------------
Function MakeFold(objFSO, strPathFolder)
If objFSO.FolderExists(strPathFolder) Then
MakeFold = 0
Exit Function
End If
Dim arrPath
Dim strPath
Dim iPath
arrPath = Split(strPathFolder, "\")
strPath = ""
MakeFold = 1
On Error Resume Next
For Each iPath In arrPath
strPath = strPath + iPath + "\"
If Not objFSO.FolderExists(strPath) Then
objFSO.CreateFolder strPath
If Err.Number <> 0 Then
MsgBox strPath + vbCrLf + vbCrLf + "Error= " + CStr(Err.Number) + vbCrLf + Err.Description
MakeFold = 1
On Error GoTo 0
Exit Function
End If
MakeFold = 0
End If
Next
On Error GoTo 0
End Function
Функцию можно упростить, если последовательно вызывать её для создания папок в иерархии вложенности. В любом случае, чтобы не путаться, предлагаю использовать указание полных путей.
Код:
Option Explicit
Dim strRootFolder
Dim objFSO
Dim strSourceFolder
Dim strRelativeDestFolder
Dim intOut
Dim strFolderDate
strRootFolder = "C:\Реестр"
strSourceFolder = "C:\Реестр\реестр"
strRelativeDestFolder = "C:\Реестр\Итог"
strFolderDate = "C:\Реестр" + "\" + CStr(Year(Date)) + Right(CStr(Month(Date) + 100), 2) + Right(CStr(Day(Date) + 100), 2)
Set objFSO = CreateObject("Scripting.FileSystemObject")
intOut = MakeFold(objFSO, strRootFolder)
intOut = MakeFold(objFSO, strSourceFolder)
intOut = MakeFold(objFSO, strRelativeDestFolder)
intOut = MakeFold(objFSO, strFolderDate)
'----------------------------------------------
Function MakeFold(objFSO, strPathFolder)
MakeFold = 0
If Not objFSO.FolderExists(strPathFolder) Then
On Error Resume Next
objFSO.CreateFolder strPathFolder
If Err.Number <> 0 Then
MsgBox strPathFolder + vbCrLf + vbCrLf + "Error= " + CStr(Err.Number) + vbCrLf + Err.Description
MakeFold = 1
End If
On Error GoTo 0
End If
End Function
