How to take screenshot of a web page, and paste it in the body of a new email?

Question

I would like to take a screenshot of a webpage and paste it in the body of a new email.

I found a post with something similar but instead of attaching a screenshot in the body, it attaches a file.

The code doesn't work for me (I probably didn't paste it correctly or in the right order). How do I rewrite the code and where should it be pasted on a new module?

Base code for Outlook:

Sub test_Prateek_Narendra()
Dim FilePath As String
Dim objMsg As Object
FilePath = StoreScreenShotFrom_As("www.google.com", "TestScrenShot", "jpg")

Set objMsg = Application.CreateItem(0) 'olMailItem = 0
With objMsg
    .To = "email@email.com"
    .Subject = "Test Subject"
    .Attachments.Add FilePath
    .Display
End With 'objMsg
End Sub

The function to take the screenshot (in full-screen) and save it as a file:

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#If VBA7 Then
Declare PtrSafe Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, 
ByVal dwFlags As LongLong, ByVal dwExtraInfo As LongPtr)
#Else
Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal 
dwFlags As Long, ByVal dwExtraInfo As Long)
#End If
Private Const VK_SNAPSHOT As Byte = 44

Public Function StoreScreenShotFrom_As(URL_Dest As String, Img_Name As String, 
Img_Type As String)
Dim IE As Object, IECaption As String
Dim aXL As Object, aWB As Object, aSh As Object, aChO As Object, Img_Path As String
Img_Path = VBA.Environ$("temp") & "\" & Img_Name & "." & Img_Type

Set IE = CreateObject("InternetExplorer.Application")
With IE
    .Visible = True
    .FullScreen = True
    .Navigate URL_Dest

    '''Possibilities to wait until the page is loaded
        'Do While .Busy Or .readyState <> 4
        '    DoEvents
        'Loop
    '''OR
        'Sleep 5000
    '''OR (custom sub below)
        WasteTime 5

    '''Take a snapshot
    Call keybd_event(VK_SNAPSHOT, 0, 0, 0)
    DoEvents
    .Quit
End With 'IE

'''Start Excel
Set aXL = CreateObject("Excel.Application")
On Error Resume Next
    With aXL
        .WindowState = -4143 'xlNormal
        .Top = 1
        .Left = 1
        .Height = .UsableHeight
        .Width = .UsableWidth
        .WindowState = -4137  'xlMaximized
On Error GoTo 0
        Set aWB = .Workbooks.Add
        Set aSh = aWB.Sheets(1)
        Set aChO = aSh.ChartObjects.Add(0, 0, .Width, .Height)
    End With 'aXL

With aChO
    .Activate
    .Chart.Paste
    With .ShapeRange
        .Line.Visible = msoFalse
        .Fill.Visible = msoFalse
    End With '.ShapeRange
    With .Chart
        .Export FileName:=Img_Path, Filtername:=Img_Type, Interactive:=False
    End With '.Chart
    DoEvents
    .Delete
End With 'oChrtO
aWB.Close False
DoEvents
aXL.Quit

StoreScreenShotFrom_As = Img_Path
End Function

Private Sub WasteTime(SecondsToWait As Long)
Dim TimeLater As Date
TimeLater = DateAdd("s", SecondsToWait, Now)
Do While Now < TimeLater
    DoEvents
Loop
End Sub

Answer 1

simply raw pasting without formating below. but it works only if you have printscreen button without function button. i think sendkeys can't simulate fn button and there is no simple method for it.

Sub test_Prateek_Narendra()
    Dim objMsg As Object
    Dim wdDoc As Object     '## Word.Document
    Dim wdRange As Object   '## Word.Range
    
    Set objMsg = Application.CreateItem(0) 'olMailItem = 0
    
    SendKeys "{PRTSC}"  '   if you dont have printscreen in function button
    '   you cant simulate function key
    
    With objMsg
        .To = "email@email.com"
        .subject = "Test Subject"
        .HTMLBody PasteSpecial
        .Display
        Set wdDoc = objMsg.GetInspector.WordEditor
        Set wdRange = wdDoc.Range(0, 0)
        wdRange.InsertAfter vbCrLf & vbCrLf
        wdRange.Paste
    End With 'objMsg
End Sub