VBA Copy Screen Shot of Excel Sheet into Email and Send

[ghost5]

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

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]

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

Sub Mail_Selection_Range_Outlook_Body()
'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
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object

    Set rng = Nothing
    On Error Resume Next
    'Only the visible cells in the selection
    'Set rng = Selection.SpecialCells(xlCellTypeVisible)
    '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   'or use .Display
    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)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

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

    'Copy the range and create a new workbook to past the data in
    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

    'Publish the sheet to a htm file
    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

    'Read all data from the htm file into RangetoHTML
    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=")

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

 

[ghost5]

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