Создание папки в определенном каталоге

[jordan_74]

Всем добрый вечер! Нужна ваша помощь, о просветленные программисты)
Есть скрипт на vbs. В нем автоматически создается папка Архив. В этот архив должны складываться папки с текущей датой в имени(этого я добился)
Вопрос, как эту самую(е) папки создавать в папке Архив? Почему то создается в корне C:\Реестр\

Привожу кусок кода

Dim s,d,m,y
Dim strArciveFolder

strArciveFolder = "C:\Реестр\Архив"


'Создание папки Архив:
Set objFSO = WScript.CreateObject("Scripting.FileSystemObject")
If Not objFSO.FolderExists(strArciveFolder) Then
objFSO.CreateFolder strArciveFolder
End If

' Создание подпапки с системной датой в ее названии в каталоге Архив
Set objFSO = WScript.CreateObject("Scripting.FileSystemObject")

On Error Resume Next

d = day( date() )
m = month(date())
y = year(date())
if d < 10 then
d = "0" & d
end if
if m < 10 then
m = "0" & m
end if

s = y & "_" & m & "_" & d


Set objFSO = CreateObject("Scripting.FileSystemObject")
objFSO.CreateFolder (s)

В перспективе в эту папку с текущей датой в имени будут копироваться архивные файлы.
Буду очень признателен за помощь!

[mwz]

jordan_74, а почему вы определяете objFSO не перед первым использованием, а в конце скрипта?

[jordan_74]

jordan_74, а почему вы определяете objFSO не перед первым использованием, а в конце скрипта? »
Я привел только кусок кода, возможно получилось вырванным из контекста, я только учусь) учту все замечания

[Iska]

Вопрос, как эту самую(е) папки создавать в папке Архив? »
Например, указывать полный путь — если Вы используете создание каталога посредством метода .CreateFolder() класса Scripting.FileSystemObject. Кроме этого метода Вы можете использовать метод .Add() коллекции Folders. И тот, и другой методы возвращают объект типа Folder.

Почему то создается в корне C:\Реестр\ »
Вероятно Ваш скрипт там находится. Оттуда Вы его запускаете, и потому данный каталог является текущим для него:
https://i.imgur.com/dnsTXW3.png

Я бы изобразил нечто подобное:
Option Explicit

Dim strRootFolder
Dim strArchiveFolder

Dim objFSO

Dim objRootFolder
Dim objArchiveFolder
Dim strPath2ArchiveFolder

Dim objSWbemObjectEx

Dim objNowFolder


strRootFolder = "C:\Реестр"
strArchiveFolder = "Архив"

Set objFSO = WScript.CreateObject("Scripting.FileSystemObject")

If objFSO.FolderExists(strRootFolder) Then
Set objRootFolder = objFSO.GetFolder(strRootFolder)

strPath2ArchiveFolder = objFSO.BuildPath(strRootFolder, strArchiveFolder)

If Not objFSO.FolderExists(strPath2ArchiveFolder) Then
Set objArchiveFolder = objRootFolder.SubFolders.Add(strArchiveFolder)
Else
Set objArchiveFolder = objFSO.GetFolder(strPath2ArchiveFolder)
End If

For Each objSWbemObjectEx In WScript.CreateObject("WbemScripting.SWbemLocator").ConnectServer(".", "root\cimv2").ExecQuery("SELECT LocalDateTime FROM Win32_OperatingSystem")
Set objNowFolder = objArchiveFolder.SubFolders.Add(Left(objSWbemObjectEx.LocalDateTime, 8))

Exit For
Next

'...
'...
'...

Set objNowFolder = Nothing
Set objArchiveFolder = Nothing
Set objRootFolder = Nothing
Else
WScript.Echo "Can't find root folder [" & strRootFolder & "]."
WScript.Quit 1
End If

Set objFSO = Nothing

WScript.Quit 0


P.S. И никаких On Error Resume Next без веских причин!

[jordan_74]

Iska,
Попытался встроить данный кусок в код.
Сработало, папка с текущей датой в имени создалась в папке Архив. Но сама папка Архив создалась не в том месте, почему то... она создалась в папке Итог - C:\Реестр\Итог\Архив\20181129, а верный вариант C:\Реестр\Архив\20181129
Просьба подсказать где ошибка..

Option Explicit

Const xlCSV = 6
Const xlWindows = 2

Dim s,d,m,y
Dim Log 'Лог-файл

Dim strSourceFolder ' Папка Реестр

Dim strTemplateFile ' Файл шаблона

Dim strRelativeDestFolder ' Папка "Итог"


Dim strRootFolder ' Папка C:\Реестр
Dim strArchiveFolder ' Папка архив
Dim objRootFolder
Dim objArchiveFolder
Dim strPath2ArchiveFolder

Dim objSWbemObjectEx

Dim objNowFolder

Dim strLogDestFolder 'Папка, в которой будут создаваться лог-файлы

Dim objFSO
Dim objExcel

Dim objFile

Dim objTemplateFile
Dim objSourceFile

Dim i
Dim strDestFile

Dim strLogDestFile

Dim SumSourceFile 'Сумма по реестру
Dim SumDestFile 'Сумма по чекам
Dim SumTotal 'Общая сумма

Dim CountSourceFiles 'Для подсчета файлов реестра
CountSourceFiles = 0

Dim anyValue

'Здесь указать полный адрес папки с файлами реестра:
strSourceFolder = "C:\Реестр\реестр"

strTemplateFile = "C:\Реестр\Шаблон\check.csv"
strRelativeDestFolder = "..\Итог"
strLogDestFolder = "C:\Касса"
strArchiveFolder = "Архив"
strRootFolder = "C:\Реестр"

'If WScript.Arguments.Count = 1 Then
' strSourceFolder = WScript.Arguments.Item(0)

Set objFSO = WScript.CreateObject("Scripting.FileSystemObject")
'Если файл шаблона существует
If objFSO.FileExists(strTemplateFile) Then
' Если папка "реестр" существует
If objFSO.FolderExists(strSourceFolder) Then


strRootFolder = objFSO.GetAbsolutePathName(objFSO.BuildPath(strSourceFolder, strRelativeDestFolder))
If Not objFSO.FolderExists(strRootFolder) Then
objFSO.CreateFolder strRootFolder
End If

'Создание папки Касса:
If Not objFSO.FolderExists(strLogDestFolder) Then
objFSO.CreateFolder strLogDestFolder
End If

'Создание папки Архив:
Set objFSO = WScript.CreateObject("Scripting.FileSystemObject")

If objFSO.FolderExists(strRootFolder) Then
Set objRootFolder = objFSO.GetFolder(strRootFolder)

strPath2ArchiveFolder = objFSO.BuildPath(strRootFolder, strArchiveFolder)

If Not objFSO.FolderExists(strPath2ArchiveFolder) Then
Set objArchiveFolder = objRootFolder.SubFolders.Add(strArchiveFolder)
Else
Set objArchiveFolder = objFSO.GetFolder(strPath2ArchiveFolder)
End If

For Each objSWbemObjectEx In WScript.CreateObject("WbemScripting.SWbemLocator").ConnectServer(".", "root\cimv2").ExecQuery("SELECT LocalDateTime FROM Win32_OperatingSystem")
Set objNowFolder = objArchiveFolder.SubFolders.Add(Left(objSWbemObjectEx.LocalDateTime, 8))

Exit For
Next

Set objNowFolder = Nothing
Set objArchiveFolder = Nothing
Set objRootFolder = Nothing
Else
WScript.Echo "Can't find root folder [" & strRootFolder & "]."
WScript.Quit 3
End If

Set objExcel = Nothing

For Each objFile In objFSO.GetFolder(strSourceFolder).Files

'Подсчет количества файлов реестра:
CountSourceFiles = CountSourceFiles + 1

Select Case LCase(objFSO.GetExtensionName(objFile.Name))
Case "xls", "xlsx"
If objExcel Is Nothing Then
Set objExcel = WScript.CreateObject("Excel.Application")
End If

objExcel.Workbooks.OpenText strTemplateFile, , , , , , , , , , , , , , , , , True
Set objTemplateFile = objExcel.Workbooks.Item(1)

Set objSourceFile = objExcel.Workbooks.Open(objFile.Path, False, True)

For i = 1 To objSourceFile.Worksheets.Item(1).UsedRange.Rows.Count - 2
With objTemplateFile.Worksheets.Item(1)
anyValue = objSourceFile.Worksheets.Item(1).Cells.Item(i + 1, 5).Value

.Range("B3").Value = anyValue
.Range("F2").Value = anyValue

anyValue = objSourceFile.Worksheets.Item(1).Cells.Item(i + 1, 6).Value

.Range("D3").Value = anyValue
.Range("D4").Value = anyValue
.Range("H3").Value = anyValue
'Подсчет НДС
.Range("L3").Value = Fix((anyValue * 18 / 118 + 0.005) * 100) / 100

'Подсчет общей суммы:
SumTotal = SumTotal + anyValue

'Подсчет суммы по реестру:
SumSourceFile = SumSourceFile + anyValue

'Подсчет суммы по чекам:
SumDestFile = SumDestFile + .Range("H3").Value

End With
' Создаем имя файла
strDestFile = objFSO.BuildPath(strRootFolder, objFSO.GetBaseName(strTemplateFile) & "_" & objFSO.GetBaseName(objFile.Name) & "_" & Right("000" & CStr(i), 3) & "." & objFSO.GetExtensionName(strTemplateFile))

If objFSO.FileExists(strDestFile) Then
objFSO.DeleteFile strDestFile, True
End If

objTemplateFile.SaveAs strDestFile, xlCSV, , , , , , , , , , True


Next

'В strLogDestFile записывается где будет создан лог-файл и как он будет называться:
strLogDestFile = objFSO.BuildPath(strLogDestFolder, Day(now) & "_" & Month(now) & "_" & Year(now) & ".txt")

'Открытие лог-файла или создание, если его нет:
Set Log = objFSO.OpenTextFile(strLogDestFile, 8, True)
'Запись данных в лог-файл:
Log.Write FormatDateTime(now, 0) 'В лог записывается дата и время обработки файлов
Log.Write ". Обработан файл " & objFSO.GetBaseName(objFile.Name) & "." & objFSO.GetExtensionName(objFile.Name)
Log.Write ". Строк обработано: " & CStr(objSourceFile.Worksheets.Item(1).UsedRange.Rows.Count - 2)
Log.Write ". Чеков создано: " & CStr(objSourceFile.Worksheets.Item(1).UsedRange.Rows.Count - 2)
Log.Write ". Сумма по реестру: " & SumSourceFile
Log.Write ". Сумма по чекам: " & SumDestFile
'Сравнение сумм по реестру и чекам - если они равны, то это записывается в лог
If SumSourceFile = SumDestFile Then
Log.Write ". Суммы равны."
End If
Log.WriteBlankLines(1)
Log.Close

'Обнуление сумм, чтобы для каждого файла реестра и его чеков считалась своя отдельная сумма
SumSourceFile = 0
SumDestFile = 0

objSourceFile.Close False
objTemplateFile.Close False
End Select
Next

If Not objExcel Is Nothing Then
objExcel.Quit
Set objExcel = Nothing


'Копируем файлы из папки "Итог" в папку "Архив"
' Set objFSO = WScript.CreateObject("Scripting.FileSystemObject")
' objFSO.CopyFile "C:\Реестр\Итог\*.*" , "C:\Реестр\Архив\"


'Выводит окно о завершении обработки файлов:
WScript.Echo "Чеки сформированы успешно. Обработано " & CountSourceFiles & " реестра на сумму " & SumTotal & ". Подробности на C:\касса"

Else
WScript.Echo "Can't find source folder [" & strSourceFolder & "]."
WScript.Quit 2
End If

Set objFSO = Nothing

Else
WScript.Echo "Can't find template file [" & strTemplateFile & "]."
WScript.Quit 1
End If

'Else
' WScript.Echo "Usage: cscript.exe //nologo """ & WScript.ScriptName & """ <Source folder>"
' WScript.Quit 1

End if
WScript.Quit 0

[megaloman]

jordan_74, Я подробно не разбирался в Вашем коде, понял, что Вы создаёте несколько папок. Потом запутываетесь в путях.
Зачем-то многократно определяете Set objFSO ...
Вот пример применения функции, которая при необходимости создаст все папки в указанном пути, даже если папка более высокого уровня пока не существует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

[jordan_74]

Iska, Добрый день! Спасибо за помощь, все получилось !
Хочу вот о чем спросить, с 2019 года НДС будет не 18 а 20 %. В текущем коде 18% и я понимаю, что нужно задействовать дату. При условии что в реестре дата (второй столбец) больше 31.12.2018 тогда формула расчета НДС будет следующая:
.Range("L3").Value = Fix((anyValue * 20 / 120 + 0.005) * 100) / 100

Просьба помочь в оформлении условия. Вот текущий код

Select Case LCase(objFSO.GetExtensionName(objFile.Name))
Case "xls", "xlsx"
If objExcel Is Nothing Then
Set objExcel = WScript.CreateObject("Excel.Application")
End If

objExcel.Workbooks.OpenText strTemplateFile, , , , , , , , , , , , , , , , , True
Set objTemplateFile = objExcel.Workbooks.Item(1)

Set objSourceFile = objExcel.Workbooks.Open(objFile.Path, False, True)

For i = 1 To objSourceFile.Worksheets.Item(1).UsedRange.Rows.Count - 2
With objTemplateFile.Worksheets.Item(1)
anyValue = objSourceFile.Worksheets.Item(1).Cells.Item(i + 1, 4).Value

.Range("B3").Value = anyValue
.Range("F2").Value = anyValue

anyValue = objSourceFile.Worksheets.Item(1).Cells.Item(i + 1, 5).Value

.Range("D3").Value = anyValue
.Range("D4").Value = anyValue
.Range("H3").Value = anyValue
' Подсчет НДС
.Range("L3").Value = Fix((anyValue * 18 / 118 + 0.005) * 100) / 100

'Подсчет общей суммы:
SumTotal = SumTotal + anyValue

'Подсчет суммы по реестру:
SumSourceFile = SumSourceFile + anyValue

'Подсчет суммы по чекам:
SumDestFile = SumDestFile + .Range("H3").Value

End With

[jordan_74]

После проб и ошибок получилось нечто следующее, вроде работает.

Select Case LCase(objFSO.GetExtensionName(objFile.Name))
Case "xls", "xlsx"
If objExcel Is Nothing Then
Set objExcel = WScript.CreateObject("Excel.Application")
End If

objExcel.Workbooks.OpenText strTemplateFile, , , , , , , , , , , , , , , , , True
Set objTemplateFile = objExcel.Workbooks.Item(1)

Set objSourceFile = objExcel.Workbooks.Open(objFile.Path, False, True)

For i = 1 To objSourceFile.Worksheets.Item(1).UsedRange.Rows.Count - 2
With objTemplateFile.Worksheets.Item(1)
anyValue = objSourceFile.Worksheets.Item(1).Cells.Item(i + 1, 4).Value

.Range("B3").Value = anyValue
.Range("F2").Value = anyValue

anyValue = objSourceFile.Worksheets.Item(1).Cells.Item(i + 1, 5).Value

.Range("D3").Value = anyValue
.Range("D4").Value = anyValue
.Range("H3").Value = anyValue
' Подсчет НДС
DataPlatez = objSourceFile.Worksheets.Item(1).Cells.Item(i + 1, 2).Value
' Если дата платежа в реестре меньше или равно 31.12.2018
If DataPlatez <= #31/12/2018# Then
' НДС расчитывается по ставке 18%
.Range("L3").Value = Fix((anyValue * 18 / 118 + 0.005) * 100) / 100
Else
' Иначе НДС расчитывается по ставке 20%
.Range("L3").Value = Fix((anyValue * 20 / 120 + 0.005) * 100) / 100
End if

'Подсчет общей суммы:
SumTotal = SumTotal + anyValue

'Подсчет суммы по реестру:
SumSourceFile = SumSourceFile + anyValue

'Подсчет суммы по чекам:
SumDestFile = SumDestFile + .Range("H3").Value

End With