[Iska]

upward, гарантировать корректную работу «SendKeys()» практически невозможно. Пробуйте:

Код:

Option Explicit

Const wdCollapseEnd = 0

Dim objWshShell
Dim objWord
Dim objDocument
Dim objWB

Dim i
Dim strPath


Set objWshShell = WScript.CreateObject("WScript.Shell")
Set objWord     = WScript.CreateObject("Word.Application")
Set objWB       = WScript.CreateObject("Word.Basic")

Set objDocument = objWord.Documents.Add()

For i = 0 To 4
	With objWshShell.Exec("""%SystemRoot%\System32\rundll32.exe"" SHELL32.DLL,Control_RunDLL SYSDM.cpl,@0," & CStr(i))
		WScript.Sleep 1000
		objWshShell.AppActivate .ProcessID
		WScript.Sleep 300
		objWB.SendKeys "%{PRTSC}", True
		WScript.Sleep 1000
		
		.Terminate()
	End With
	
	With objWord.Selection
		.Paste
		.Collapse wdCollapseEnd
		.InsertParagraphAfter
		.Collapse wdCollapseEnd
		.TypeText "Рисунок " & CStr(i + 1)
		.InsertParagraphAfter
		.Collapse wdCollapseEnd
	End With
Next

objDocument.SaveAs "c:\My Screenshots.doc"
objDocument.Close

objWord.Quit

Set objWord     = Nothing
Set objWB       = Nothing
Set objWshShell = Nothing

WScript.Quit