[Phoenix]

OSArev, Как добавить в контекстное меню пункты “Копировать в папку” и “Переместить в папку”

оно?

[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: вопросы и ответы

[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