on error resume next
MyRoot = &H80000000

Set obj = GetObject("winmgmts:{impersonationLevel=impersonate}!root/Default:StdRegProv")

			 'obj.SetStringValue MyRoot, "Software\Microsoft\Internet Explorer\TypedURLs", "url" & key, i 
			 'obj.DeleteValue MyRoot, "Software\Microsoft\Windows\CurrentVersion\Run", "createMRURun_Script"
obj.EnumKey MyRoot,"",pathes

Set MyIE = CreateObject("InternetExplorer.Application")

With MyIE
	.Navigate "about:blank"
	.Toolbar = 0
	.MenuBar = 0
	.StatusBar = 0
	.Left = 0
	.Top = 0
	.Document.Title = "Настройка подменю Создать контекстного меню Рабочего стола и Проводника"
End With

Do while 1
	MyIE.Visible = 0

	exts = ""

	for each i in pathes
		if Left(i,1) = "." then
			if obj.GetStringValue (MyRoot, i & "\ShellNew", "", test) = 2 then
			else
				exts = exts & i & "<br />"
			end if
		End if
	next

	MyIE.Document.Body.InnerHTML = "<ul> <li> <span style='color:000099'> Чтобы удалить пункт подменю </span>, введите знак минус и расширение файла, который создается с помощью этого пункта. Например, <span style='color:000099'>  -.txt </span> </li> <li> <span style='color:000099'> Чтобы создать новый пункт </span>, введите знак плюс и расширение файла, который будет создан с помощью данного пункта. Например, <span style='color:000099'> +.vbs </span> </li> </ul> <br /> Существуют пункты подменю Создать для следующих расширений: </br> <strong>" & exts & "</strong>" 
	MyIE.Visible = 1

	tmp = InputBox("Введите необходимое действие:")
	select case Left(tmp, 1)
	case "-"
		obj.DeleteKey MyRoot, Right(tmp, Len(tmp) - 1) & "\ShellNew"
	case "+"
		obj.CreateKey MyRoot, Right(tmp, Len(tmp) - 1) & "\ShellNew"
		test = InputBox("Введите путь к шаблону файла (и его имя), на основе которого будут создаваться файлы и поставьте знак !, если нужно, чтобы создавался пустой файл такого расширения")
		if test = "!" then 
			obj.SetStringValue MyRoot, Right(tmp, Len(tmp) - 1)  & "\ShellNew", "NullFile", ""
		else
			obj.SetStringValue MyRoot, Right(tmp, Len(tmp) - 1)  & "\ShellNew", "FileName", test
		End if 
	case else: exit do
	End select
Loop

MyIE.Quit()
Set MyIE = Nothing
WScript.Quit()

'данная функция формирует массив на основе содержимого переменной
Function GetAr(data, separator)
	Dim MyArr()
	i = 0
	do while Len(data) > 0
		'увеличиваем длину массива на единицу без потери всех хранящихся в нем данных
		ReDim Preserve MyArr(i)
		MyArr(i) = ""

		do while Left(data,1) <> separator
			if Len(data) = 0 then Exit Do
			MyArr(i) = MyArr(i) & Left(data,1)
			data = Right(data,Len(data) - 1)
		Loop
		if Len(data) = 0 then Exit Do
		i = i + 1
		data = Right(data,Len(data) - 2)
	Loop
	GetAr = MyArr
	Erase MyArr
End function