Перемещение файлов в только, что созданную папку из контекстного меню.

[OSArev]

Здраствуйте...
Возможно, ли воплотить посредством написания скрипта на VBS перемещение в папку выделенных файлов из контекстного меню?
Что бы было более понятно, скажу, что такой пункт есть в программе "FileMenu Tools".
Пытался использовать:

On Error Resume Next
Dim Message, fso, Text, FolderName, FileName, Title
Message = "Введите название:"
Title = "Создание папки"
'создаем объект FileSystemObject в переменную fso
Set fso = CreateObject("Scripting.FileSystemObject")
FolderName = InputBox(Message, Title)
Set Fldr = fso.CreateFolder ("" & FolderName)

и

On error resume next
Dim objWshShell, strFolderName, strFullFolderName, Message, Title
Message = "Введите название:"
Title = "Создание папки"
Set objFSO = WScript.CreateObject("Scripting.FileSystemObject")
Set objWshShell = WScript.CreateObject("WScript.Shell")
strFolderName = InputBox(Message, Title)
strFullFolderName = objFSO.BuildPath(objWshShell.SpecialFolders("C , D ,"), strFolderName)
If objFSO.FolderExists(strFullFolderName) Then
WScript.Echo "Папка с таким именем уже существует."
Else
objFSO.CreateFolder strFullFolderName
WScript.Echo "Folder [" & strFullFolderName & "] created."
End If
Set objWshShell = Nothing
Set objFSO = Nothing
WScript.Quit 0

Эти два скрипта отлично справляются со своей задачей, по созданию папок.Но вот, чтобы переместить в созданную этими скриптами папку файлы...Полный ступор.
Пробывал через:

Set WshShell = CreateObject("WScript.Shell")
WshShell.SendKeys("^X")

и

Set WshShell = CreateObject("WScript.Shell")
WshShell.SendKeys("^V")

Но не хватает знаний.Прошу помощи.Буду признателен.

[Phoenix]

OSArev, Как добавить в контекстное меню пункты “Копировать в папку” и “Переместить в папку” (http://www.outsidethebox.ms/10617/)

оно?

[OSArev]

оно? »
Не оно.
1.Выделяется файл
2. Выводится "InputBox"
3.Вводится имя папки.
4.Создаётся папка.
5.Файл вырезается и вставляется в эту созданную папку.
Я не могу реализовать вставку в папку.

On Error Resume Next
Dim Message, fso, Text, FolderName, FileName, Title
Message = "Введите название:"
Title = "Создание папки"

Set WshShell = CreateObject("WScript.Shell") 'вырезаю
WshShell.SendKeys("^X")

Set fso = CreateObject("Scripting.FileSystemObject") 'создаю папку
FolderName = InputBox(Message, Title)
Set Fldr = fso.CreateFolder ("" & FolderName)

А тут надо вставить вырезанный объект.А как?
Как указать на вновь созданную папку?
Как узнать её имя и путь к ней?

[OSArev]

Возвращаюсь к своей маникальной идее средствами VBS "передрать" фукцию из FileMenuTools 'Перемещение в папку':

'*************************************
Dim objWshShell, strFileName, strFullFileName
Set objFSO = WScript.CreateObject("Scripting.FileSystemObject")
Set objWshShell = WScript.CreateObject("WScript.Shell")
'------------------------------------
' Создание папки(никаких проблем):
Dim objFSO, objFolder, objShell, strDirectory
strDirectory = InputBox("Введите название папки:", "Пермещение объектов.")
If Len(strDirectory) = 0 Then
strDirectory = WScript.Quit
End If

On Error Resume Next
Set objFSO = CreateObject("Scripting.FileSystemObject")
If objFSO.FolderExists(strDirectory) Then
Set objFolder = objFSO.GetFolder(strDirectory)
Else
Set objFolder = objFSO.CreateFolder(strDirectory)
End If
'-----------------------------------
'Узнаём путь к новой папке:
on error resume next
Folderspec = strDirectory
Set fso = CreateObject( "Scripting.FileSystemObject" )
Set folder = fso.GetFolder(folderSpec)
'**************************
'Дальше идёт код заимствованный на одном из форумов Ru.Board,
'(честное слово, не помню где точно),cпасибо огромное автору, для копирования
Set FSO = CreateObject("Scripting.FileSystemObject")
set Args = WScript.Arguments
Set objShellApp = CreateObject("Shell.Application")
'------------------------------------------------------
'Перед запуском скрипта Folder должен быть создан, иначе ошибка.
Set objFolder = objShellApp.NameSpace(strDirectory)

Dest = strDirectory

If Args.Count = 0 Then
WScript.Quit
End If
For i = 0 To Args.Count - 1
CopyObj IsFileOrDir(Args.Item(i)), Args.Item(i)
Next
MsgBox "Скопировано"
'===========================================================
Function IsFileOrDir (ItemPath)

If FSO.FileExists (ItemPath) Then
IsFileOrDir = "File"
Else
IsFileOrDir = "Dir"
End If

End Function
'===========================================================
Sub CopyObj (FileOrDir, ItemPath)

Select Case FileOrDir

Case "File"

Set File = FSO.GetFile (ItemPath)

File.Copy CreateDestFolders(Dirs)

Case "Dir"

Set Folder = FSO.GetFolder (ItemPath)

Folder.Copy CreateDestFolders(Dirs)

End Select

End Sub
'===========================================================
Function CreateDestFolders(Dirs)

SplitDirs = Split(Dirs, "\")

DestFold = Dest

For j = 0 To UBound(SplitDirs)

NewDest = DestFold & "\" & SplitDirs(j)

If Not FSO.FolderExists(NewDest) Then
FSO.CreateFolder NewDest
End If
DestFold = NewDest

Next

CreateDestFolders = DestFold & "\"

End Function

Прописываю этот код в реестр с параметром "%1" и всё в порядке, но...
Всё в порядке для одного объекта. А при попытке скопировать несколько объектов - Inputbox запускается равнозначно количеству выделенных в меню объектов.
Подскажите, пожалуйста, как ограничить запуск InputBox так, чтобы это не влияло на количество копируемых объектов.
Извините, если эта тема кажется лёгкой - я новичёк, и ни как не могу это понять.
Спасибо.

[OSArev]

Многократный запуск InputBox - победил, при помощи создания временных файлов. Но пришлось создавать два скрипта.
Скрипт№1:

Set FSO = CreateObject("Scripting.FileSystemObject")
'Узнаю имена перемещаемых объектов:
Dim Arg,objArgs,s
Set objArgs = WScript.Arguments
For Each Arg In objArgs
s=s & Arg & vbCrLf
Next
'Пишу имена в файл:
Set f = FSO.OpenTextFile("C:\Windows\OSA\Moving_to_folder\testfile.log", 8, True)
f.Write s
f.Close
'Узнаю путь для создания новой папки:
If WScript.Arguments.Count = 1 Then
sFile = WScript.Arguments.Item(0)
End If

on error resume next
Filespec = sFile
Set folder = fso.GetFolder(fileSpec)
Set file = fso.GetFile(fileSpec)
'Пишу путь в файл:
Set f1 = FSO.OpenTextFile("C:\Windows\OSA\Moving_to_folder\testfile1.log", 2, True)
f1.WriteLine file.ParentFolder & "\"
F1.WriteLine folder.ParentFolder & "\"
f1.Close
'Запускаю второй скрипт:
Set WshShell = CreateObject ("WScript.Shell")
WSHShell.Run "C:\Windows\OSA\Moving_to_folder\Start1.vbs",,True

Скрипт№2:

'Запрещаю повторный запуск скрипта:
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FileExists("C:\Windows\OSA\Moving_to_folder\" & WScript.ScriptName & ".txt") Then
WScript.Quit
End If
FSO.CreateTextFile "C:\Windows\OSA\Moving_to_folder\" & WScript.ScriptName & ".txt"
'Читаю путь для содания папки;
Set objFSO = CreateObject ("Scripting.FileSystemObject")
filelocation = "C:\Windows\OSA\Moving_to_folder\testfile1.log"
If objFSO.FileExists(filelocation) Then
Set logfile = objFSO.OpenTextFile(filelocation, 1)

Do While Not logfile.AtEndOfStream
strcontents = ""
strcontents = logfile.ReadLine
If Not strcontents = "" then
'Создаю папку:
strRoot=strcontents

Set objFolder=objFSO.GetFolder(strRoot)
Set colFolders=objFolder.SubFolders

strFolder=InputBox("Введите имя папки:", "Перемещение в создаваемую папку:")
If objFSO.FolderExists(strRoot & strFolder) Then
Else
colFolders.Add strFolder
End If
End if
Loop
logfile.Close
end if
'Удаляю временный файл:
objFSO.DeleteFile "C:\Windows\OSA\Moving_to_folder\testfile1.log"
'Читаю имена перемещаемых объектов:
filelocation = "C:\Windows\OSA\Moving_to_folder\testfile.log"
If objFSO.FileExists(filelocation) Then
Set logfile = objFSO.OpenTextFile(filelocation, 1) '
Do While Not logfile.AtEndOfStream '
strcontents = ""
strcontents = logfile.ReadLine
If Not strcontents = "" then
'Перемещаю в созданную папку:
Set FSO =CreateObject("scripting.FileSystemObject")
on error resume next
fso.movefolder strcontents , strRoot & strFolder & "\"
fso.movefile strcontents , strRoot & strFolder & "\"
End if
Loop
logfile.Close
end if
'Удаляю временные файлы:
objFSO.DeleteFile "C:\Windows\OSA\Moving_to_folder\testfile.log"

FSO.DeleteFile "C:\Windows\OSA\Moving_to_folder\" & WScript.ScriptName & ".txt"

Но проявилась ещё одна бяка.
Работает только для 18-и, 20-и объектов. Может, кто подскажет, как победить это несчастье. На данном этапе не могу этого догнать.
Спасибо.

[homo_novu5]

подскажите еще, пожалуйста

есть компьютерный класс

шаловливые юзеры очень любят менять всевозможные атрибуты, мишуру
и оформления - например, в Сервис->Свойства папки->Общие и ->Вид
- насколько я понимаю в самой OC (Windows XP Prof. SP2)
предусмотрены значения "по умолчанию"

как написать такой скрипт, чтобы он, не мудрствуя лукаво,
сам возвращал эти самые "умолчания"
при каждом новом входе User'a в систему (или презагрузке)?

подскажите если кто знает

* * *

и еще - если по теме

оптимизировать скрипт
чтобы перемещал созданные на рабочем столе Юзера файлы .doc, .xls и прочую ересь
в папку C:\User\"дата создания"\


Спасибо

[Iska]

Windows SteadyState: вопросы и ответы (http://www.microsoft.com/rus/windows/products/winfamily/sharedaccess/faq.mspx)

[alpap]

Зравствуйте
OSArev
Если не тяжело, можете рассказать как и куда девать скрипты, я в этом не очень, а вот этот пункт из FileMenu Tools очень хочется.
Еще использую программу RightClicker Pro 1.44 - очень хороша, а можно как-то вставить пункты FileMenu Tools в ее конт. меню, это
было бы вообще идеально так как они дополняют друг друга. В RightClicker Pro 1.44, кстати, есть пункт "поместить в..." по типу
переместить в папку в FileMenu Tools, но там нельзя ввести свое имя папки - по умолчанию создается папка с именем "Новая папка",
не продумали, а как это изменить не знаю, через реестр ничего не получается.

[OSArev]

можете рассказать как и куда девать скрипты »
Я, так понимаю, где их разместить и как их прописать?
Напримере моих двух скриптов :Скрипт№1 и Скрипт№2 - это будет выглядеть так:
1.Размещаете их где угодно.
2.Что касается реестра. У меня скрипты расположены по адресу: "C:\Windows\OSA\Moving_to_folder".
Значит создаём reg-файл для этого пути.
а)Ведущим скриптом является Скрипт№1, значит reg-файл надо создать для него.
б)Т.к. скрипт будет использоваться для всех объектов файловой системы, то прописываем скрипт в "AllFilesystemObjects"

Windows Registry Editor Version 5.00

[HKEY_CLASSES_ROOT\AllFilesystemObjects\shell\Переместить в папку с текущей датой]
"icon"="shell32.dll,-21"

[HKEY_CLASSES_ROOT\AllFilesystemObjects\shell\Переместить в папку с текущей датой\command]
@="WScript C:\\Windows\\OSA\\To_folder_on_date\\To_folder_on_date.vbs \"%1\""


Что касается программы "RightClicker Pro 1.44" - не разу не работал. А вот в "FileMenuTools"
можно без проблем добавлять свои пунткы.

[OSArev]

оптимизировать скрипт
чтобы перемещал созданные на рабочем столе Юзера файлы .doc, .xls и прочую ересь
в папку C:\User\"дата создания"\ »
Вот есть хороший скрипт(на этом форуме!!!), только, что проверил:
http://forum.oszone.net/thread-86094.html
Можно переделать под свои нужды.
Dim FSO, FldN, Fls, Fl, DtN, FlN
Set FSO = WScript.CreateObject("Scripting.FileSystemObject")

FldN = "C:\Users\OSA\Desktop" ' Ваш путь откуда
If Not FSO.FolderExists(FldN) Then
MsgBox "Папка """ & FldN & """ не существует. ", vbExclamation, "Ошибка"
WScript.Quit
End If

Set Fls = FSO.GetFolder(FldN).Files
For Each Fl In Fls
' "C:\Users\" - Путь куда перемещать.
DtN = FSO.BuildPath("C:\Users\", GetDateName(Fl.DateLastModified))
If Not FSO.FolderExists(DtN) Then FSO.CreateFolder DtN

FlN = FSO.BuildPath(DtN, Fl.Name)
If FSO.FileExists(FlN) Then FSO.DeleteFile FlN, True
Fl.move FlN

MsgBox "Скрипт завершен. ", vbInformation, "Финиш"
WScript.Quit

Private Function GetDateName(Dt)
Dim M, D

M = Month(Dt)
D = Day(Dt)
If M < 10 Then M = "0" & M
If D < 10 Then D = "0" & D

GetDateName = Year(Dt) & "-" & M & "-" & D
End Function

[OSArev]

Но проявилась ещё одна бяка.
Работает только для 18-и, 20-и объектов. Может, кто подскажет, как победить это несчастье. На данном этапе не могу этого догнать.
Спасибо. »
Ну, что, ребята. Подскажите, что-нибудь.
И ещё иногда появляется ошибка:"Отказано в доступе". Это, наверное связано с именами - не дойдёт до меня никак.
Помогите, пожалуйста.

[alpap]

OSArev, а не получилось победить 18(20) объектов?

[OSArev]

OSArev, а не получилось победить 18(20) объектов? »
Пока ни до чего не "дотумкался".
Если есть, какие идеи - поделись.

[alpap]

OSArev я в программировании не силен, но есть такая мысль. Если как-то программно начинать так:
Выполняется команда "вырезать" потом уже создать папку, вставить в нее файлы и дать возможность выбрать имя папки. То есть, если ничего не выделено, то и скрипт не будет выполняться, а если выделен один объект или любое их количество то выполняется команда вырезать и далее. Не знаю можно ли так, просто к размышлению.

[OSArev]

OSArev я в программировании не силен, но есть такая мысль. Если как-то программно начинать так:
Выполняется команда "вырезать" потом уже создать папку, вставить в нее файлы и дать возможность выбрать имя папки. То есть, если ничего не выделено, то и скрипт не будет выполняться, а если выделен один объект или любое их количество то выполняется команда вырезать и далее. Не знаю можно ли так, просто к размышлению. »
Я уже работал в этом направлении(и скриптик написал), но есть пару недоработок.
1.Во время выполнения скрипта нельзя кликать мышкой, т.к. объекты переместятся в то место где кликнули мышкой.
2.При перемещении папка у меня остаётся открытой.
В каком направлении идти?
1-мысля:
Надо бы наверное найти способ отслеживать вновь созданную папку и ту же закрывать, но это не спасёт от случайного кликанья мышкой.
2-я мысля:
Отключать на время исполнения скрипта мышь(вроде бы где-то встречал).
3-я мысля:
Вырезать, как обычно, а из буфера перемещать уже по-другому, но вот каким образом?
Собственно скриптик:

'Разрешаем запуск только одного экземпляра, при помощи создания временного файла c именем скрипта:
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FileExists("C:\Windows\OSA\Moving_to_folder\" & WScript.ScriptName & ".txt") Then
WScript.Quit
End If
FSO.CreateTextFile "C:\Windows\OSA\Moving_to_folder\" & WScript.ScriptName & ".txt"
'-----------------------------------------------------
'Создание папки:
Dim objFSO, objFolder, objShell, strDirectory
strDirectory = InputBox("Введите название папки", "Перемещение объектов.")
If Len(strDirectory) = 0 Then

FSO.DeleteFile "C:\Windows\OSA\Moving_to_folder\" & WScript.ScriptName & ".txt"

strDirectory = WScript.Quit
End If

FSO.DeleteFile "C:\Windows\OSA\Moving_to_folder\" & WScript.ScriptName & ".txt"

On Error Resume Next
Set objFSO = CreateObject("Scripting.FileSystemObject")
If objFSO.FolderExists(strDirectory) Then
Set objFolder = objFSO.GetFolder(strDirectory)
Else
Set objFolder = objFSO.CreateFolder(strDirectory)
End If
'-----------------------------------
'Узнаём путь к новой папке:
on error resume next
Folderspec = strDirectory
Set fso = CreateObject( "Scripting.FileSystemObject" )
Set folder = fso.GetFolder(folderSpec)
'------------------------------
' Используем "Вырезать" для перемещения объектов:
Set WshShell = CreateObject("WScript.Shell")
WshShell.SendKeys("^X")
'--------------------------
' Перемещаем объекты при помощи "Вставить":
folder = folder.Path & "\"
set shapp = createobject("shell.application")
shapp.open(folder)
WScript.Sleep 500
WshShell.SendKeys("^V")
'------------------------
' Удаляем временные файлы:
FSO.DeleteFile "C:\Windows\OSA\Moving_to_folder\" & WScript.ScriptName & ".txt"
WScript.Quit


Извиняюсь, за недоработки. Может ,кто поможет подправить мои ошибки.

Кстати, насчёт:OSArev, а не получилось победить 18(20) объектов? »
натолкнулся, сегодня случайно вот на такую документацию по реестру:

"Как известно, при выделении более 15 файлов команды контекстного меню, такие как "Открыть/Печать/Редактировать" становятся недоступны.
Для отмены данного ограничения проделайте следующее:

1) Запустите редактор реестра ( Win+R -> regedit -> OK)
2) Откройте ветку HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer
3) Создайте в ней параметр MultipleInvokePromptMinimum типа DWORD.
4) Установите значение данного параметра равным 16.

Для уменьшения количества файлов на которых действует ограничение применения команд, введите значение от 1 до 15.
При выделении файлов выше выбранного Вами значения команды в контекстном меню применяться не будут. При указании значения 0 произойдет полное отключение команд, включая команду "Открыть". "

Так, что рыть, при перемещении из контекстного, надо в другом направлении(для других команд то же самое). В каком?
Может кто и подскажет?

[denis19]

перемещение в папку выделенных файлов из контекстного меню »
On Error Resume Next
if WScript.Arguments.Count = 0 then WScript.Quit
Arg = WScript.Arguments(0)
set FSO=CreateObject ("Scripting.FileSystemObject")
File = Arg
FileName = FSO.GetBaseName(File)
FileName_ext = FSO.GetFileName(File)
ParentFolder = Left(Arg, InStrRev(Arg, "\"))
NewFolderPath = ParentFolder & "01.Перемещённое"
NewFilePath = NewFolderPath & "\" & FileName_ext
If not FSO.folderexists (NewFolderPath) then
fso.createfolder (NewFolderPath)
end if
If Not FSO.FileExists(NewFilePath) Then
FSO.MoveFile File, NewFolderPath & "\"
Else
MsgBox "Файл " & FileName_ext & " Уже существует в папке " & NewFolderPath, vbOKOnly + vbExclamation, "Внимание!"
End If
Set FSO = Nothing
Wscript.Quit