Создание папки в определенном каталоге - Компьютерный форум OSzone.net

Компьютерный форум OSzone.net (http://forum.oszone.net/index.php)

- Скриптовые языки администрирования Windows (http://forum.oszone.net/forumdisplay.php?f=102)

- - Создание папки в определенном каталоге (http://forum.oszone.net/showthread.php?t=337954)

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

Всем добрый вечер! Нужна ваша помощь, о просветленные программисты)
Есть скрипт на 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)

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

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

Цитата:

Цитата mwz

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

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

Цитата:

Цитата jordan_74

Вопрос, как эту самую(е) папки создавать в папке Архив? »

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

Цитата:

Цитата jordan_74

Почему то создается в корне C:\Реестр\ »

Вероятно Ваш скрипт там находится. Оттуда Вы его запускаете, и потому данный каталог является текущим для него:

Скрытый текст

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

Код:

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 без веских причин!

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

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

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

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

Скрытый текст

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