VBA transfer userform data to Email Body

[DanSMT]

Hi,

Im having trouble trying to pull data from a userform into an email body. See below for code.

Dim aOutlook As Object
Dim aEmail As Object
Dim rngeAddresses As Range, rngeCell As Range, strRecipients As String

    If UserForm1.failtb.Value > UserForm1.RejectTB.Value Then
    'If ActiveWorkbook.Path <> "" Then

Set aOutlook = CreateObject("Outlook.Application")
Set aEmail = aOutlook.CreateItem(0)

'set Importance
aEmail.Importance = 2
'Set Subject
aEmail.Subject = "TestMailSend"
'Set Body for mail
aEmail.Body = "Test" & UserForm1.dat1.Value & Chr(10) & _
              "Test 2" & UserForm1.CommentsTB.Value & Chr(10) & _
              "Revenue" & UserForm1.ListBox3.Value


'send one off to 1 person use this static code
'aEmail.Recipients.Add "E-mail.address-here@ntlworld.com"
aEmail.Recipients.Add "dans@teamsmt.local"
'Send Mail
aEmail.Send

aemail.body section is not pulling anything from the userform.

Any ideas?

 

[ranman256]

in the userform, SEND button, to send the text boxes like:

sub btnSend_Click()
   vTo =  txtTO
  vSubj= txtSubject
  vBody = txtBox1  & vbcrlf & txtBox2
   Send1Email vTo, vSubj, vBody
end sub

the form sends the data to the email routine:

Public Function Send1Email(ByVal pvTo, ByVal pvSubj, ByVal pvBody, Optional ByVal pvFile) As Boolean
Dim oApp As Outlook.Application
Dim oMail As Outlook.MailItem
On Error GoTo ErrMail
'NOTE : YOU MUST HAVE THE OUTLOOK REFERENCE CHECKED IN VBE; Alt-F11, menu,tools, references, Microsoft Outlook XX Object library
Set oApp = CreateObject("Outlook.Application")  'not this
''Set oApp = GetApplication("Outlook.Application")  'it may be open already so use this
Set oMail = oApp.CreateItem(olMailItem)
With oMail
    .To = pvTo
    .Subject = pvSubj
    If Not IsMissing(pvFile) Then .Attachments.Add pvFile, olByValue, 1
  
    .HTMLBody = pvBody
    'If Not IsNull(pvBody) Then .Body = pvBody
  
    .Display True   'show user but dont send yet
    '.Send          'send now
End With
Send1Email = True
endit:
Set oMail = Nothing
Set oApp = Nothing
Exit Function
ErrMail:
MsgBox Err.Description, vbCritical, Err
Resume endit
End Function

 

[DanSMT]

Are you implying that it is not possible to transfer data and send the email all in one operation?

I'm trying to have a single click complete the task. The operation is also doing many other things, this is just a closing feature to submit an email notice.

 

[DanSMT]

Im struggling with a single line of code, everything else appears to be working as intended.

Dim aOutlook As Object
Dim aEmail As Object
Dim rngeAddresses As Range, rngeCell As Range, strRecipients As String

    If UserForm1.failtb.Value > UserForm1.RejectTB.Value Then
    'If ActiveWorkbook.Path <> "" Then

Set aOutlook = CreateObject("Outlook.Application")
Set aEmail = aOutlook.CreateItem(0)

'set Importance
aEmail.Importance = 2
'Set Subject
aEmail.Subject = "TestMailSend"
'Set Body for mail
aEmail.Body = "Test - " & UserForm1.dat1.Value & vbCrLf & _
              "Test 2 - " & UserForm1.CommentsTB.Value & vbCrLf & _
              "Revenue - " & UserForm1.FailData.Column(1, 1)

'send one off to 1 person use this static code
aEmail.Recipients.Add "dans@teamsmt.local"
'Send Mail
aEmail.Send

The code below is not pulling anything.

              "Revenue - " & UserForm1.FailData.Column(1, 1)

 

[DanSMT]

I did quite a bit of searching to finally come to a conclusion.

First of all Outlook 16.0 Object Library Reference needs to be turned on in references.

Then a large function needs to be added in the program.

Function ListToHTML(lst As Object, Optional Ordered = False) As String
    Dim strHTML As String
    Dim strCloseTag As String
    Dim strOpenTag As String
    Dim arrItemList As Variant
    Dim cnt As Long
    Dim idx As Long

    ReDim arrItemList(1 To lst.ListCount)
    
    strOpenTag = Chr(60)
    strCloseTag = Chr(62)
    
    If Ordered Then
        strHTML = strOpenTag & "ol" & strCloseTag & "{content}" & strOpenTag & "/ol" & strCloseTag
    Else
        strHTML = strOpenTag & "ul" & strCloseTag & "{content}" & strOpenTag & "/ul" & strCloseTag
    End If
    
    For idx = 0 To lst.ListCount - 1
        'If lst.Selected(idx) Then
             cnt = cnt + 1
             arrItemList(cnt) = strOpenTag & "li" & strCloseTag & lst.List(idx) & strOpenTag & "/li" & strCloseTag
        'End If
    Next idx
    
    If cnt = 1 Then
        strHTML = Replace(strHTML, "{content}", arrItemList(cnt))
    ElseIf cnt > 1 Then
        ReDim Preserve arrItemList(1 To cnt)
        strHTML = Replace(strHTML, "{content}", Join(arrItemList))
    End If

    ListToHTML = strHTML
    
End Function

This converts the listbox to HTML data allowing it to transfer to the email.

Once this is added just convert the .body of the email text to the following (altering to suit)

.HTMLBody = "<HTML><BODY>" & "The following part(s) have failed the RI process.<br><br><br>" & Replace(dat1.Text, vbLf, "<br><br>") & _
                    ListToHTML(FailData) & "<br><br>" & "Comments:" & "<br>" & CommentsTB.Value & "<br><br>" & "Please review the RI documentation and provide disposition." & "<br><br><br>" & _
                    "Regards" & "<br><br>" & "Receiving Inspection" & "</BODY></HTML>"