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

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

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

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

Здраствуйте...
Возможно, ли воплотить посредством написания скрипта на 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

оно? »

Не оно.
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)



А тут надо вставить вырезанный объект.А как?

Как указать на вновь созданную папку?

Как узнать её имя и путь к ней?

Возвращаюсь к своей маникальной идее средствами 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 так, чтобы это не влияло на количество копируемых объектов.
Извините, если эта тема кажется лёгкой - я новичёк, и ни как не могу это понять.
Спасибо.

Многократный запуск 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-и объектов. Может, кто подскажет, как победить это несчастье. На данном этапе не могу этого догнать.
Спасибо.

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

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

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

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

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

* * *

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

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

Спасибо

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

Цитата:

Цитата alpap

можете рассказать как и куда девать скрипты »

Я, так понимаю, где их разместить и как их прописать?
Напримере моих двух скриптов :Скрипт№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"
можно без проблем добавлять свои пунткы.

Цитата:

Цитата homo_novu5

оптимизировать скрипт
чтобы перемещал созданные на рабочем столе Юзера файлы .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-и объектов. Может, кто подскажет, как победить это несчастье. На данном этапе не могу этого догнать.
Спасибо. »

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

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

Цитата:

Цитата alpap

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

Пока ни до чего не "дотумкался".
Если есть, какие идеи - поделись.

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

Цитата:

Цитата alpap

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

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

Кстати, насчёт:

Цитата:

Цитата alpap

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 произойдет полное отключение команд, включая команду "Открыть". "

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

Цитата:

Цитата OSArev

перемещение в папку выделенных файлов из контекстного меню »

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