Capture Screen Shot

[adeel1]

Hi All

i want to capture active window and save that image (PNG) in a folder. (Window 11)
is this possible with VBA..

i make this thread in "outlook" as i want to capture mail snap actually.
Adeel

[HansV]

See [RESOLVED] Screen Capture of the active window

[adeel1]

thx for your reply but this did not work...

Adeel

[HansV]

I hope someone else will have a suggestion for you.

[adeel1]

thx sir,

i also posted now https://www.excelforum.com/excel-progra ... ost5853883

Adeel

[ChrisGreaves]

thx for your reply but this did not work...

The code below is from my utility library UW.dot
You will need a defined constant

Code: Select all

Public Const VK_SNAPSHOT = &H2C ' for ActiveScreenToClipboard

Code: Select all

Public Function ActiveScreenToClipboard()
    ' Procedure :   ScreenToClipboard
    ' Description:  Simulate the PrtScr key.
    ' Copyright:    Christopher Greaves
    ' Inputs:       None
    ' Returns:      None.
    ' Assumes:      None.
    ' Side Effects: Clipboard contents change.
    ' Tested:       By a call from the user.
    ' This code compliments of Q240653 & Kevin Paddock of www.wopr.com (Woody's Lounge)
    keybd_event VK_SNAPSHOT, 1, 0, 0
    '    To test this code, indulge me:
    '    Run the macro, then open up Paint, Paintbrush, or any other graphics editor
    '       and within the graphics editor choose Edit Paste.
    '    You should see a snapshot of ALL OF the screen as it was at the time you ran the macro.
    '
    '    I suppose you could use this macro to trap a snapshot at the time an error was detected
    '       and generate an error report with the screen contents attached.
End Function
Public Function ActiveWindowToClipboard()
    ' Procedure :   ActiveWindowToClipboard
    ' Description:  Simulate the Alt-PrtScr key combination.
    ' Copyright:    Christopher Greaves
    ' Inputs:       None
    ' Returns:      None.
    ' Assumes:      None.
    ' Side Effects: Clipboard contents change.
    ' Tested:       By a call from the user.
    'This code compliments of Q240653 & Kevin Paddock of www.wopr.com (Woody's Lounge)
    keybd_event VK_SNAPSHOT, 0, 0, 0
    '    To test this code, indulge me:
    '    Run the macro, then open up Paint, Paintbrush, or any other graphics editor
    '       and within the graphics editor choose Edit Paste.
    '    You should see a snapshot of PART OF the screen as it was at the time you ran the macro.
    '
    '    I suppose you could use this macro to trap a snapshot at the time an error was detected
    '       and generate an error report with the screen contents attached.
End Function

Cheers, Chris

[JoeP]

Why don't you just use the snipping tool and not have to write something?

[adeel1]

Why don't you just use the snipping tool and not have to write something?

right now doing as you say, more then 100 images need to save of different emails, i am looking one click solution rather take snap ,ctrl+S then save in folder...

Adeel

[adeel1]

@Chris
thx for your help

when i paste your code in outlook module its shows error "keybd_event" function not defined
Adeel

[adeel1]

i found this code

this is working well but in excel when i run from outlook its showing error in different line i tried to change lines but hasn't succeed.

source code link: https://stackoverflow.com/questions/745 ... o-a-folder

Code: Select all

Private Declare PtrSafe Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, _
        ByVal dwFlags As Long, ByVal dwExtraInfo As LongPtr)

Private Const VK_SNAPSHOT = &H2C
Private Const KEYEVENTF_KEYUP = &H2

Private Const PREFIX As String = "<My folder>\"

Sub PrintScreen()
    ' grab filename
    Dim fileName As String
    fileName = ActiveCell.Value
    ' activate, for example, Chrome ... this will only work if Chrome is already in 
    ' a 'normal' or 'maximized' window (ie not 'minimized')
    AppActivate "Chrome", False
    ' take screenshot
    keybd_event VK_SNAPSHOT, 0, 0, 0
    keybd_event VK_SNAPSHOT, 0, KEYEVENTF_KEYUP, 0
    ' wait for screenshot
    Dim t As Single
    t = Timer + 0.1
    Do While Timer < t
        DoEvents
    Loop
    
    ' paste screenshot to sheet and grab it ... the active sheet must be 
    ' a Worksheet for this to work
    ActiveSheet.Paste
    Dim shp As Shape
    Set shp = Selection.ShapeRange(1)
    
    ' save as file ... PNG in this case
    If ExportPicture(shp, PREFIX & fileName & ".png", "png") Then
        ' do success stuff!
        Debug.Print "Success"
    Else
        ' do failed stuff!
        Debug.Print "Failed"
    End If
    
    ' optionally, if required, delete the screenshot
    shp.Delete
End Sub

' Export Shape, as a picture, to a file
Function ExportPicture(shp As Shape, sFile As String, sFilter As String) As Boolean
    On Error GoTo errExit
    Dim ch As ChartObject
    Set ch = shp.Parent.ChartObjects.Add(0, 0, shp.Width, shp.Height)
    ch.Activate
    ch.ShapeRange.Fill.Visible = msoFalse ' to allow transparency if PNG
    ch.ShapeRange.Line.Visible = msoFalse
    ch.Chart.Paste
    ch.Chart.Export sFile, sFilter
    ExportPicture = True
errExit:
    If Not ch Is Nothing Then ch.Delete
End Function
Share
Improve this answer
Follow
answered Nov 27, 2022 at 12:50
JohnM's user avatar
JohnM
1,347

Adeel

[ChrisGreaves]

when i paste your code in outlook module its shows error "keybd_event" function not defined

Adeel, I offer my my apologies.

I have assembled the VBA code in an MSWord2003 document (attached).
Please try testing/running the procedures in MSWord before Outlook. My VBA experience in mainly in MSWord. Once we are happy that they work for you in MSWord you can try porting them over to MSOutlook.

I re-ran the tests; i suspect that the procedure ActiveWindowToClipboard is not functioning as it should. I know it worked twenty years ago, but something might be different with Win 11.

Cheers, Chris

[JoeP]

Is your objective to save a copy of the email easily outside of Outlook? Does it have to be a picture?

[adeel1]

Hi @Charis Good Morning

thx for your help

when i open file there is one red at top but this not make any effect i think

A.png

this Code is 2 times in code ActiveScreenToClipboard this only show capture option and copy to clipboard then nothing is happening.

B.png

and when i am running this code "lngClipboard" nothing happening

if i overall hit F5 then code is doing nothing.
many thx

Adeel

[adeel1]

Is your objective to save a copy of the email easily outside of Outlook? Does it have to be a picture?

Hi Joe

only PNG pic as saving mails take lot of space as email also has further attachments in it.

Adeel

[HansV]

Disk storage is extremely cheap nowadays, so I wouldn't worry about the space taken up by email messages.

Moreover, deleting email messages and keeping only a picture of them is a bad idea - you can easily search for text in email messages, but searching for text in pictures is very tedious.

[ChrisGreaves]

and when i am running this code "lngClipboard" nothing happening
if i overall hit F5 then code is doing nothing.

Adeel, did you try running the TEST procedure for each of these procedures?
"Please try testing/running the procedures in MSWord"

Each TEST procedure comes with a brief explanation of what should result. For some of the TEST procedures you will need to have MSPaint and NotePad open to actually see that the clipboard is being loaded, cleared etc. Those TEST procedures that use Debug.Assert should run to completion with no interruptions. There is limited VBA help for Debug.Assert. Where one TEST procedure depends on another procedure, be wise and test the other procedure FIRST to convince yourself that that procedure is working before using it in another TEST procedure.

If you want to see how the procedures work, you can single-step through them in the normal manner.
Cheers, Chris

[adeel1]

Disk storage is extremely cheap nowadays, so I wouldn't worry about the space taken up by email messages.

Moreover, deleting email messages and keeping only a picture of them is a bad idea - you can easily search for text in email messages, but searching for text in pictures is very tedious.

i totally agreed sir, your and JOE point is very much strong and valid.
PIC has limitation for cropping and each person can be crop in different angle/Way and it also fixed in size and also cannot be go thorough bottom to top etc. for future investigation in case of query ect.
But i will raise this same with Line but till then i have to do it like this.
Adeel

[adeel1]

Hi Chris sir

thx i will get back to you
Adeel

[adeel1]

thx Chris for your idea/Suggestion!

i got solve my issue.

Take a pic from outlook and move that pic in excel and Export in folder...

Adeel