Dim strFile, strTemp, x, y
Dim objWMI, objEventsCollection, objEvent, objFS
Const strTestDir = "c:\\\\source" 'Это - C:\папка
Const strSourceDir = "c:\source\" 'Это - тоже C:\папка
Const strTargetDir = "c:\target\" 'Это - C:\папка2
Set objWMI = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
Set objEventsCollection = objWMI.ExecNotificationQuery _
("SELECT * FROM __InstanceCreationEvent WITHIN 1 WHERE " _
& "Targetinstance ISA 'CIM_DirectoryContainsFile' and " _
& "TargetInstance.GroupComponent= " _
& "'Win32_Directory.Name=""" & strTestDir & """'")
Set objFS = CreateObject("Scripting.FileSystemObject")
Do
Set objEvent = objEventsCollection.NextEvent
strTemp = objEvent.TargetInstance.PartComponent
x = InStrRev(strTemp, "\")
y = Len(Mid(strTemp, x + 1)) - 1
strFile = Mid(strTemp, x + 1, y)
If objFS.FileExists(strTargetDir & strFile) Then
objFS.DeleteFile strTargetDir & strFile, True
End If
objFS.MoveFile strSourceDir & strFile, strTargetDir
Loop
цикл в папке
Подскажите пожалуйста код. Допустим есть папка C:\папка, нужно чтобы при появлении в ней любого файла (независимо от расширения), он переносился в C:\папка2 к примеру и удалялся из первой папки.
Цитата: rostov-ilya
... Допустим есть папка C:\папка, нужно чтобы при появлении в ней любого файла...
Для этого надо каким-либо образом следить за наступлением соответтвующего системного события, например, с помощью средств WMI.
Вот пример сценария для WSH:
Код:
Поскольку сценарий основан на бесконечном цикле, то в рабочей версии надо предусмотреть какой-либо способ завершения этого цикла (например, по таймеру или количеству зарегистрированных событий).
Если программа пишется на VB6, то можно создать объект Timer, задать ему интервал, допустим, в 100 (думаю, это наиболее оптимальный вариант), Enabled, соответственно, в True, и тело цикла записать в процедуру Timer1_Timer. Таким образом бесконечный цикл будет выполняться параллельно выполнению основного кода и других событий приложения, и приложение можно будет легко закрыть.
а у меня предложение несколько иного плана: дело в том, что есть API функции FindFirstChangeNotification, FindNextChangeNotification, FindCloseChangeNotification с помощью которых можно отслеживать изменение в выбранном каталоге, потом как только появился сигнал о появлении файла перемещать его куда надо, правда, наверное, для реализации всего этого понадобится работать с потоками, но думаю зато будет интересно реализовывать это, да и есть чему поучиться при таком подходе.
Ну вот, rostov-ilya, у Вас есть из чего выбирать. :)
Добавлю "до кучи" ещё один сценарий:
По сути - это "скриптовая" реализация того алгоритма, который предложил AxXxB.
Добавлю "до кучи" ещё один сценарий:
Код:
Dim objFS, objFolder, objFiles, objCurFile
Dim strTemp
Const strSourceDir = "c:\source\"
Const strTargetDir = "c:\target\"
Set objFS = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFS.GetFolder(strSourceDir)
Do
If objFolder.Files.Count > 0 Then
For Each objCurFile In objFolder.Files
strTemp = objCurFile.Name
If objFS.FileExists(strTargetDir & strTemp) Then
objFS.DeleteFile strTargetDir & strTemp, True
End If
objCurFile.Move strTargetDir
Next
End If
WScript.Sleep 1000
Loop
Dim strTemp
Const strSourceDir = "c:\source\"
Const strTargetDir = "c:\target\"
Set objFS = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFS.GetFolder(strSourceDir)
Do
If objFolder.Files.Count > 0 Then
For Each objCurFile In objFolder.Files
strTemp = objCurFile.Name
If objFS.FileExists(strTargetDir & strTemp) Then
objFS.DeleteFile strTargetDir & strTemp, True
End If
objCurFile.Move strTargetDir
Next
End If
WScript.Sleep 1000
Loop
По сути - это "скриптовая" реализация того алгоритма, который предложил AxXxB.
Большое спасибо за ответы.
Цитата: Dmitrii
Ну вот, rostov-ilya, у Вас есть из чего выбирать. :)
Добавлю "до кучи" ещё один сценарий:
По сути - это "скриптовая" реализация того алгоритма, который предложил AxXxB.
Добавлю "до кучи" ещё один сценарий:
Код:
Dim objFS, objFolder, objFiles, objCurFile
Dim strTemp
Const strSourceDir = "c:\source\"
Const strTargetDir = "c:\target\"
Set objFS = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFS.GetFolder(strSourceDir)
Do
If objFolder.Files.Count > 0 Then
For Each objCurFile In objFolder.Files
strTemp = objCurFile.Name
If objFS.FileExists(strTargetDir & strTemp) Then
objFS.DeleteFile strTargetDir & strTemp, True
End If
objCurFile.Move strTargetDir
Next
End If
WScript.Sleep 1000
Loop
Dim strTemp
Const strSourceDir = "c:\source\"
Const strTargetDir = "c:\target\"
Set objFS = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFS.GetFolder(strSourceDir)
Do
If objFolder.Files.Count > 0 Then
For Each objCurFile In objFolder.Files
strTemp = objCurFile.Name
If objFS.FileExists(strTargetDir & strTemp) Then
objFS.DeleteFile strTargetDir & strTemp, True
End If
objCurFile.Move strTargetDir
Next
End If
WScript.Sleep 1000
Loop
По сути - это "скриптовая" реализация того алгоритма, который предложил AxXxB.
ругается на WScript.Sleep 1000 "object required" я так понял команда останавливает скрипт через какое-то время или число отработанных раз, может надо как-то обьявить или библиотеку подключить какую?
Цитата: Dmitrii
Для этого надо каким-либо образом следить за наступлением соответтвующего системного события, например, с помощью средств WMI.
Вот пример сценария для WSH:
Поскольку сценарий основан на бесконечном цикле, то в рабочей версии надо предусмотреть какой-либо способ завершения этого цикла (например, по таймеру или количеству зарегистрированных событий).
Вот пример сценария для WSH:
Код:
Dim strFile, strTemp, x, y
Dim objWMI, objEventsCollection, objEvent, objFS
Const strTestDir = "c:\\\\source" 'Это - C:\папка
Const strSourceDir = "c:\source\" 'Это - тоже C:\папка
Const strTargetDir = "c:\target\" 'Это - C:\папка2
Set objWMI = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
Set objEventsCollection = objWMI.ExecNotificationQuery _
("SELECT * FROM __InstanceCreationEvent WITHIN 1 WHERE " _
& "Targetinstance ISA 'CIM_DirectoryContainsFile' and " _
& "TargetInstance.GroupComponent= " _
& "'Win32_Directory.Name=""" & strTestDir & """'")
Set objFS = CreateObject("Scripting.FileSystemObject")
Do
Set objEvent = objEventsCollection.NextEvent
strTemp = objEvent.TargetInstance.PartComponent
x = InStrRev(strTemp, "\")
y = Len(Mid(strTemp, x + 1)) - 1
strFile = Mid(strTemp, x + 1, y)
If objFS.FileExists(strTargetDir & strFile) Then
objFS.DeleteFile strTargetDir & strFile, True
End If
objFS.MoveFile strSourceDir & strFile, strTargetDir
Loop
Dim objWMI, objEventsCollection, objEvent, objFS
Const strTestDir = "c:\\\\source" 'Это - C:\папка
Const strSourceDir = "c:\source\" 'Это - тоже C:\папка
Const strTargetDir = "c:\target\" 'Это - C:\папка2
Set objWMI = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
Set objEventsCollection = objWMI.ExecNotificationQuery _
("SELECT * FROM __InstanceCreationEvent WITHIN 1 WHERE " _
& "Targetinstance ISA 'CIM_DirectoryContainsFile' and " _
& "TargetInstance.GroupComponent= " _
& "'Win32_Directory.Name=""" & strTestDir & """'")
Set objFS = CreateObject("Scripting.FileSystemObject")
Do
Set objEvent = objEventsCollection.NextEvent
strTemp = objEvent.TargetInstance.PartComponent
x = InStrRev(strTemp, "\")
y = Len(Mid(strTemp, x + 1)) - 1
strFile = Mid(strTemp, x + 1, y)
If objFS.FileExists(strTargetDir & strFile) Then
objFS.DeleteFile strTargetDir & strFile, True
End If
objFS.MoveFile strSourceDir & strFile, strTargetDir
Loop
Поскольку сценарий основан на бесконечном цикле, то в рабочей версии надо предусмотреть какой-либо способ завершения этого цикла (например, по таймеру или количеству зарегистрированных событий).
Работает хорошо, спасибо. Только остановить нельзя и ругается что приложение занято ( this action cannot be completed because the other application is busy. choose 'switch to' to activate the busy application and correct the problem.)
Пытался остановить цикл не получилось в VBA еще пока не селён.
Цитата: rostov-ilya
... в VBA еще пока не селён.
Вы пытались использовать оба моих примера в составе макросов?
Если так, то они и не должны в этом случае нормально работать, потому что это сценарии для WSH.
Для использования в составе макроса в оба сценария надо добавить (либо в начало, либо в конец тела цикла) вызов функции [color=blue]DoEvents[/color].
Кроме того, во втором сценарии выражение WScript.Sleep 1000 заменить на вызов API-процедуры [color=blue]Sleep[/color].
Код:
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub Test()
Do
Sleep 1000
DoEvents
Loop
End Sub
Sub Test()
Do
Sleep 1000
DoEvents
Loop
End Sub
Цитата: Dmitrii
Вы пытались использовать оба моих примера в составе макросов?
Если так, то они и не должны в этом случае нормально работать, потому что это сценарии для WSH.
Для использования в составе макроса в оба сценария надо добавить (либо в начало, либо в конец тела цикла) вызов функции [color=blue]DoEvents[/color].
Кроме того, во втором сценарии выражение WScript.Sleep 1000 заменить на вызов API-процедуры [color=blue]Sleep[/color].
Если так, то они и не должны в этом случае нормально работать, потому что это сценарии для WSH.
Для использования в составе макроса в оба сценария надо добавить (либо в начало, либо в конец тела цикла) вызов функции [color=blue]DoEvents[/color].
Кроме того, во втором сценарии выражение WScript.Sleep 1000 заменить на вызов API-процедуры [color=blue]Sleep[/color].
Код:
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub Test()
Do
Sleep 1000
DoEvents
Loop
End Sub
Sub Test()
Do
Sleep 1000
DoEvents
Loop
End Sub
Уважаемый Dmitrii. Я использовал ваши макросы по отдельности, сталкиваясь с выше указанными ошибками. В общем используя процедуру Sleep во втором макросе у меня все висло намертво, сделал я так:
Public Sub idle(n As Single)
Dim t As Single
t = Timer + n
DoEvents
Do While Timer < t
Loop
End Sub
и процедурой idle() заменил Sleep.
Теперь такой вопрос этот макрос я запускаю кнопкой он вертится, как мне бы его при нажатии еще раз на кнопку тормозить? а то при выходе из программы он продолжает висеть в памяти и работать.
Цитата: rostov-ilya
... Я использовал ваши макросы по отдельности...
В этом я нисколько не сомневался. Написав слово "оба", я имел в виду "и тот, и другой, но по-отдельности", а не "вместе".
Смысл моего замечания заключается в том, что представленные примеры в исходном виде не годятся для использования в составе макросов.
Цитата: rostov-ilya
... используя процедуру Sleep во втором макросе у меня все висло намертво...
Странно. Вот этот макрос у меня хорошо работает:
Код:
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub Test()
Dim objFS, objFolder, objFiles, objCurFile
Dim strTemp
Const strSourceDir = "c:\source\"
Const strTargetDir = "c:\target\"
Set objFS = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFS.GetFolder(strSourceDir)
Do
If objFolder.Files.Count > 0 Then
For Each objCurFile In objFolder.Files
strTemp = objCurFile.Name
If objFS.FileExists(strTargetDir & strTemp) Then
objFS.DeleteFile strTargetDir & strTemp, True
End If
objCurFile.Move strTargetDir
Next
End If
Sleep 1000
DoEvents
Loop
End Sub
Sub Test()
Dim objFS, objFolder, objFiles, objCurFile
Dim strTemp
Const strSourceDir = "c:\source\"
Const strTargetDir = "c:\target\"
Set objFS = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFS.GetFolder(strSourceDir)
Do
If objFolder.Files.Count > 0 Then
For Each objCurFile In objFolder.Files
strTemp = objCurFile.Name
If objFS.FileExists(strTargetDir & strTemp) Then
objFS.DeleteFile strTargetDir & strTemp, True
End If
objCurFile.Move strTargetDir
Next
End If
Sleep 1000
DoEvents
Loop
End Sub
Разумеется, останавливать его приходится вручную.
Цитата: rostov-ilya
..
Пытался остановить цикл не получилось в VBA еще пока не селён.
Ctrl+Break рулит :)
Может, организовать второй поток?
Потоки на VB-это здорово.Я как-то читал,что они там не очень работают(илил вообще не работают).Попробую,но,по-моему,Notification-очень хорошая вешь
Кстати,kosfiz,не мог бы ты мне об этом подкинуть инфы?
Кстати,kosfiz,не мог бы ты мне об этом подкинуть инфы?
Цитата: @pixo $oft
Потоки на VB-это здорово.Я как-то читал,что они там не очень работают(илил вообще не работают).Попробую,но,по-моему,Notification-очень хорошая вешь
Кстати,kosfiz,не мог бы ты мне об этом подкинуть инфы?
Кстати,kosfiz,не мог бы ты мне об этом подкинуть инфы?
кстати соглашусь с тобой потоки на VB - это ... вообщем слов нет: готов тому кто реализует эту вещь(Notification) с потоками даже отзыв сделать положительный:), сам я пробывал - времени потратил кучу, правда и вб не очень увлекаюсь, так иногда.
@pixo $oft
по Notofocation как обычно в мсдн надо искать и гугл заюзать. извини что ничего конкретного не предлагаю поскольку на вб ничего у меня нет, зато если есть желание могу подкинуть код, правда на си, но ты сможешь просмотреть вообще как это организовывается, так что если нужно - в личку.