[Iska]

sov44, пробуйте:

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

Код:

Option Explicit

Dim objFSO
Dim objFile

Dim strPath2Wallpapers
Dim strPath2File

Dim objImageFile
Dim objImageProcess

Dim lngScreenHeight
Dim lngScreenWidth

Dim lngDelta


Set objFSO          = WScript.CreateObject("Scripting.FileSystemObject")
Set objImageFile    = WScript.CreateObject("WIA.ImageFile")
Set objImageProcess = WScript.CreateObject("WIA.ImageProcess")

strPath2Wallpapers = objFSO.BuildPath(objFSO.GetSpecialFolder(0).Path, "Web\Wallpaper")

With WScript.CreateObject("htmlfile")
	With .Script.screen
		lngScreenHeight = .Height
		lngScreenWidth  = .Width
	End With
End With

If objFSO.FolderExists(strPath2Wallpapers) Then
	With objFSO.GetFolder(strPath2Wallpapers)
		' Создадим копию папки %SystemRoot%\Web\Wallpaper
		.Copy objFSO.BuildPath(objFSO.GetSpecialFolder(0).Path, "Web\Wallpaper.bak"), True
	
		For Each objFile In .Files
			WScript.Echo objFile.Path
			
			objImageFile.LoadFile objFile.Path
			
			With objImageProcess
				.Filters.Add .FilterInfos("Crop").FilterID
				
				With .Filters(1).Properties
					If lngScreenHeight / lngScreenWidth > objImageFile.Height / objImageFile.Width Then
						' Подрежем справа-слева
						lngDelta = (objImageFile.Width - objImageFile.Height * lngScreenWidth / lngScreenHeight) / 2
						
						.Item("Left")   = lngDelta
						.Item("Right")  = lngDelta
					ElseIf lngScreenHeight / lngScreenWidth < objImageFile.Height / objImageFile.Width Then
						' Подрежем сверху-снизу
						lngDelta = (objImageFile.Height - objImageFile.Width * lngScreenHeight / lngScreenWidth) / 2
						
						.Item("Top")    = lngDelta
						.Item("Bottom") = lngDelta
					Else
						' Nothing to do
					End If
				End With
				
				Set objImageFile = .Apply(objImageFile)
				
				.Filters.Remove 1
			End With
			
			' Перезаписывать существующий файл компонент не умеет,
			' потому предварительно удаляем файл…
			strPath2File = objFile.Path
			objFile.Delete
			
			' Сохраняем файл под тем же именем:
			objImageFile.SaveFile strPath2File
		Next
	End With
Else
	WScript.Echo "Wallpaper's folder [" & strPath2Wallpapers & "] not found"
End If

Set objImageProcess = Nothing
Set objImageFile    = Nothing
Set objFSO          = Nothing

WScript.Quit 0

Копия папки получит имя «Wallpaper.bak».