Results 1 to 4 of 4
  1. #1
    Join Date
    Feb 2012
    Posts
    3

    Unanswered: Sending an email with VBA

    Dear All, I have been trying to work out how to send an email from the click of a button/image in excel, using a macro that creates the email and sends it ...

    Other forums have given me help, but don't seem to come up with anyting conclusive. the current code I have been given to use is below.

    Other issues include, adding a from address automatically, creating the body of the email as a sheet in the workbook.

    Any help is greatly appreciated...

    Code:
    Private Sub cmdSendEmail_Click()
        Dim Email_Subject As String, Email_Send_To As String
        Dim Mail_Object As Object, Mail_Single As Object
        Dim rng As Range
        
        Email_Subject = "Freight Quote Request"
        Email_Send_To = EmailBuild.Emailbox2.Text
        Email_Send_From = "userbf@mrexcel.com"
        
        On Error GoTo debugs
        Set rng = Sheet12.Range("A1:J49")
        Set Mail_Object = CreateObject("Outlook.Application")
        Set Mail_Single = Mail_Object.CreateItem(0)
        With Mail_Single
            .Subject = Email_Subject
            .To = Email_Send_To
            .From = Email_Send_From
            .HTMLBody = RangetoHTML(rng)
            .Send
        End With
    debugs:
    If Err.Description <> "" Then MsgBox Err.Description
    End Sub
    Function RangetoHTML(rng As Range)
    ' Changed by Ron de Bruin 28-Oct-2006
    ' Working in Office 2000-2010
        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=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

  2. #2
    Join Date
    Jan 2007
    Location
    UK
    Posts
    11,434
    Provided Answers: 10
    This example is in MS Access which also uses VBA: http://www.dbforums.com/microsoft-ac...ml#post6296492

    Have a play with that - it should do what you need.
    George
    Home | Blog

  3. #3
    Join Date
    Feb 2012
    Posts
    3
    Thanks George,

    unfortunately I don't have Access, could you copy the code onto a reply for me please? I currently cannot view it

  4. #4
    Join Date
    Feb 2012
    Posts
    3
    This code runs straight through, while pressing F8 until end Function where it says mismatch, but won't show me where. anymore ideas?!?!

    Really grateful for any help at this point


    Code:
    Sub Emailsend()
        Dim Email_Subject As String, Email_Send_To As String
        Dim Mail_Object As Object, Mail_Single As Object
        Dim rng As Range
        
        Email_Subject = "Freight Quote Request"
        Email_Send_To = Sheet1.TextBox3.Text
        
        Set rng = Sheets("Price").Range("A1:I9")
        Set Mail_Object = CreateObject("Outlook.Application")
        Set Mail_Single = Mail_Object.CreateItem(0)
        With Mail_Single
            .Subject = Email_Subject
            .To = Email_Send_To
            .HtmlBody = RangetoHTML(rng)
            .Send
        End With
    End Sub
    Function RangetoHTML(rng As Range)
    ' Changed by Ron de Bruin 28-Oct-2006
    ' Working in Office 2000-2010
        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 = Sheet1.Range("A1:I9")
     
        '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

Posting Permissions

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