Need VBA Code to copy Columns from Excel to Outlook

Laxminarayan · Feb 17, 2015

I need to Copy Selected Excel Data to Outlook, i have created an VBA Code for the normal stuffs as Creating the body of the Email and auto Fills "To" and From data in Outlook,

Below is the VBA Code which i have used.

In Here in Sheets Drafter and Range J9 which has some data i need to copy paste the Entire data in Outlook, currently its not possible with the below Code,

Can anyone advise or amend the below code so that i can get the necessary results.

Let me know in case of any issues.

Code:

Sub AutoCreateMail()
    Application.ScreenUpdating = False
    Selection.Copy
    Sheets("Drafter").Visible = True
    Sheets("Drafter").Select
    Range("J9").Select
    On Error GoTo Handler
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    On Error GoTo 0
    Dim objOutlook As Object
    Dim objMail As Object
    Dim EmailFrom As Range
    Dim EmailTo As Range
    Dim EmailCc As Range
    Dim EmailSubject As Range
    Dim EmailBody1 As Range
    Dim EmailBody2 As Range
    Dim EmailBody3 As Range
    Dim EmailBody4 As Range
    Dim EmailBody5 As Range
    Dim EmailBody6 As Range
    Set objOutlook = CreateObject("Outlook.Application")
    Set objMail = objOutlook.CreateItem(0)
   
    With ActiveSheet
        Set EmailFrom = .Range("B1")
        Set EmailTo = .Range("B2")
        Set EmailCc = .Range("B3")
        Set EmailSubject = .Range("B4")
        Set EmailBody1 = .Range("B5")
        Set EmailBody2 = .Range("B6")
        Set EmailBody3 = .Range("B7")
        Set EmailBody4 = .Range("B8")
        Set EmailBody5 = .Range("B9")
        Set EmailBody6 = .Range("B10")
       
    End With
   
    With objMail
        .Display
        .SentOnBehalfOfName = EmailFrom.Value
        .To = EmailTo.Value
        .Cc = EmailCc.Value
        .Subject = EmailSubject.Value
        .HTMLBody = "<br>" & EmailBody1.Value & "<br><br>" & EmailBody2.Value & "<br><br>" & EmailBody3.Value & "<br><br><br>" & EmailBody4.Value & "<br><br><br>" & EmailBody5.Value & "<br><br><br>" & EmailBody6.Value & "<br>" & .HTMLBody
    End With
       
    ThisWorkbook.Activate
    Sheets("Drafter").Select
    Range("J:N").Select
    Selection.ClearContents
    Sheets("Drafter").Visible = False
    Sheets("Planner").Select
   
    Application.ScreenUpdating = True
   
Handler:
    Sheets("Drafter").Visible = False
    Application.CutCopyMode = False
    Exit Sub
End Sub

Dayanand · Feb 17, 2015

This code cannot give you desired output.

Laxminarayan · Feb 18, 2015

Dayanand said:
This code cannot give you desired output.

Can u amend the above code and advise the changes so i can incorporate it in the above...

Atom · Feb 18, 2015

Hi,
I use "sendkeys" cobmination to paste value from excel to mail.

Code:

SendKeys "{DOWN}{END}{ENTER}" 'combination to navigate in mail body...
SendKeys "^v", True 'this line paste value from the excel...
SendKeys "{DOWN}{BACKSPACE}"
SendKeys "^{NUMLOCK}"

I had to use SendKeys "^{NUMLOCK}" at the end, because macro switched numlock off... i have no idea why

So you can skip this line in your case.

Regards,

Laxminarayan · Feb 24, 2015

Thanks for the above... will check it and let u know if this works... Cheers

Laxminarayan · Feb 24, 2015

hi... well i tried to incorporate the above code but it doesnot seems to work for me... can u try to amend the original with your new one...and paste the code in here...

What i want to achieve in here is that from Excel Sheet tab named as "Drafter", i want to copy visible cells from J:N column to Email just below Email Body 1.

Nebu · Feb 24, 2015

Hi:

Can you please upload your workbook.

Thanks

Atom · Feb 24, 2015

Hi,
I hope that code below will work for you...

Code:

Sub AutoCreateMail()
    Application.ScreenUpdating = False
    Selection.Copy
    Sheets("Drafter").Visible = True
    Sheets("Drafter").Select
    Range("J9").Select
    On Error GoTo Handler
    Selection.PasteSpecial paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    On Error GoTo 0
    Dim objOutlook As Object
    Dim objMail As Object
    Dim EmailFrom As Range
    Dim EmailTo As Range
    Dim EmailCc As Range
    Dim EmailSubject As Range
    Dim EmailBody1 As Range
    Dim EmailBody2 As Range
    Dim EmailBody3 As Range
    Dim EmailBody4 As Range
    Dim EmailBody5 As Range
    Dim EmailBody6 As Range
    Set objOutlook = CreateObject("Outlook.Application")
    Set objMail = objOutlook.CreateItem(0)
  
    With ActiveSheet
        Set EmailFrom = .Range("B1")
        Set EmailTo = .Range("B2")
        Set EmailCc = .Range("B3")
        Set EmailSubject = .Range("B4")
        Set EmailBody1 = .Range("B5")
        Set EmailBody2 = .Range("B6")
        Set EmailBody3 = .Range("B7")
        Set EmailBody4 = .Range("B8")
        Set EmailBody5 = .Range("B9")
        Set EmailBody6 = .Range("B10")
    End With
  
    Range("J:N").Select
    With Selection.Copy
    End With
  
    With objMail
        .SentOnBehalfOfName = EmailFrom.Value
        .To = EmailTo.Value
        .Cc = EmailCc.Value
        .Subject = EmailSubject.Value
        .Body = EmailBody1.Value & Chr(10) & Chr(10) & EmailBody2.Value & Chr(10) & Chr(10) & _
        EmailBody3.Value & Chr(10) & Chr(10) & EmailBody4.Value & Chr(10) & Chr(10) & EmailBody5.Value & _
        Chr(10) & Chr(10) & EmailBody6.Value & Chr(10) & Chr(10)
        .Display 'i've changed .HTMLbody to .body, otherwise sendkeys will not work...
    End With
  
    SendKeys "{DOWN}{END}{ENTER}"
    SendKeys "^v", True
    SendKeys "{DOWN}{BACKSPACE}"
    SendKeys "^{NUMLOCK}"
      
    ThisWorkbook.Activate
    Sheets("Drafter").Select
    Range("J:N").Select
    Selection.ClearContents
    Sheets("Drafter").Visible = False
    Sheets("Planner").Select
  
    Application.ScreenUpdating = True
  
Handler:
    Sheets("Drafter").Visible = False
    Application.CutCopyMode = False
    Exit Sub
End Sub

Regards,

Laxminarayan · Feb 25, 2015

Hey.. thanks for the above... i tried using it.. but again the issue remains the same.... it is not able to copy and paste the Xl visible cells in Outlook.

Also i was working on instead of copying cells why not capture the highlighted cells as JPG File. When i now run the code it says Run-Time Error "438":
Object doesn't support this property or method.

Can u check the code and advise me where i m going wrong..

checking the code bring me to below line which shows the error.

.Attachments.Add TempFilePath & "DashboardFile.jpg", olByValue, 0

Code:

Sub AutoCreateMail()
    Application.ScreenUpdating = False
    Selection.Copy
    Sheets("Drafter").Visible = True
    Sheets("Drafter").Select
    Range("J9").Select
    On Error GoTo Handler
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    On Error GoTo 0
    Dim objOutlook As Object
    Dim objMail As Object
    Dim EmailFrom As Range
    Dim EmailTo As Range
    Dim EmailCc As Range
    Dim EmailSubject As Range
    Dim EmailBody1 As Range
    Dim EmailBody2 As Range
    Dim EmailBody3 As Range
    Dim EmailBody4 As Range
    Dim EmailBody5 As Range
    Dim EmailBody6 As Range
    Dim TempFilePath As String
    Set objOutlook = CreateObject("Outlook.Application")
    Set objMail = objOutlook.CreateItem(0)
 
    With ActiveSheet
        Set EmailFrom = .Range("B1")
        Set EmailTo = .Range("B2")
        Set EmailCc = .Range("B3")
        Set EmailSubject = .Range("B4")
        Set EmailBody1 = .Range("B5")
        Set EmailBody2 = .Range("B6")
        Set EmailBody3 = .Range("B7")
        Set EmailBody4 = .Range("B8")
        Set EmailBody5 = .Range("B9")
        Set EmailBody6 = .Range("B10")
     
        Call createJpg("Drafter", "J8:N15", "DashboardFile")
        TempFilePath = Environ$("temp") & "\"
        .Attachments.Add TempFilePath & "DashboardFile.jpg", olByValue, 0
     
           
    End With
 
    With objMail
        .Display
        .SentOnBehalfOfName = EmailFrom.Value
        .To = EmailTo.Value
        .Cc = EmailCc.Value
        .Subject = EmailSubject.Value
        .HTMLBody = "<br>" & EmailBody1.Value & "<br><br>" & "<img src='cid:DashboardFile.jpg'" & "width=width height=height><br>" & EmailBody2.Value & "<br><br>" & EmailBody3.Value & "<br><br><br>" & EmailBody4.Value & "<br><br><br>" & EmailBody5.Value & "<br><br><br>" & EmailBody6.Value & "<br>" & .HTMLBody
    End With
     
    ThisWorkbook.Activate
    Sheets("Drafter").Select
    Range("J8:N15").Select
    Selection.ClearContents
    Sheets("Drafter").Visible = False
    Sheets("Planner").Select
 
 
    Application.ScreenUpdating = True
 
Handler:
    Sheets("Drafter").Visible = False
    Application.CutCopyMode = False

    Exit Sub
End Sub

Sub createJpg(Namesheet As String, nameRange As String, nameFile As String)
    ThisWorkbook.Activate
    Worksheets(Namesheet).Activate
    Set Plage = ThisWorkbook.Worksheets(Namesheet).Range(nameRange)
    Plage.CopyPicture
    With ThisWorkbook.Worksheets(Namesheet).ChartObjects.Add(Plage.Left, Plage.Top, Plage.Width, Plage.Height)
        .Activate
        .Chart.Paste
        .Chart.Export Environ$("temp") & "\" & nameFile & ".jpg", "JPG"
    End With
    Worksheets(Namesheet).ChartObjects(Worksheets(Namesheet).ChartObjects.Count).Delete
Set Plage = Nothing
End Sub

Laxminarayan · Feb 25, 2015

Nebu said:
Hi:

Can you please upload your workbook.

Thanks

i m not sure i can do that... we have restrictive access at my offfice... and its my office work file...i would have surely uploaded if i can...

Laxminarayan · Feb 26, 2015

Guys... i have a new Problem here... i was able to incorporate the JPG in Email, but the Image is not reflecting in outlook, its says as

Here is the code i used.

Code:

Sub AutoCreateMail()
    Application.ScreenUpdating = False
    Selection.Copy
    Sheets("Drafter").Visible = True
    Sheets("Drafter").Select
    Range("J9").Select
    On Error GoTo Handler
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    On Error GoTo 0
    Dim objOutlook As Object
    Dim objMail As Object
    Dim EmailFrom As Range
    Dim EmailTo As Range
    Dim EmailCc As Range
    Dim EmailSubject As Range
    Dim EmailBody1 As Range
    Dim EmailBody2 As Range
    Dim EmailBody3 As Range
    Dim EmailBody4 As Range
    Dim EmailBody5 As Range
    Dim EmailBody6 As Range
    Set objOutlook = CreateObject("Outlook.Application")
    Set objMail = objOutlook.CreateItem(0)
   
    With ActiveSheet
        Set EmailFrom = .Range("B1")
        Set EmailTo = .Range("B2")
        Set EmailCc = .Range("B3")
        Set EmailSubject = .Range("B4")
        Set EmailBody1 = .Range("B5")
        Set EmailBody2 = .Range("B6")
        Set EmailBody3 = .Range("B7")
        Set EmailBody4 = .Range("B8")
        Set EmailBody5 = .Range("B9")
        Set EmailBody6 = .Range("B10")
       
    End With
   
sendMail
    With objMail
        .Display
        .SentOnBehalfOfName = EmailFrom.Value
        .To = EmailTo.Value
        .Cc = EmailCc.Value
        .Subject = EmailSubject.Value
        .HTMLBody = "<br>" & EmailBody1.Value & "<br><br>" & EmailBody2.Value & "<br><br>" & "<img src='cid:DrafterFile.jpg'" & "width='814' height='33'><br>" & EmailBody3.Value & "<br><br><br>" & EmailBody4.Value & "<br><br><br>" & EmailBody5.Value & "<br><br><br>" & EmailBody6.Value & "<br>" & .HTMLBody
    End With
       
    ThisWorkbook.Activate
    Sheets("Drafter").Select
    Range("J:N").Select
    Selection.ClearContents
    Sheets("Drafter").Visible = False
    Sheets("Planner").Select
   
    Application.ScreenUpdating = True
   
Handler:
    Sheets("Drafter").Visible = False
    Application.CutCopyMode = False
    Exit Sub
End Sub


Sub sendMail()
        Application.Calculation = xlManual
        With Application
            .ScreenUpdating = False
            .EnableEvents = False
        End With
   
        Dim TempFilePath As String
       
        'Create a new Microsoft Outlook session
        Set appOutlook = CreateObject("outlook.application")
        'create a new message
        Set Message = appOutlook.CreateItem(olMailItem)
         
       
        With Message
           
   

               
            'first we create the image as a JPG file
            Call createJpg("Drafter", "J8:N16", "DrafterFile")
            'we attached the embedded image with a Position at 0 (makes the attachment hidden)
            TempFilePath = Environ$("temp") & "\"
            .Attachments.Add TempFilePath & "DrafterFile.jpg", olByValue, 0
               
        End With
   
        With Application
            .ScreenUpdating = True
            .EnableEvents = True
        End With
        Application.Calculation = xlCalculationAutomatic
    End Sub
   
    Sub createJpg(Namesheet As String, nameRange As String, nameFile As String)
    ThisWorkbook.Activate
    Set Plage = ThisWorkbook.Worksheets(Namesheet).Range(nameRange)
    Plage.CopyPicture
    With ThisWorkbook.Worksheets(Namesheet).ChartObjects.Add(Plage.Left, Plage.Top, Plage.Width, Plage.Height)
        .Activate
        .Chart.Paste
        .Chart.Export Environ$("temp") & "\" & nameFile & ".jpg", "JPG"
    End With
    Worksheets(Namesheet).ChartObjects(Worksheets(Namesheet).ChartObjects.Count).Delete
Set Plage = Nothing
End Sub

Need VBA Code to copy Columns from Excel to Outlook

Laxminarayan

New Member

Dayanand

New Member

Laxminarayan

New Member

Atom

New Member

Laxminarayan

New Member

Laxminarayan

New Member

Nebu

Excel Ninja

Atom

New Member

Laxminarayan

New Member

Laxminarayan

New Member

Laxminarayan

New Member