Take screenshot of userform and paste into email body

johnsonk

Board Regular
Joined
Feb 4, 2019
Messages
166
Hi,
I am try to paste a screenshot of a userform in to an email body but can not get it work could some take a look at my code and see if I have missed something.

VBA Code:
Dim OutApp As Object

Dim OutMail As Object


'Shift-Print Screen

Application.SendKeys "(%{1068})"


DoEvents


On Error Resume Next


'Prepare the email

Set OutApp = CreateObject("Outlook.Application")

OutApp.Session.Logon

Set OutMail = OutApp.CreateItem(0)


On Error Resume Next


With OutMail

.To = "myemail.co.uk"

.Subject = "TEST"


Application.SendKeys "(^v)"

.Send


End With

On Error GoTo 0


OutApp.Session.Logoff

Set OutMail = Nothing

Set OutApp = Nothing

Regards

Also posted on Ozgrid:
 

Some videos you may like

Excel Facts

Excel motto
Not everything I do at work revolves around Excel. Only the fun parts.

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
6,465
Try this code, calling the Screenshot_Active_Window_Send_Outlook_Email routine from your userform code.

VBA Code:
Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
    Private Declare PtrSafe Function MapVirtualKey Lib "user32" Alias "MapVirtualKeyA" (ByVal wCode As Long, ByVal wMapType As Long) As Long
#Else
    Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
    Private Declare Function MapVirtualKey Lib "user32" Alias "MapVirtualKeyA" (ByVal wCode As Long, ByVal wMapType As Long) As Long
#End If

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


Public Sub Screenshot_Active_Window_Send_Outlook_Email()

    Dim OutApp As Object
    Dim OutMail As Object
    Dim OutInsp As Object
    Dim wdDoc As Object
    Dim OutRng As Object
   
    'Capture active window to clipboard
   
    AltPrintScreen
   
    On Error Resume Next
    Set OutApp = GetObject(, "Outlook.Application")
    If Err <> 0 Then Set OutApp = CreateObject("Outlook.Application")
    On Error GoTo 0
   
    'Create and send Outlook email with clipboard pasted
   
    Set OutMail = OutApp.CreateItem(0)
   
    With OutMail
       
        .To = "email@address.com"
        .CC = ""
        .BCC = ""
        .Subject = Time & " Userform screenshot"
       
        Set OutInsp = .GetInspector
        Set wdDoc = OutInsp.WordEditor
        Set OutRng = wdDoc.Range
        OutRng.Collapse 1
        OutRng.Paste
       
        .Display
        DoEvents
        .Send
           
    End With
  
    Set OutMail = Nothing
    Set OutApp = Nothing
    Set OutInsp = Nothing
    Set wdDoc = Nothing
    Set OutRng = Nothing
   
End Sub
 

johnsonk

Board Regular
Joined
Feb 4, 2019
Messages
166
John,

I have a working code for the email from the site ozgrid but I would like to thank you for your time in providing the code.

Regards
 

Watch MrExcel Video

Forum statistics

Threads
1,114,278
Messages
5,546,939
Members
410,764
Latest member
Dedeke
Top