VBA Copy Screen Shot of Excel Sheet into Email and Send

ghost5

New Member
Joined
Sep 28, 2017
Messages
2
I am not the nest with VBA so I have searched around the internet and come up with the following code that allows a user to press a button, a screen shot of the worksheet captured which is then pasted into an Outlook message which can then be sent to myself. This is being used for training and a record of this training.

It works 95% of the time but I have two problems with this
1) The VBA that I have seems to have been created for graphs. Not always but sometimes, a graph will appear in the screenshot even though there is no graph within the excel sheet. Sometimes this completely overwrites the worksheet and sometimes it only appears slightly but messes with the formatting. A screenshot of this is shown at https://screenshot.net/eyqo4t1
2) I have tested this worksheet successfully on three out of four PCs. The one PC that it did not work on, it only took a plain white screen shot (showing nothing). This PC is using Office 2016 whereas the others, including mine, use 2013. I need this to work on both versions of Office.

Below is my code

Code:
Private Sub cmdMainMenu_Click()


frmMainMenu.Show


End Sub


Private Sub cmdEmail_Click()


'Application.ScreenUpdating = False     ' this stops new chart from being displayed all the time - this seems to produce a white screen


Dim oRange As Range
Dim oCht As Chart
Dim oImg As Picture


Set oRange = Range("A1:P34")
Set oCht = Charts.Add


oRange.CopyPicture xlScreen, xlPicture
oCht.Paste
oCht.Export Filename:="C:\_Training\_System\Completed_Module.jpg", Filtername:="JPG"


    Application.DisplayAlerts = False     ' turns prompts off so that chart is deleted automatically; no user prompt
    oCht.Delete
    Application.DisplayAlerts = True     ' turns prompts back on
    
    MsgBox "Images have been created.     ", vbInformation     'messagebox with text and OK-button


Application.ScreenUpdating = True     ' this turns screen updating back on.
'ActiveSheet.Protect       ' place at end of code


Screenshot_Mail "me@emailaddress.co.uk" & "; " & "", "" & _
 "; " & "" & "; " & "", Range("R1"), "[COLOR=red]" & _
"[I]" & "Below is a Snapshot View of the Training Completed:  " & "[/I][/COLOR][I]" & "[/I]" & _
"
" & "
" & "******>[FONT=Arial][SIZE=2][COLOR=#000080][/COLOR][/SIZE][/FONT]" & _
"[IMG]https://www.mrexcel.com/forum/_Training\_System\Completed_Module.jpg[/IMG] "






End Sub


Private Sub cmdPrint_Click()




Worksheets("Printable_Version").Activate


Dim sh As Worksheet
Dim rngPrint As Range
Set sh = ActiveSheet
Set rngPrint = ActiveCell.CurrentRegion
With sh.PageSetup
    .Orientation = xlLandscape
    .Zoom = False
    .FitToPagesTall = 1
    .FitToPagesWide = 1
End With
rngPrint.PrintPreview




'Worksheets("Printable_Version").PrintPreview


'Worksheets("Printable_Version").PrintPreview
'Sheets("Printable_Version").PrintOut




End Sub
Can someone help with any tweaks or amendments that I can make to this to try to stop these problems?

Thanks
 

CalcSux78

Well-known Member
Joined
Oct 15, 2013
Messages
1,120
Re: Help: VBA Copy Screen Shot of Excel Sheet into Email and Send

Ron DeBruin has an awesome blog on sending email via excel.. Note: might run into issues if Excel and Outlook are not the same version

Code:
<!--StartFragment-->Sub Mail_Selection_Range_Outlook_Body()
[COLOR=black]'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Don't forget to copy the function RangetoHTML in the module.
'Working in Excel 2000-2016[/COLOR]
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object

    Set rng = Nothing
    On Error Resume Next
    [COLOR=black]'Only the visible cells in the selection[/COLOR]
    [COLOR=#000000]'Set rng = Selection.SpecialCells(xlCellTypeVisible)[/COLOR]
    'You can also use a fixed range if you want
    Set rng = Range("A1:P34").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
               vbNewLine & "please correct and try again.", vbOKOnly
        Exit Sub
    End If

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
    With OutMail
        .To = "ron@debruin.nl"
        .CC = ""
        .BCC = ""
        .Subject = "This is the Subject line"
        .HTMLBody = "Below is a Snapshot View of the Training Completed:" & "<.br><.br>" & RangetoHTML(rng)  'Remove the dots in the "br" portion of the string
        .Send   [COLOR=black]'or use .Display[/COLOR]
    End With
    On Error GoTo 0

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub


Function RangetoHTML(rng As Range)
[COLOR=black]' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
    Dim fso As Object[/COLOR]
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    [COLOR=black]'Copy the range and create a new workbook to past the data in[/COLOR]
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

    [COLOR=black]'Publish the sheet to a htm file[/COLOR]
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    [COLOR=black]'Read all data from the htm file into RangetoHTML[/COLOR]
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")

    [COLOR=black]'Close TempWB[/COLOR]
    TempWB.Close savechanges:=False

    [COLOR=black]'Delete the htm file we used in this function[/COLOR]
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function<!--EndFragment-->
 

ghost5

New Member
Joined
Sep 28, 2017
Messages
2
Re: Help: VBA Copy Screen Shot of Excel Sheet into Email and Send

Thank you very much for this - it is easily laid out for me to be able to follow the basics of it and it works well across all computers
 

Forum statistics

Threads
1,085,838
Messages
5,386,265
Members
401,989
Latest member
romandavis

Some videos you may like

This Week's Hot Topics

Top