[Iska]

Научи.. »

Попробуйте так:

читать дальше »

Код:

Option Explicit

Const wiaFormatBMP = "{B96B3CAB-0728-11D3-9D7B-0000F81EF32E}"
Const ssfLOCALAPPDATA = &H1C


Dim strDomainPath2WallpaperFile

Dim objFSO

Dim strLocalPath2WallpaperFolder
Dim strLocalPath2WallpaperFile

Dim collSWbemObjectSet
Dim objSWbemObjectEx

Dim objImageFile


strDomainPath2WallpaperFile = "C:\Мои проекты\Wallpapers\Source2.jpg"

Set objFSO = WScript.CreateObject("Scripting.FileSystemObject")

If Not objFSO.FileExists(strDomainPath2WallpaperFile) Then
	WScript.Echo "Can't find wallpaper's source file [" & strDomainPath2WallpaperFile & "]."
	WScript.Quit 1
End If

strLocalPath2WallpaperFolder = objFSO.BuildPath(WScript.CreateObject("Shell.Application").NameSpace(ssfLOCALAPPDATA).self.Path, "Microsoft")

If Not objFSO.FolderExists(strLocalPath2WallpaperFolder) Then
	WScript.Echo "Can't find local path [" & strLocalPath2WallpaperFolder & "] to wallpapers."
	WScript.Quit 2
End If

Set collSWbemObjectSet = WScript.CreateObject("WbemScripting.SWbemLocator").ConnectServer(".", "root\cimv2").ExecQuery("SELECT ScreenWidth, ScreenHeight FROM Win32_DesktopMonitor")

If collSWbemObjectSet.Count > 0 Then
	For Each objSWbemObjectEx In collSWbemObjectSet
		Set objImageFile    = WScript.CreateObject("WIA.ImageFile")
		
		objImageFile.LoadFile strDomainPath2WallpaperFile
		
		With WScript.CreateObject("WIA.ImageProcess")
			.Filters.Add .FilterInfos("Scale").FilterID
			
			With .Filters.Item(1).Properties
				.Item("MaximumWidth")  = objSWbemObjectEx.ScreenWidth
				.Item("MaximumHeight") = objSWbemObjectEx.ScreenHeight
			End With
			
			.Filters.Add .FilterInfos("Convert").FilterID
			.Filters.Item(2).Properties.Item("FormatID").Value = wiaFormatBMP
			
			Set objImageFile = .Apply(objImageFile)
		End With
		
		strLocalPath2WallpaperFile = objFSO.BuildPath(strLocalPath2WallpaperFolder, objFSO.GetBaseName(strDomainPath2WallpaperFile) & ".bmp")
		
		If objFSO.FileExists(strLocalPath2WallpaperFile) Then
			objFSO.DeleteFile strLocalPath2WallpaperFile, True
		End If
		
		objImageFile.SaveFile strLocalPath2WallpaperFile
		
		With WScript.CreateObject("WScript.Shell")
			.RegWrite "HKEY_CURRENT_USER\Control Panel\Desktop\Wallpaper", strLocalPath2WallpaperFile
			.Run """%SystemRoot%\System32\RUNDLL32.EXE"" user32.dll,UpdatePerUserSystemParameters", 0, True
		End With
		
		Set objImageFile    = Nothing
		
		Exit For
	Next
Else
	WScript.Echo "Can't find any DesktopMonitor."
	WScript.Quit 3
End If

Set objFSO = Nothing

WScript.Quit 0

P.S. На «UpdatePerUserSystemParameters» я бы не особенно рассчитывал — работает от станции к станции, не угадаешь.
P.P.S. Конечно, можно масштабировать не только по большей стороне изображения как сейчас (при разнице в соотношении сторон исходного изображения и текущего разрешения (например, изображение — 16:9, а монитор — 4:3 сверху/снизу или справа/слева могут оставаться поля, заполненные фоновым цветом), но и вычислять кроп-фактор и обрезать изображение, подгоняя его соотношение под текущее разрешение.