Results 1 to 2 of 2

Thread: Copy the text in textboxes into an email
Thanks Thanks: 0 Likes Likes: 0

  1. #1
    Board Regular
    Join Date
    Feb 2018
    Location
    Midlands, UK
    Posts
    908
    Post Thanks / Like
    Mentioned
    1 Post(s)
    Tagged
    0 Thread(s)

    Default Copy the text in textboxes into an email

    HI Good moring, please can you help me, i have the code below where it is copying a range of cells A5:K24 into an email, but hovering over some of these cells are text boxes, please see screen shot below where the big white spaces are i have 2 textboxes in each where text is typed into, please can you help me to add this into my email, i have the code below where it copies all the cells into an email but not the text in the textboxes. the white space next to Liverpool and Warrington for example there is TextBox1 and TextBox2. i hope you can help.
    <!--[if gte mso 9]><xml> <o:OfficeDocumentSettings> <o:AllowPNG/> </o:OfficeDocumentSettings> </xml><![endif]-->
    HTML Code:
    Sub Mail_Selection_Range_Outlook_Body()
    
        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)
    
        Set rng = Sheets("Central").Range("A5:K24").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 = ThisWorkbook.Sheets("Email Links").Range("C2").Value
            .CC = ""
            .BCC = ""
            .Subject = "This is the Subject line"
            .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
    Last edited by Patriot2879; Mar 12th, 2019 at 04:42 AM.

  2. #2
    Board Regular
    Join Date
    Jul 2009
    Posts
    1,672
    Post Thanks / Like
    Mentioned
    3 Post(s)
    Tagged
    5 Thread(s)

    Default Re: Copy the text in textboxes into an email

    Hi,

    I can't see any characters in your worksheet.

    You can add the content of the Text Boxes after the range is added using:
    change Sheet name as required

    Code:
    .HTMLBody =RangetoHTML(rng) & vbNewLine & Worksheets("Sheet1").TextBox1.Value & vbNewLine & Worksheets("Sheet1").TextBox2.Value
    Last edited by daverunt; Mar 12th, 2019 at 12:26 PM.

Some videos you may like

User Tag List

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

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