'====================================================================
' AJPapps - Create named folder
' Линда Кайе 2010. Посвящается Ариэль
' 
' Данный скрипт призван бороться с проблемой Проводника, когда при 
' создании папки (и последующем её переименовании) через окно 
' сохранения файла, система подвешивается на несколько секунд. Тут 
' всё просто: папку создаёт не Проводник, а скрипт, так что всё 
' работает без тормозов. И вызывается всё через тоже самое меню.
' 
' Скрипт рассчитан на Windows XP, но наверняка заработает и в других 
' системах. Возможно, кое-что придётся подправить.
' 
' • 12.10.2009
'   Первая версия ^^
' 
' • 15.10.2009
'   [+] Теперь скрипт учитывает имя папки, скопированное из FAR. 
'       Тоесть, оно может содержать пробелы по краям и заключено в 
'       кавычки. Вот их мы и убираем.
' 
'====================================================================
' Маленький копирайт
' 
' 1. Программа и исходный код распространяются бесплатно.
' 2. Вы имеете право распространять их на тех же условиях.
' 3. Вы не имеете права использовать имя автора после модификации 
'    исходного кода.
' 4. При этом желательно указывать ссылку на автора оригинальной 
'    версии исходного кода.
' 5. Вы не имеете права на платное распространение исходного кода, 
'    а также программных модулей, содержащих данный исходный код.
' 6. Программа и исходный код распространяются как есть. Автор не 
'    несёт ответственности за любые трагедии или несчастные случаи, 
'    вызванные использованием программы и исходного кода.
' 7. Для любого пункта данного соглашения может быть сделано 
'    исключение с разрешения автора программы.
' 8. По любым вопросам, связанным с данной программой, обращайтесь 
'    по адресу lindaoneesama@gmail.com
' 
' Загружено с http://purl.oclc.org/Linda_Kaioh/Homepage/
'====================================================================
Option Explicit

Const AppTitle = "AJPapps - Create named folder"
Const INVALID_CHARS = "/ \ : * ? "" < > |"

Dim FolderName
Dim Arg
Dim FSO
Dim BaseFolderName
Dim NewFolderName

On Error Resume Next

If WScript.Arguments.Count = 1 Then
  CreateFolderProc
Else
  InstallProc
End If

'====================================================================
Private Sub CreateFolderProc()
  ' Сохраняем в переменную - проще отлаживать...
  Arg = WScript.Arguments(0)

  ' Сделаем это заранее, чтобы не мучить пользователя в случае ошибок.
  Set FSO = CreateObject("Scripting.FileSystemObject")

  ' Система передаёт нам имя каталога, где было задействовано создание 
  ' файла, а также имя файла, состоящее из названия типа и расширения 
  ' типа. Всё кроме каталога нам надо отбросить.
  BaseFolderName = GetBaseFolderName(Arg)
  If BaseFolderName = "" Then
    MsgBox "Не удалось получить имя базового каталога." & vbCrLf & _
           "Продолжение невозможно.", vbCritical, AppTitle
    WScript.Quit
  End If

  ' Теперь получаем от пользователя имя папки. Так как GoTo тут нет,
  ' залупим процесс...
  Do
    FolderName = InputBox("Введите имя папки, которая будет создана в " & _
                          "текущей. Обратите внимание, что нельзя " & _
                          "использовать следующие символы:" & vbCrlf & _
                          vbCrLf & INVALID_CHARS, AppTitle, FolderName)
    
    ' Лень разбираться, будем выходить, всё равно пустая строка 
    ' бессмысленна.
    If FolderName = "" Then WScript.Quit
    
    ' Если скопировали из FAR, то могут быть всякие мелочи, 
    ' которые мы тут устраняем...
    FolderName = Trim(FolderName)
    If Left(FolderName, 1) = """" Then FolderName = Mid(FolderName, 2)
    If Right(FolderName, 1) = """" Then FolderName = Left(FolderName, Len(FolderName) - 1)
    
    ' Проверяем валидность имени, и если всё правильно, 
    ' выходим из цикла.
    If IsValidName(FolderName) Then
      Exit Do
    Else
      MsgBox "Имя файла не должно содержать следующих символов:" & _
             vbCrLf & vbCrLf & INVALID_CHARS, vbCritical, AppTitle
    End If
  Loop

  ' Сооружаем полное имя папки.
  NewFolderName = FSO.BuildPath(BaseFolderName, FolderName)

  ' А теперь проверим, существует ли вообще такая папка.
  If FSO.FolderExists(NewFolderName) Then
    MsgBox FolderName & vbCrLf & vbCrLf & _
           "Папка уже существует." & vbCrLf & _
           "Создавать нечего.", _
           vbExclamation, AppTitle
    WScript.Quit
  End If

  FSO.CreateFolder NewFolderName
  If Err Then
    ErrBox NewFolderName & vbCrLf & vbCrLf & _
           "Не удаётся создать папку."
    Wscript.Quit
  End If
  
  ' А тут мы ничего не сообщаем...
End Sub

'====================================================================
Private Function IsValidName(ByVal FolderName)
  Dim Chars
  Dim TMP
  
  Chars = Split(INVALID_CHARS, " ")
  
  For TMP = LBound(Chars) To UBound(Chars)
    If InStr(FolderName, Chars(TMP)) <> 0 Then
      IsValidName = False
      Exit Function
    End If
  Next
  
  IsValidName = True
End Function

'====================================================================
Private Function GetBaseFolderName(Arg)
  Dim TMP
  
  TMP = InStrRev(Arg, "\")
  If TMP > 0 Then GetBaseFolderName = Left(Arg, TMP - 1)
End Function

'====================================================================
Private Sub ErrBox(ByVal Message)
  MsgBox Message & vbCrlf & vbCrLf & _
         "Error number: " & Err.Number & vbCrLf & _
         "Description:  " & Err.Description, vbCritical, AppTitle
End Sub

'====================================================================
Private Sub InstallProc()
  Dim RC
  
  RC = MsgBox("Вы запустили скрипт без параметров. Сейчас можно " & _
              "установить его в системе, либо удалить все записи из " & _
              "реестра." & vbCrLf & vbCrLf & _
              "В случае установки убадитесь, что файл скрипта, " & _
              "который вы запустили, находится в каталоге, где он " & _
              "и должен лежать. После этого удалять этот файл или " & _
              "перемещать не стоит. Если это не так, нажмите Отмену, " & _
              "перенесите файл в нужную папку и запустите снова." & _
              vbCrLf & vbCrLf & _
              "В случае удаления записей из реестра, дождитесь " & _
              "успешного окончания операции и удалите файл скрипта. " & _
              "И всё." & vbCrLf & vbCrLf & _
              "И ещё. Установка возможна только пользователем с " & _
              "правами админа." & vbCrLf & vbCrLf & _
              "Да:     установить скрипт." & vbCrLf & _
              "Нет:    удалить скрипт." & vbCrLf & _
              "Отмена: отмена операции.", _
              vbInformation + vbYesNoCancel, AppTitle)
  
  Select Case RC
    Case vbYes: InstallScript
    Case vbNo:  UninstallScript
  End Select
End Sub

'====================================================================
Private Sub InstallScript()
  Dim WShell
  Set WShell = WScript.CreateObject("WScript.Shell")
  
  On Error Resume Next
  
  WShell.RegWrite "HKEY_CLASSES_ROOT\.99C\", "99C_File", "REG_SZ"
  If Err Then InstallScript_Error
  
  WShell.RegWrite "HKEY_CLASSES_ROOT\.99C\ShellNew\Command", _
                  """" & WScript.ScriptFullName & """ ""%1""", "REG_SZ"
  If Err Then InstallScript_Error
  
  WShell.RegWrite "HKEY_CLASSES_ROOT\99C_File\", _
                  "Папку с заданным именем", "REG_SZ"
  If Err Then InstallScript_Error
  
  WShell.RegWrite "HKEY_CLASSES_ROOT\99C_File\DefaultIcon\", _
                  "%SystemRoot%\System32\SHELL32.DLL,3", "REG_EXPAND_SZ"
  If Err Then InstallScript_Error
  
  WShell.RegWrite "HKEY_CLASSES_ROOT\99C_File\Shell\Open\Command\", _
                  "WScript.EXE """ & WScript.ScriptFullName & """ ""%1""", "REG_SZ"
  If Err Then InstallScript_Error
  
  MsgBox "Готово! ^_^v", vbInformation, AppTitle
End Sub

Private Sub InstallScript_Error()
  ErrBox "Не удалось записать все ключи в реестр." & vbCrLf & vbCrLf & _
         "Запустите скрипт от лица пользователя с правами админа."
  WScript.Quit
End Sub

'====================================================================
Private Sub UninstallScript()
  Dim WShell
  Set WShell = WScript.CreateObject("WScript.Shell")
  
  On Error Resume Next
  
  MyRegDelete WShell, "HKEY_CLASSES_ROOT\.99C\ShellNew\"
  If Err Then UninstallScript_Error
  
  MyRegDelete WShell, "HKEY_CLASSES_ROOT\.99C\"
  If Err Then UninstallScript_Error
  
  MyRegDelete WShell, "HKEY_CLASSES_ROOT\99C_File\Shell\Open\Command\"
  If Err Then UninstallScript_Error
  
  MyRegDelete WShell, "HKEY_CLASSES_ROOT\99C_File\Shell\Open\"
  If Err Then UninstallScript_Error
  
  MyRegDelete WShell, "HKEY_CLASSES_ROOT\99C_File\Shell\"
  If Err Then UninstallScript_Error
  
  MyRegDelete WShell, "HKEY_CLASSES_ROOT\99C_File\DefaultIcon\"
  If Err Then UninstallScript_Error
  
  MyRegDelete WShell, "HKEY_CLASSES_ROOT\99C_File\"
  If Err Then UninstallScript_Error
  
  MsgBox "Готово! ^_^v", vbInformation, AppTitle
End Sub

Private Sub UninstallScript_Error()
  ErrBox "Не удалось записать все ключи в реестр." & vbCrLf & vbCrLf & _
         "Запустите скрипт от лица пользователя с правами админа."
  WScript.Quit
End Sub

Private Sub MyRegDelete(WShell, ByVal KeyName)
  If IsKeyExist(WShell, KeyName) Then WShell.RegDelete KeyName
End Sub
  
Private Function IsKeyExist(WShell, ByVal KeyName)
  Dim TMP
  
  On Error Resume Next
  
  TMP = WShell.RegRead(KeyName)
  IsKeyExist = CBool(Err.Number = 0)
  
  Err.Clear
End Function