Email Body

V

vmjan02

Well-known Member
Joined
Aug 15, 2012
Messages
1,132
Office Version
  1. 365
  2. 2021
  3. 2019
  4. 2016
  5. 2013
I have this code and is all perfect and running very smoothly, just need a change so that after body the copy past so be done. currently it is doing but copy pasting is over writing the text.
Any solution.

VBA Code: 
Sub EmailBodyENOCFixed()
    Dim outlookApp As Object
    Dim outlookMail As Object
    Dim ws As Worksheet
    Dim rng As Range
    Dim pic As Object
    
    Windows("Hourly Pending Tickets V1.xlsm").Activate

    Sheets("Pending Tickets with ENOC Fixed").Select
    
    
    Set ws = ThisWorkbook.Sheets("Pending Tickets with ENOC Fixed")

    
    Set rng = ws.UsedRange

    
    If Not rng Is Nothing Then
        
        Set outlookApp = CreateObject("Outlook.Application")
        Set outlookMail = outlookApp.CreateItem(0)

        
        With outlookMail
            .Body = Sheets("Email").Range("C7").Value
            .To = Sheets("Email").Range("C2").Value
            .CC = Sheets("Email").Range("C3").Value
            .BCC = Sheets("Email").Range("C4").Value
            .Subject = Sheets("Email").Range("C5").Value
            
        End With

        
        rng.CopyPicture xlScreen, xlBitmap

        outlookMail.GetInspector.WordEditor.Range.Paste

        
        On Error Resume Next
        Set pic = outlookMail.GetInspector.WordEditor.Range.InlineShapes(1)
        On Error GoTo 0

        If pic Is Nothing Then
            On Error Resume Next
            Set pic = outlookMail.GetInspector.WordEditor.Range.Shapes(1)
            On Error GoTo 0
        End If

        
        If Not pic Is Nothing Then
            pic.LockAspectRatio = msoFalse
            'pic.Height = 700
            'pic.Width = 1800
            
            pic.Height = rng.Height * 1
            pic.Width = rng.Width * 1
            
            
        Else
            MsgBox "Unable to find the pasted picture.", vbExclamation
        End If

        
        outlookMail.Display
        
        Application.Wait (Now + TimeValue("0:00:03"))
        
      '  outlookMail.Send
    Else
        MsgBox "No used cells in the specified range", vbInformation
    End If
End Sub
 

Excel Facts

Quick Sum
Select a range of cells. The total appears in bottom right of Excel screen. Right-click total to add Max, Min, Count, Average.
Sort by date Sort by votes
I am still not able to find the way out any help on this.
 
Upvote 0
I do not use outlook and this code is untested, but let me know if this works for you.

VBA Code: 
Sub EmailBodyENOCFixed()
    Dim outlookApp As Object
    Dim outlookMail As Object
    Dim ws As Worksheet
    Dim rng As Range
    Dim pic As Object
    
    Windows("Hourly Pending Tickets V1.xlsm").Activate
    Sheets("Pending Tickets with ENOC Fixed").Select
    Set ws = ThisWorkbook.Sheets("Pending Tickets with ENOC Fixed")
    Set rng = ws.UsedRange

    If Not rng Is Nothing Then
        Set outlookApp = CreateObject("Outlook.Application")
        Set outlookMail = outlookApp.CreateItem(0)
        
        rng.CopyPicture xlScreen, xlBitmap
        outlookMail.GetInspector.WordEditor.Range.Paste

        On Error Resume Next
        Set pic = outlookMail.GetInspector.WordEditor.Range.InlineShapes(1)

        If pic Is Nothing Then
            Set pic = outlookMail.GetInspector.WordEditor.Range.Shapes(1)
        End If
        
        If Not pic Is Nothing Then
            pic.LockAspectRatio = msoFalse
            'pic.Height = 700
            'pic.Width = 1800
            
            pic.Height = rng.Height * 1
            pic.Width = rng.Width * 1
        Else
            MsgBox "Unable to find the pasted picture.", vbExclamation
        End If
        
        With outlookMail
            .Body = Sheets("Email").Range("C7").Value & Chr(13) & Chr(13) & pic
            .To = Sheets("Email").Range("C2").Value
            .CC = Sheets("Email").Range("C3").Value
            .BCC = Sheets("Email").Range("C4").Value
            .Subject = Sheets("Email").Range("C5").Value
        End With
        
        outlookMail.Display
        Application.Wait (Now + TimeValue("0:00:03"))
        
      '  outlookMail.Send
    Else
        MsgBox "No used cells in the specified range", vbInformation
    End If
End Sub
 
Upvote 0
@Trixterz

this is the output. screen shot attached. No error, only image no text and below the text image.
 

Attachments

  • Output.png
    Output.png
    253.2 KB · Views: 10
Upvote 0
Hi, vmjan02. Pls try to replace in your code
VBA Code: 
outlookMail.GetInspector.WordEditor.Range.Paste
with
Code: 
Dim rng2 As Object
Set rng2 = outlookMail.GetInspector.WordEditor.Range
rng2.Collapse Direction:=wdCollapseEnd
rng2.Paste
 
Upvote 0
Solution
I don't know if this is any better or not as I am not able to run any test on it. But give it a try and let me know if it works.
VBA Code: 
Sub EmailBodyENOCFixed()
    On Error GoTo FixError
    Dim outlookApp As Object, outlookMail As Object
    Dim ws As Worksheet, rng As Range
    Dim pic As Chart, pic1 As String, pic2 As String
    
    Windows("Hourly Pending Tickets V1.xlsm").Activate
    Sheets("Pending Tickets with ENOC Fixed").Select
    
    ws = ThisWorkbook.Sheets("Pending Tickets with ENOC Fixed")
    rng = ws.UsedRange
    
    If Not rng Is Nothing Then
        outlookApp = CreateObject("Outlook.Application")
        outlookMail = outlookApp.CreateItem(0)
        
        Set pic = ThisWorkbook.chats.Add
        rng.CopyPicture xlScreen, xlBitmap
        pic1 = ThisWorkbook.Path & "\Pic1.png"
        With pic
            .Paste
            .Export Filename:=pic1, Filtername:="PNG"
            .Delete
        End With
        
        Set pic = ThisWorkbook.chats.Add
        outlookMail.GetInspector.WordEditor.Range.InlineShapes(1).CopyPicture xlScreen, xlBitmap
        pic2 = ThisWorkbook.Path & "\Pic2.png"
        With pic
            .Paste
            .Export Filename:=pic2, Filtername:="PNG"
            .Delete
        End With
        
        With outlookMail
            .To = Sheets("Email").Range("C2").Value
            .CC = Sheets("Email").Range("C3").Value
            .BCC = Sheets("Email").Range("C4").Value
            .Subject = Sheets("Email").Range("C5").Value
            .Attachments.Add pic1, 1, 0
            .Attachments.Add pic2, 1, 0
            .HTMLBody = "<html><p>" & Sheets("""Email""").Range("""C7""").Value & "</p><br>" & _
                        "<img src=""cid:pic1.png"" height=520 width=750><br>" & _
                        "<img src=""cid:pic2.png"" height=700 width=1800></html>"
        End With
        
        outlookMail.Display
        Application.Wait (Now + TimeValue("0:00:03"))
        
        'outlookMail.Send
        Set outlookMail = Nothing
        Set outlookApp = Nothing
        Kill pic1
        Kill pic2
    Else
        MsgBox "No used cells in the specified range", vbInformation
    End If
    Exit Sub
    
FixError:
    Debug.Print Format(Now(), "m/d/yyyy HH:MM") & " - Error Code: (" & Err.Number & ") " & Err.Description
    Err.Clear
    Resume Next
End Sub
 
Last edited:
Upvote 0
gior said:
Hi, vmjan02. Pls try to replace in your code
VBA Code: 
outlookMail.GetInspector.WordEditor.Range.Paste
with
Code: 
Dim rng2 As Object
Set rng2 = outlookMail.GetInspector.WordEditor.Range
rng2.Collapse Direction:=wdCollapseEnd
rng2.Paste
Click to expand...
perfect this worked perfect, thanks
Dam i missed the part earlier. thanks a ton
 
Upvote 0
Trixterz said:
I don't know if this is any better or not as I am not able to run any test on it. But give it a try and let me know if it works.
VBA Code: 
Sub EmailBodyENOCFixed()
    On Error GoTo FixError
    Dim outlookApp As Object, outlookMail As Object
    Dim ws As Worksheet, rng As Range
    Dim pic As Chart, pic1 As String, pic2 As String
   
    Windows("Hourly Pending Tickets V1.xlsm").Activate
    Sheets("Pending Tickets with ENOC Fixed").Select
   
    ws = ThisWorkbook.Sheets("Pending Tickets with ENOC Fixed")
    rng = ws.UsedRange
   
    If Not rng Is Nothing Then
        outlookApp = CreateObject("Outlook.Application")
        outlookMail = outlookApp.CreateItem(0)
       
        Set pic = ThisWorkbook.chats.Add
        rng.CopyPicture xlScreen, xlBitmap
        pic1 = ThisWorkbook.Path & "\Pic1.png"
        With pic
            .Paste
            .Export Filename:=pic1, Filtername:="PNG"
            .Delete
        End With
       
        Set pic = ThisWorkbook.chats.Add
        outlookMail.GetInspector.WordEditor.Range.InlineShapes(1).CopyPicture xlScreen, xlBitmap
        pic2 = ThisWorkbook.Path & "\Pic2.png"
        With pic
            .Paste
            .Export Filename:=pic2, Filtername:="PNG"
            .Delete
        End With
       
        With outlookMail
            .To = Sheets("Email").Range("C2").Value
            .CC = Sheets("Email").Range("C3").Value
            .BCC = Sheets("Email").Range("C4").Value
            .Subject = Sheets("Email").Range("C5").Value
            .Attachments.Add pic1, 1, 0
            .Attachments.Add pic2, 1, 0
            .HTMLBody = "<html><p>" & Sheets("""Email""").Range("""C7""").Value & "</p><br>" & _
                        "<img src=""cid:pic1.png"" height=520 width=750><br>" & _
                        "<img src=""cid:pic2.png"" height=700 width=1800></html>"
        End With
       
        outlookMail.Display
        Application.Wait (Now + TimeValue("0:00:03"))
       
        'outlookMail.Send
        Set outlookMail = Nothing
        Set outlookApp = Nothing
        Kill pic1
        Kill pic2
    Else
        MsgBox "No used cells in the specified range", vbInformation
    End If
    Exit Sub
   
FixError:
    Debug.Print Format(Now(), "m/d/yyyy HH:MM") & " - Error Code: (" & Err.Number & ") " & Err.Description
    Err.Clear
    Resume Next
End Sub
Click to expand...
Tested you part as well , but
this line is giving me error as method failed. yes but thanks a lot for your support as well. thank you once again.
Excel Formula: 
Set pic = ThisWorkbook.chats.Add
 
Upvote 0
vmjan02 said:
Tested you part as well , but
this line is giving me error as method failed. yes but thanks a lot for your support as well. thank you once again.
Excel Formula: 
Set pic = ThisWorkbook.chats.Add
Click to expand...
My bad, I spelled chats instead of charts. :ROFLMAO: Glad that you have find the answer you were looking for. (y)
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question Question
UserForm Image loading Error . I tried with the following your code but the picture is blank
Replies
4
Views
188
NdNoviceHlp
NdNoviceHlp
C
  • Solved
Add a table to e-mail to be sent to multiple addreses
Replies
3
Views
207
mumps
mumps
KlausW
  • Solved
Change Attachments from XLSM to XLSX in mail
Replies
5
Views
283
Micron
M
KlausW
  • Solved
Take fil name from cell
Replies
4
Views
246
KlausW
KlausW
D
  • Question Question
VBA change to not show a sent email in outlook
Replies
6
Views
446
Dspace
D

Forum statistics

Threads
1,223,886
Messages
6,175,196
Members
452,616
Latest member
intern444

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top