• Status: Solved
  • Priority: High
  • Security: Private
  • Views: 42
  • Last Modified:

How to modify this VBA code, VBA string cannot move to the new line

I had this question after viewing VBA challenge how can i change this VBA so that returned data is also in form of table.

i have this code below,  please see the body text of the email, i use  & vbCrLf &  & vbCrLf &  and yet the email text is not in the next line.  i mean after "Dear Focal Points of warehouses,"  there should be  new lines.  but now it is does not work.

Sub test()
    Dim ws As Worksheet, row As Integer
    
    With ThisWorkbook
    
        'Add a new worksheet
        Set ws = .Sheets("helper")
        ws.Cells.Clear
        ws.Cells(1, "A") = "Names"
        ws.Cells(1, "B") = "Street"
        ws.Cells(1, "C") = "SSN"
        ws.Cells(1, "D") = "PIN"
        row = 2
        
        Set ISONUMBER = .Worksheets("Sheet1").ListObjects("Table1")
        
        With ISONUMBER
            For Each rngCell In .DataBodyRange.Columns(1).Cells
                If rngCell(1, 3).Value & rngCell(1, 10).Value = "MatchedTrue" Then
                    ws.Cells(row, "A") = rngCell(1, 1).Value
                    ws.Cells(row, "B") = rngCell(1, 5).Value
                    ws.Cells(row, "C") = rngCell(1, 11).Value
                    ws.Cells(row, "D") = rngCell(1, 9).Value
                    row = row + 1
                End If
            Next rngCell
        End With
        
        ws.Columns("A:D").EntireColumn.AutoFit
        ws.UsedRange.Borders.LineStyle = xlContinuous
        
        SendMessage "youremail@yourdomain", , , "Subject is this one", "Dear Focal Points of warehouses,  & vbCrLf &  & vbCrLf &  Please see list of the stock report. please contact your customers and inform them on the updated delivery dates.  Your Sincerely , ws.UsedRange
    End With
End Sub

Function SendMessage(strTo As String, Optional strCC As String, Optional strBCC As String, Optional strSubject As String, Optional strMessage As String, Optional rngToCopy As Range, Optional strAttachmentPath As String, Optional blnShowEmailBodyWithoutSending As Boolean = False, Optional blnSignature As Boolean)
     
    Dim objOutlook As Object 'Outlook.Application
    Dim objOutlookMsg As Object 'Outlook.MailItem
    Dim objOutlookRecip As Object 'Outlook.Recipient
    Dim objOutlookAttach As Object 'Outlook.Attachment
    Dim lngLoop As Long
    Dim strSignature As String
     
    If Trim(strTo) & Trim(strCC) & Trim(strBCC) = "" Then
        MsgBox "Please provide a mailing address!", vbInformation + vbOKOnly, "Missing mail information"
        Exit Function
    End If
    
    'Create the Outlook session.
    On Error Resume Next
    Set objOutlook = GetObject(, "Outlook.Application." & Val(Application.Version))
    Err.Clear: On Error GoTo -1: On Error GoTo 0
    If objOutlook Is Nothing Then
        Set objOutlook = CreateObject("Outlook.Application." & Val(Application.Version))
    End If
     
    'Create the message.
    Set objOutlookMsg = objOutlook.CreateItem(0)


    With objOutlookMsg
        
        'Add the To recipient(s) to the message.
        For lngLoop = LBound(Split(strTo, ";")) To UBound(Split(strTo, ";"))
            If Trim(Split(strTo, ";")(lngLoop)) <> "" Then
                Set objOutlookRecip = .Recipients.Add(Trim(Split(strTo, ";")(lngLoop)))
                objOutlookRecip.Type = 1 'olTO
            End If
        Next lngLoop
         
        'Add the CC recipient(s) to the message.
        For lngLoop = LBound(Split(strCC, ";")) To UBound(Split(strCC, ";"))
            If Trim(Split(strCC, ";")(lngLoop)) <> "" Then
                Set objOutlookRecip = .Recipients.Add(Trim(Split(strCC, ";")(lngLoop)))
                objOutlookRecip.Type = 2 'olCC
            End If
        Next lngLoop
         
        'Add the BCC recipient(s) to the message.
        For lngLoop = LBound(Split(strBCC, ";")) To UBound(Split(strBCC, ";"))
            If Trim(Split(strBCC, ";")(lngLoop)) <> "" Then
                Set objOutlookRecip = .Recipients.Add(Trim(Split(strBCC, ";")(lngLoop)))
                objOutlookRecip.Type = 3 'olBCC
            End If
        Next lngLoop
         
        'Set the Subject, Body, and Importance of the message.
        If strSubject = "" Then
            strSubject = "This is an Automation test with Microsoft Outlook"
        End If
        .Subject = strSubject
        If strMessage = "" Then
            strMessage = "This is the body of the message." & vbCrLf & vbCrLf
        End If
        .Importance = 2 'High importance
        If Not strMessage = "" Then
            .Body = strMessage & vbCrLf & vbCrLf
        End If
        
        If Not rngToCopy Is Nothing Then
            .HTMLBody = .Body & RangetoHTML(rngToCopy)
        End If
         
        'Add attachments to the message.
        For lngLoop = LBound(Split(strAttachmentPath, "|")) To UBound(Split(strAttachmentPath, "|"))
        If Not strAttachmentPath = "" Then
            If Len(Dir(Trim(Split(strAttachmentPath, "|")(lngLoop)))) <> 0 Then
                Set objOutlookAttach = .Attachments.Add(Trim(Split(strAttachmentPath, "|")(lngLoop)))
            Else
                MsgBox "Unable to find the specified attachment '" & Trim(Split(strAttachmentPath, "|")(lngLoop)) & "'. Sending mail anyway."
            End If
        End If
        Next lngLoop
        
        If blnSignature Then
            'Win XP
            strSignature = Environ("USERPROFILE") & "\Application Data\Microsoft\Signatures\*.htm"
            strSignature = Environ("USERPROFILE") & "\Application Data\Microsoft\Signatures\" & Dir(strSignature)
            If Dir(strSignature) = "" Then
            'Win 7
                strSignature = Environ("USERPROFILE") & "\AppData\Roaming\Microsoft\Signatures\*.htm"
                strSignature = Environ("USERPROFILE") & "\AppData\Roaming\Microsoft\Signatures\" & Dir(strSignature)
            End If
        End If
         
        If Dir(strSignature) <> "" Then
            strSignature = GetBoiler(strSignature)
        Else
            strSignature = ""
        End If
        
        'MsgBox .htmlbody
        .HTMLBody = .HTMLBody & strSignature
            
        'Resolve each Recipient's name.
        For Each objOutlookRecip In .Recipients
            objOutlookRecip.Resolve
        Next
         
        'Should we display the message before sending?
        If blnShowEmailBodyWithoutSending Then
            .Display
        Else
            .Display
            .Save
            .Send
        End If
    End With
     
    Set objOutlook = Nothing
    Set objOutlookMsg = Nothing
    Set objOutlookAttach = Nothing
    Set objOutlookRecip = Nothing
     
End Function


Function RangetoHTML(rng As Range)


    'Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
    Dim strTempFile As String
    Dim wbkTemp As Workbook


    strTempFile = Environ$("temp") & Application.PathSeparator & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
 
    'Copy the range and create a workbook to receive the data.
    rng.Copy
    Set wbkTemp = Workbooks.Add(1)
    With wbkTemp.Sheets(1)
        With .Cells(1)
            .PasteSpecial Paste:=8
            .PasteSpecial xlPasteValues, , False, False
            .PasteSpecial xlPasteFormats, , False, False
            .Select
        End With
        Application.CutCopyMode = False
        On Error Resume Next
            .DrawingObjects.Visible = True
            .DrawingObjects.Delete
        Err.Clear: On Error GoTo 0
    End With
 
    'Publish the sheet to an .htm file.
    With wbkTemp.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=strTempFile, _
         Sheet:=wbkTemp.Sheets(1).Name, _
         Source:=wbkTemp.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
 
    'Read all data from the .htm file into the RangetoHTML subroutine.
    RangetoHTML = GetBoiler(strTempFile)
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
 
    'Close wbkTemp
    wbkTemp.Close savechanges:=False
 
    'Delete the htm file.
    Kill strTempFile
 
    Set wbkTemp = Nothing
    
End Function


Function GetBoiler(ByVal strFile As String) As String


    'May not be supported in MAC
    Dim objFSO As Object
    Dim objTextStream As Object
    On Error Resume Next
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objTextStream = objFSO.GetFile(strFile).OpenAsTextStream(1, -2)
    GetBoiler = objTextStream.ReadAll
    objTextStream.Close
    
    Set objFSO = Nothing
    Set objTextStream = Nothing
    
End Function

Open in new window

0
Flora
Asked:
Flora
  • 4
  • 2
1 Solution
 
Ryan ChongCommented:
since you are using HTMLBody property, the line break need to be in HTML as well.

hence, instead of vbCrLf , use "<br>"
0
 
Ryan ChongCommented:
and there's a error in your SendMessage command as you're sending test of vbCrLf as string but not value:

SendMessage "youremail@yourdomain", , , "Subject is this one", "Dear Focal Points of warehouses,  & vbCrLf &  & vbCrLf &  Please see list of the stock report. please contact your customers and inform them on the updated delivery dates.  Your Sincerely , ws.UsedRange"

you should use this instead:

SendMessage "youremail@yourdomain", , , "Subject is this one", "Dear Focal Points of warehouses," & vbCrLf & vbCrLf & "Please see list of the stock report. please contact your customers and inform them on the updated delivery dates.  Your Sincerely ", ws.UsedRange
0
 
Ryan ChongCommented:
so, based on my previous comment, try use "<br>" instead of vbCrLf , else you would need to do a replacement in your function: SendMessage, like:

If strMessage = "" Then
            strMessage = "This is the body of the message." & vbCrLf & vbCrLf
        End If
        .Importance = 2 'High importance
        If Not strMessage = "" Then
            .HTMLBody = Replace(strMessage, vbCrLf, "<br>")
        End If
        
        If Not rngToCopy Is Nothing Then
            .HTMLBody = .HTMLBody & RangetoHTML(rngToCopy)
        End If

Open in new window

0
Cloud Class® Course: CompTIA Healthcare IT Tech

This course will help prep you to earn the CompTIA Healthcare IT Technician certification showing that you have the knowledge and skills needed to succeed in installing, managing, and troubleshooting IT systems in medical and clinical settings.

 
FloraAuthor Commented:
thanks Ryan Chong

both options failed.  in the body of email. still shows all the text next to each other, there is no line break.
0
 
Ryan ChongCommented:
this works for me:

Sub test()
    Dim ws As Worksheet, row As Integer
    
    With ThisWorkbook
    
        'Add a new worksheet
        Set ws = .Sheets("helper")
        ws.Cells.Clear
        ws.Cells(1, "A") = "Names"
        ws.Cells(1, "B") = "Street"
        ws.Cells(1, "C") = "SSN"
        ws.Cells(1, "D") = "PIN"
        row = 2
        
        Set ISONUMBER = .Worksheets("Sheet1").ListObjects("Table1")
        
        With ISONUMBER
            For Each rngCell In .DataBodyRange.Columns(1).Cells
                If rngCell(1, 3).Value & rngCell(1, 10).Value = "MatchedTrue" Then
                    ws.Cells(row, "A") = rngCell(1, 1).Value
                    ws.Cells(row, "B") = rngCell(1, 5).Value
                    ws.Cells(row, "C") = rngCell(1, 11).Value
                    ws.Cells(row, "D") = rngCell(1, 9).Value
                    row = row + 1
                End If
            Next rngCell
        End With
        
        ws.Columns("A:D").EntireColumn.AutoFit
        ws.UsedRange.Borders.LineStyle = xlContinuous
        
        SendMessage "youremail@yourdomain", , , "Subject is this one", "Dear Focal Points of warehouses," & vbCrLf & vbCrLf & "Please see list of the stock report. please contact your customers and inform them on the updated delivery dates.  Your Sincerely ", ws.UsedRange
    End With
End Sub

Function SendMessage(strTo As String, Optional strCC As String, Optional strBCC As String, Optional strSubject As String, Optional strMessage As String, Optional rngToCopy As Range, Optional strAttachmentPath As String, Optional blnShowEmailBodyWithoutSending As Boolean = False, Optional blnSignature As Boolean)
     
    Dim objOutlook As Object 'Outlook.Application
    Dim objOutlookMsg As Object 'Outlook.MailItem
    Dim objOutlookRecip As Object 'Outlook.Recipient
    Dim objOutlookAttach As Object 'Outlook.Attachment
    Dim lngLoop As Long
    Dim strSignature As String
     
    If Trim(strTo) & Trim(strCC) & Trim(strBCC) = "" Then
        MsgBox "Please provide a mailing address!", vbInformation + vbOKOnly, "Missing mail information"
        Exit Function
    End If
    
    'Create the Outlook session.
    On Error Resume Next
    Set objOutlook = GetObject(, "Outlook.Application." & Val(Application.Version))
    Err.Clear: On Error GoTo -1: On Error GoTo 0
    If objOutlook Is Nothing Then
        Set objOutlook = CreateObject("Outlook.Application." & Val(Application.Version))
    End If
     
    'Create the message.
    Set objOutlookMsg = objOutlook.CreateItem(0)


    With objOutlookMsg
        
        'Add the To recipient(s) to the message.
        For lngLoop = LBound(Split(strTo, ";")) To UBound(Split(strTo, ";"))
            If Trim(Split(strTo, ";")(lngLoop)) <> "" Then
                Set objOutlookRecip = .Recipients.Add(Trim(Split(strTo, ";")(lngLoop)))
                objOutlookRecip.Type = 1 'olTO
            End If
        Next lngLoop
         
        'Add the CC recipient(s) to the message.
        For lngLoop = LBound(Split(strCC, ";")) To UBound(Split(strCC, ";"))
            If Trim(Split(strCC, ";")(lngLoop)) <> "" Then
                Set objOutlookRecip = .Recipients.Add(Trim(Split(strCC, ";")(lngLoop)))
                objOutlookRecip.Type = 2 'olCC
            End If
        Next lngLoop
         
        'Add the BCC recipient(s) to the message.
        For lngLoop = LBound(Split(strBCC, ";")) To UBound(Split(strBCC, ";"))
            If Trim(Split(strBCC, ";")(lngLoop)) <> "" Then
                Set objOutlookRecip = .Recipients.Add(Trim(Split(strBCC, ";")(lngLoop)))
                objOutlookRecip.Type = 3 'olBCC
            End If
        Next lngLoop
         
        'Set the Subject, Body, and Importance of the message.
        If strSubject = "" Then
            strSubject = "This is an Automation test with Microsoft Outlook"
        End If
        .Subject = strSubject
        If strMessage = "" Then
            strMessage = "This is the body of the message." & vbCrLf & vbCrLf
        End If
        .Importance = 2 'High importance
        If Not strMessage = "" Then
            .HTMLBody = Replace(strMessage, vbCrLf, "<br>")
        End If
        
        If Not rngToCopy Is Nothing Then
            .HTMLBody = .HTMLBody & RangetoHTML(rngToCopy)
        End If
         
        'Add attachments to the message.
        For lngLoop = LBound(Split(strAttachmentPath, "|")) To UBound(Split(strAttachmentPath, "|"))
        If Not strAttachmentPath = "" Then
            If Len(Dir(Trim(Split(strAttachmentPath, "|")(lngLoop)))) <> 0 Then
                Set objOutlookAttach = .Attachments.Add(Trim(Split(strAttachmentPath, "|")(lngLoop)))
            Else
                MsgBox "Unable to find the specified attachment '" & Trim(Split(strAttachmentPath, "|")(lngLoop)) & "'. Sending mail anyway."
            End If
        End If
        Next lngLoop
        
        If blnSignature Then
            'Win XP
            strSignature = Environ("USERPROFILE") & "\Application Data\Microsoft\Signatures\*.htm"
            strSignature = Environ("USERPROFILE") & "\Application Data\Microsoft\Signatures\" & Dir(strSignature)
            If Dir(strSignature) = "" Then
            'Win 7
                strSignature = Environ("USERPROFILE") & "\AppData\Roaming\Microsoft\Signatures\*.htm"
                strSignature = Environ("USERPROFILE") & "\AppData\Roaming\Microsoft\Signatures\" & Dir(strSignature)
            End If
        End If
         
        If Dir(strSignature) <> "" Then
            strSignature = GetBoiler(strSignature)
        Else
            strSignature = ""
        End If
        
        'MsgBox .htmlbody
        .HTMLBody = .HTMLBody & strSignature
            
        'Resolve each Recipient's name.
        For Each objOutlookRecip In .Recipients
            objOutlookRecip.Resolve
        Next
         
        'Should we display the message before sending?
        If blnShowEmailBodyWithoutSending Then
            .Display
        Else
            .Display
            .Save
            .Send
        End If
    End With
     
    Set objOutlook = Nothing
    Set objOutlookMsg = Nothing
    Set objOutlookAttach = Nothing
    Set objOutlookRecip = Nothing
     
End Function


Function RangetoHTML(rng As Range)


    'Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
    Dim strTempFile As String
    Dim wbkTemp As Workbook


    strTempFile = Environ$("temp") & Application.PathSeparator & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
 
    'Copy the range and create a workbook to receive the data.
    rng.Copy
    Set wbkTemp = Workbooks.Add(1)
    With wbkTemp.Sheets(1)
        With .Cells(1)
            .PasteSpecial Paste:=8
            .PasteSpecial xlPasteValues, , False, False
            .PasteSpecial xlPasteFormats, , False, False
            .Select
        End With
        Application.CutCopyMode = False
        On Error Resume Next
            .DrawingObjects.Visible = True
            .DrawingObjects.Delete
        Err.Clear: On Error GoTo 0
    End With
 
    'Publish the sheet to an .htm file.
    With wbkTemp.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=strTempFile, _
         Sheet:=wbkTemp.Sheets(1).Name, _
         Source:=wbkTemp.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
 
    'Read all data from the .htm file into the RangetoHTML subroutine.
    RangetoHTML = GetBoiler(strTempFile)
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
    
    'Close wbkTemp
    wbkTemp.Close savechanges:=False
 
    'Delete the htm file.
    Kill strTempFile
 
    Set wbkTemp = Nothing
    
End Function


Function GetBoiler(ByVal strFile As String) As String


    'May not be supported in MAC
    Dim objFSO As Object
    Dim objTextStream As Object
    On Error Resume Next
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objTextStream = objFSO.GetFile(strFile).OpenAsTextStream(1, -2)
    GetBoiler = objTextStream.ReadAll
    objTextStream.Close
    
    Set objFSO = Nothing
    Set objTextStream = Nothing
    
End Function

Open in new window


SnapShot.png
0
 
FloraAuthor Commented:
Thanks it worked now
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

Join & Write a Comment

Featured Post

Free Tool: Port Scanner

Check which ports are open to the outside world. Helps make sure that your firewall rules are working as intended.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

  • 4
  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now