VBScript & COM: Установка обоев на Рабочий стол

 
 'Скрипт предназначен для установки обоев на Рабочий стол,
 'и основан на вызове функций интерфейса IActiveDesktop 
 'средствами COM API.

 'Чтобы установить новые обои, перетащите изображение GIF, JPG или BMP
 'на значок скрипта.
 
 'ОС WinXP/7

 Option Explicit
 '---------------------------------------------------------------
 Dim sWallPaperPath
 Dim oArgs
 Dim oScrSvc

 Set oArgs = WScript.Arguments
 If oArgs.Length = 0 Then
	MsgBox "Чтобы установить новые обои, перетащите изображение GIF, JPG или BMP на значок скрипта.", _
	vbExclamation + vbSystemModal, _
	"Reply"
	QuitMe()
 Else
 	sWallPaperPath = CStr(oArgs.Item(0))	
 End If

 '---------------------------------------------------------------
 Set oScrSvc = CreateObject("ScriptService.Service")

 'Интерфейс [IActiveDesktop]
 '---------------------------------------------------------------
 Const CLSID_IActiveDesktop = "{75048700-EF1F-11D0-9888-006097DEACF9}"
 Const UUID_IActiveDesktop = "{F490EB00-1240-11D1-9888-006097DEACF9}"

 'Методы интерфейса IActiveDesktop;
 Const ApplyChanges = 3
 Const GetWallpaper = 4
 Const SetWallpaper = 5
 Const GetWallpaperOptions = 6     
 Const SetWallpaperOptions = 7    
 Const GetPattern = 8          
 Const SetPattern = 9             
 Const GetDesktopItemOptions = 10 
 Const SetDesktopItemOptions = 11  
 Const AddDesktopItem = 12         
 Const AddDesktopItemWithUI = 13   
 Const ModifyDesktopItem = 14      
 Const RemoveDesktopItem = 15   
 Const GetDesktopItemCount = 16    
 Const GetDesktopItem = 17       
 Const GetDesktopItemByID = 18    
 Const GenerateDesktopItemHtml = 19
 Const AddUrl = 20               
 Const GetDesktopItemBySource = 21

 'Параметры установки обоев
 Const WPSTYLE_CENTER = 0
 Const WPSTYLE_TILE = 1
 Const WPSTYLE_STRETCH = 2
 
 Const CLSCTX_INPROC_SERVER = 1
 Const CC_STDCALL = 4
 Const S_OK = 0

 '/Выбор параметров установки/
 '---------------------------------------------------------------
 Dim i
 Dim r
 Dim GUID1, GUID2
 Dim pVarRes
 Dim pWALLPAPEROPT
 Dim VftPtr
 Dim IActiveDesktop, lData, p
 Dim pSetWallpaper, pApplyChanges, pSetWallpaperOptions

 Dim WPSTYLE_CHOICE
 Dim arr(4)
 Dim arr1(4)
 Dim arrRet

 arr(0) = "Центрировать"
 arr(1) = "Замостить"
 arr(2) = "Растянуть"

 arr1(0) = WPSTYLE_CENTER
 arr1(1) = WPSTYLE_TILE
 arr1(2) = WPSTYLE_STRETCH

 arrRet = oScrSvc.multi_dialog(arr)

 If Ubound(arrRet)=-1 Then QuitMe()
 If Ubound(arrRet) > 0 Then
	MsgBox "Допустим выбор только одного параметра.", vbExclamation + vbSystemModal, "Reply"
	QuitMe()
 End If

 For i=0 To UBound(arr)
	If StrComp(arrRet(0),arr(i)) = 0 Then WPSTYLE_CHOICE = arr1(i)
 Next

 '/Запрос интерфейса IActiveDesktop и вызов его функций/
 '---------------------------------------------------------------
 With oScrSvc

	'Выделение памяти
	'-------------------------------------------------------
 	GUID1 = .struct_setval(String(8,Chr(32)))		'8*2=16 итоговое количество байт
 	GUID2 = .struct_setval(String(8,Chr(32)))		'8*2=16 итоговое количество байт
 	pVarRes = .struct_setval(String(2,Chr(32)))		'2*2=4 итоговое количество байт
	pWALLPAPEROPT = .struct_setval(String(4,Chr(32)))	'4*2=8 итоговое количество байт
	'-------------------------------------------------------
 
		.set_vararg 0, 0
		.api_call "OLE32.DLL","CoInitialize", 1

	'Запрос интерфейса
	'-------------------------------------------------------
	.set_strarg 0, CLSID_IActiveDesktop, True	
	.set_vararg 1, GUID1
	r = .api_call("OLE32.DLL","CLSIDFromString",2)
	
	.set_strarg 0, UUID_IActiveDesktop, True
	.set_vararg 1, GUID2
	r = .api_call("OLE32.DLL","CLSIDFromString",2)

	.set_vararg 0, GUID1
	.set_vararg 1, 0
	.set_vararg 2, CLSCTX_INPROC_SERVER
	.set_vararg 3, GUID2
	.set_vararg 4, pVarRes
	r = .api_call("OLE32.DLL","CoCreateInstance",5)

	'-------------------------------------------------------
	IActiveDesktop = .struct_getval(pVarRes, 0, 4)
	
	'Получение адресов функций из vtable
	'-------------------------------------------------------
	VftPtr = .struct_getval(IActiveDesktop, 0, 4)

	pSetWallpaper = .struct_getval(VftPtr, 4 * SetWallpaper, 4)
	pApplyChanges = .struct_getval(VftPtr, 4 * ApplyChanges, 4)	
	pSetWallpaperOptions = .struct_getval(VftPtr, 4 * SetWallpaperOptions, 4)	

	'Вызов интерфейсных функций, установка обоев рабочего стола
	'-------------------------------------------------------
	'-------------------------------------------------------

	'----------- Выбор обоев
	.set_vararg 0, IActiveDesktop
	.set_vararg 1, .struct_setval(sWallPaperPath)
	.set_vararg 2, 0
	.api_direct_call pSetWallpaper, 3

	'----------- Установка параметров
	.struct_setval pWALLPAPEROPT, 8, 0, 4
	.struct_setval pWALLPAPEROPT, WPSTYLE_CHOICE, 4, 4

	.set_vararg 0, IActiveDesktop
	.set_vararg 1, pWALLPAPEROPT
	.set_vararg 2, 0
	.api_direct_call pSetWallpaperOptions, 3

	'----------- Применение изменений
	.set_vararg 0, IActiveDesktop
	.set_vararg 1, 7
	.api_direct_call pApplyChanges, 2
	'-------------------------------------------------------

		.api_call "OLE32.DLL","CoUninitialize",0


	'-------------------------------------------------------
	WScript.Sleep(50)
	MsgBox "Проверьте правильность установки обоев Рабочего стола.", vbInformation + vbSystemModal, "Reply"
	QuitMe()

 End With

 '/Проверка ошибки/
 '---------------------------------------------------------------
 Sub CheckResult(x, sSource)
	If x <> S_OK Then
		MsgBox "Сбой выполнения. Источник" & sSource, vbSystemModal + vbExclamation, "Error"
		QuitMe()
	End If
 End Sub

 '/Завершение работы/
 '---------------------------------------------------------------
 Sub QuitMe()
	Set oScrSvc = Nothing
	WScript.Quit()
 End Sub