Email Body

V

vmjan02

Well-known Member
Joined
Aug 15, 2012
Messages
1,059
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

Move date out one month or year
Use =EDATE(A2,1) for one month later. Use EDATE(A2,12) for one year later.
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: 5
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

J
  • Question
VBA code to send an email if a certain IF Criteria is met that loops when the spreadsheet is open
Replies
1
Views
243
joeyc123
J
J
  • Question
SAVING A PDF SPREADSHEET IN EXCEL DOESN'T WORK
Replies
1
Views
369
dmt32
D
H
  • Question
VBA split file based and send splitted file in separate emails
Replies
0
Views
163
harmless92
H
M
  • Question
Extract data from outlook emails using excel vba
Replies
1
Views
1K
RoryA
RoryA
F
  • Question
VBA Export Outlook emails to Excel
Replies
1
Views
599
DanteAmor
DanteAmor

Forum statistics

Threads
1,215,071
Messages
6,122,964
Members
449,094
Latest member
Anshu121

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