Consulting

Results 1 to 4 of 4

Thread: VBA command button to auto generate outlook email

  1. #1

    VBA command button to auto generate outlook email

    Good evening Everyone,

    Big thank you to everyone on this forum! The Knowledge on here has been a big help so far.

    I'm using Excel for Office 365 MSO (16.0.11629.20238)64-bit

    I have been using this code to automatically generate an email through outlook to send a designated range of cells

    Sub Button3_Click()
        Dim rng As Range
        Dim OutApp As Object
        Dim OutMail As Object
    
        Set rng = Nothing
        On Error Resume Next
        Set rng = Sheets("1st").Range("A1:U38").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 = ""
            .CC = ""
            .BCC = ""
            .Subject = Range("V1")
            .HTMLBody = RangetoHTML(rng)
            .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)
        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"
        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
        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
        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=")
        TempWB.Close savechanges:=False
        Kill TempFile
        Set ts = Nothing
        Set fso = Nothing
        Set TempWB = Nothing
    End Function
    The code works fine but unfortunately the 2 charts I have in the designated cell range do not get generated in outlook with the cells when the email is created. Is there anyway I can get around this? Or do I need a code that generates the charts in outlook? File attached.

    Thank for your time and help!
    Attached Files Attached Files

  2. #2
    VBAX Mentor Logit's Avatar
    Joined
    Sep 2016
    Posts
    423
    Location
    .
    See if this project can help in some manner :

    
    Sub mailchart()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim vInspector, GetInspector, wEditor As Variant
    
    
    
    
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    With OutMail
        .To = "yo momma@nowhere.com"
        .CC = "xyz@anc.com"
        .BCC = "abc@xyz.com"
        .Subject = "Test"
        .Body = "Dear" & "Macro " & vbCrLf
        .Display
        ActiveSheet.Range("B4:R21").Copy
        Set vInspector = OutMail.GetInspector
        Set wEditor = vInspector.WordEditor
    
    
        wEditor.Application.Selection.Start = Len(.Body)
        wEditor.Application.Selection.End = wEditor.Application.Selection.Start
    
    
        wEditor.Application.Selection.Paste
    
    
    .Display
    End With
    End Sub
    Attached Files Attached Files

  3. #3
    Thank you very much that's perfect!

  4. #4
    VBAX Mentor Logit's Avatar
    Joined
    Sep 2016
    Posts
    423
    Location
    .
    You are welcome. Hope it all works out.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •