How to take print screen using VBScript?

if you getting any issues to activate using WshShell.AppActivate “untitled – Paint”.

Then You tried minimizing and Restoring the opened windows using shell.Application and it’s working fine.

1 script

'**************************************************
'Taking Screenshot using word object
Set oWordBasic = CreateObject("Word.Basic")
oWordBasic.SendKeys "{prtsc}" 
oWordBasic.AppClose "Microsoft Word"
Set oWordBasic = Nothing
WScript.Sleep 2000
 
'Opening Paint Application
set WshShell = CreateObject("WScript.Shell")
WshShell.Run "mspaint"
WScript.Sleep 2000
 
'Some times Paint Application is not activating properly
'To activate MS Paint properly i have minimized and restored the opened windows
set shl=createobject("shell.application")  
shl.MinimizeAll  
WScript.Sleep 1000
shl.UndoMinimizeAll
Set shl=Nothing
WScript.Sleep 1000
 
'Activating Paint Application
WshShell.AppActivate "untitled - Paint"
WScript.Sleep 1000
 
'Paste the captured Screenshot
WshShell.SendKeys "^v"
WScript.Sleep 500
 
'Save Screenshot
WshShell.SendKeys "^s"
WScript.Sleep 500
WshShell.SendKeys "c:\test.bmp"
WScript.Sleep 500
WshShell.SendKeys "{ENTER}"
 
'Release Objects
Set WshShell=Nothing
WScript.Quit
'************************************************** 

2 script

Docname = “snapshot.doc”
Foldername = “Folderpath”

Const END_OF_STORY = 6
Const MOVE_SELECTION = 0
count = 1
Docopen = 0

Set oWordBasic = CreateObject(“Word.Basic”)
oWordBasic.SendKeys “%{prtsc}”
oWordBasic.FileQuit
Set oWordBasic = nothing ‘ clean up’

StrFullname = Foldername & Docname

On Error resume Next
Dim oWdApp : Set oWdApp = GetObject(,”Word.Application”)

‘Msgbox(err.description)
If err.Number <> 0 then
Set oWdApp = CreateObject(“Word.Application”)
Set oWordBasic = CreateObject(“Word.Basic”)
End If
oWdApp.Visible = true
Err.Clear

Do Until count > oWdApp.Documents.Count OR oWdApp.Documents.Count = 0
‘Msgbox(oWdApp.Documents(count).Name)
if StrComp(oWdApp.Documents(count).FullName,StrFullname,1) = 0 then
Set MyDoc = oWdApp.Documents(count)
Docopen = 1
MyDoc.Activate
‘Msgbox(“Doc Open”)
Exit Do
End If
count = count + 1
Loop

if Docopen = 0 then
‘Msgbox(“Doc not open”)
Set MyDoc = oWdApp.Documents.Open(StrFullname)
If err.number = 5273 then
Msgbox(“Given directory ” & Foldername & ” does not exist, Create it First )” )
End If
If err.number = 5174 then
Set MyDoc = oWdApp.Documents.Add()
Mydoc.Saveas(StrFullname)
End If
End If

Set oWdApp.Visible=False

Set objSelection = oWdApp.Selection
objSelection.EndKey END_OF_STORY, MOVE_SELECTION
oWdApp.sendkeys “{ENter}”
objSelection.paste
Mydoc.save

Set oWdApp.Visible=True

Set Mydoc = Nothing
‘Set WshShell = WScript.CreateObject(“WScript.Shell”)
‘WshShell.AppActivate “Microsoft Internet Explorer”

oWdApp = nothing