• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

VBA - Sending Email using Excel and then copying data from Email

MaunishP

Member
Dear Team,
I am trying to create macro where I want my team member to send report bi-hourly basis through Microsoft WebOutlook App using Excel [Small button which says "Send Mail" and same I need to copy paste data into excel against thier name.

It is easy to capture data during 5-6 team members, but it becomes diffcult when 30+ team members send me email and i need to copy paste data everytime.

My Requirements :
1) A excel file which is unquiely [same format] there with my team members with a button saying " Send Email "
  • First worksheet to contain information which needs to be sent
  • Second worksheet to contain list of email id's which require data to be sent.
  • Email which will be sent needs to come in a HTML format not attachment format. "Do you think that next question which i am asking will restrict this request?"
2) Once i receive emails from particular team members [Every subject line will be same, however only dates will change ] an excel file to run macro and copy information from each email sent by team members and I a particular master sheet [date wise, hourly wise]

I have attached sample sheet which i require and visualization how i require.



Regards,
Maunish Patel
 

Attachments

Sathish KV

Active Member
Hi,

Lets go by one requirement at a time

First selecting the range from the sheet 'Insert Data' and mailing it based on the mail ids available in the sheet 'Email Distrubution List'

Try out the below code and come back

Note: Subject for the mail is not defined in your excel file

Code:
Sub Mail_Selection_Range_Outlook_Body()
  Dim rng As Range
  Dim OutApp As Object
  Dim OutMail As Object
  Dim StrBody As String
 
  Set rng = Nothing
  On Error Resume Next
  Set rng = Sheets("Insert Data").Range("C2:D8")
  On Error GoTo 0
 
  With Application
  .EnableEvents = False
  .ScreenUpdating = False
  End With
  Set OutApp = CreateObject("Outlook.Application")
  Set OutMail = OutApp.CreateItem(0)
 
  StrBody = "<p style='font-family:Calibri;font-size:16'>Hi " & Sheets("Email Distrubution List").Range("A2").Value & "," & "<br><br>" & _
  "<p style='font-family:Calibri;font-size:16'>Please find below given project status details as on " & Format(Date, "dd-mm-yyyy")
  On Error Resume Next
  With OutMail
  .Display
  .To = Sheets("Email Distrubution List").Range("B2").Value
  .CC = Sheets("Email Distrubution List").Range("B3").Value
  .BCC = Sheets("Email Distrubution List").Range("B4").Value
  .Subject = "Test"
  .HTMLBody = StrBody & RangetoHTML(rng) & "<br>" & .HTMLBody
  .Display  'or use .Display
  End With
  On Error GoTo 0
  With Application
  .EnableEvents = True
  .ScreenUpdating = True
  End With
  Set OutMail = Nothing
  Set OutApp = Nothing
End Sub
 
Function RangetoHTML(rng As Range)
  Dim fso As Object
  Dim ts As Object
  Dim TempFile As String
  Dim TempWB As Workbook
  TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
 
  rng.Copy
  Set TempWB = Workbooks.Add(1)
  With TempWB.Sheets(1)
  .Cells(1).PasteSpecial Paste:=8
  .Cells(1).PasteSpecial xlPasteValues, , False, False
  .Cells(1).PasteSpecial xlPasteFormats, , False, False
  .Cells(1).Select
  Application.CutCopyMode = False
  On Error Resume Next
  .DrawingObjects.Visible = True
  .DrawingObjects.Delete
  On Error GoTo 0
  End With
 
  With TempWB.PublishObjects.Add( _
  SourceType:=xlSourceRange, _
  Filename:=TempFile, _
  Sheet:=TempWB.Sheets(1).Name, _
  Source:=TempWB.Sheets(1).UsedRange.Address, _
  HtmlType:=xlHtmlStatic)
  .Publish (True)
  End With
 
  Set fso = CreateObject("Scripting.FileSystemObject")
  Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
  RangetoHTML = ts.readall
  ts.Close
  RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
  "align=left x:publishsource=")
 
  TempWB.Close savechanges:=False
 
  Kill TempFile
  Set ts = Nothing
  Set fso = Nothing
  Set TempWB = Nothing
End Function
 

MaunishP

Member
Hi Sathish,
Great this work !!! I have done few changes as required.

My Second question is if i have emails coming in a required with specific subject line [date will change daily] from specific team memebers.

How will i be able to copy data through macro from Outlook to Excel?

Regards,
Maunish Patel
 

Sathish KV

Active Member
Hi,

Whenever a new mail reaches your inbox the below macro downloads the details to a workbook

This may not fully address your requirement but just check if it works and we may tweak it as per the requirement

Note: This macro goes to your outlook and not in excel
Also change the path of the excel file in the below path

Code:
'Goes into Outlook Session Module
' Whenever a new mail comes to the Inbox, the data of that mail saved to an excel file
 
Const strFilePath As String = "C:\Users\Public\Documents\Excel\OutlookMailItemsDB.xlsx"
Const strSubjectLineStartWith As String = ""
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
 
    Dim varArray As Variant
    Dim strSub As String
    Dim strBody As String
    Dim strArray() As String
    Dim lngLoop As Long
    Dim objItem As Object
    Dim lngMailCounter As Long
    Dim objMItem As MailItem
    strArray = Split(EntryIDCollection, ",")
    For lngMailCounter = LBound(strArray) To UBound(strArray)
        Set objItem = Session.GetItemFromID(strArray(lngMailCounter))
        If TypeName(objItem) = "MailItem" And InStr(1, objItem.Subject, strSubjectLineStartWith) And InStr(1, objItem.Body, "") Then
            Set objMItem = objItem
            With CreateObject("Excel.Application").Workbooks.Open(strFilePath)
                With .Sheets(1)
                    With .Cells(.Rows.Count, 1).End(-4162)(2).Resize(1, 7)
                        .Value = Array(objMItem.SenderEmailAddress, objMItem.To, objMItem.CC, objMItem.BCC, objMItem.Subject, objMItem.ReceivedTime, objMItem.Body)
                    End With
                End With
                .Close 1
            End With
            Set objItem = Nothing
        End If
    Next lngMailCounter
    If Not IsEmpty(strArray) Then
        Erase strArray
    End If
 
End Sub
 
Hi,

Lets go by one requirement at a time

First selecting the range from the sheet 'Insert Data' and mailing it based on the mail ids available in the sheet 'Email Distrubution List'

Try out the below code and come back

Note: Subject for the mail is not defined in your excel file

Code:
Sub Mail_Selection_Range_Outlook_Body()
  Dim rng As Range
  Dim OutApp As Object
  Dim OutMail As Object
  Dim StrBody As String

  Set rng = Nothing
  On Error Resume Next
  Set rng = Sheets("Insert Data").Range("C2:D8")
  On Error GoTo 0

  With Application
  .EnableEvents = False
  .ScreenUpdating = False
  End With
  Set OutApp = CreateObject("Outlook.Application")
  Set OutMail = OutApp.CreateItem(0)

  StrBody = "<p style='font-family:Calibri;font-size:16'>Hi " & Sheets("Email Distrubution List").Range("A2").Value & "," & "<br><br>" & _
  "<p style='font-family:Calibri;font-size:16'>Please find below given project status details as on " & Format(Date, "dd-mm-yyyy")
  On Error Resume Next
  With OutMail
  .Display
  .To = Sheets("Email Distrubution List").Range("B2").Value
  .CC = Sheets("Email Distrubution List").Range("B3").Value
  .BCC = Sheets("Email Distrubution List").Range("B4").Value
  .Subject = "Test"
  .HTMLBody = StrBody & RangetoHTML(rng) & "<br>" & .HTMLBody
  .Display  'or use .Display
  End With
  On Error GoTo 0
  With Application
  .EnableEvents = True
  .ScreenUpdating = True
  End With
  Set OutMail = Nothing
  Set OutApp = Nothing
End Sub

Function RangetoHTML(rng As Range)
  Dim fso As Object
  Dim ts As Object
  Dim TempFile As String
  Dim TempWB As Workbook
  TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

  rng.Copy
  Set TempWB = Workbooks.Add(1)
  With TempWB.Sheets(1)
  .Cells(1).PasteSpecial Paste:=8
  .Cells(1).PasteSpecial xlPasteValues, , False, False
  .Cells(1).PasteSpecial xlPasteFormats, , False, False
  .Cells(1).Select
  Application.CutCopyMode = False
  On Error Resume Next
  .DrawingObjects.Visible = True
  .DrawingObjects.Delete
  On Error GoTo 0
  End With

  With TempWB.PublishObjects.Add( _
  SourceType:=xlSourceRange, _
  Filename:=TempFile, _
  Sheet:=TempWB.Sheets(1).Name, _
  Source:=TempWB.Sheets(1).UsedRange.Address, _
  HtmlType:=xlHtmlStatic)
  .Publish (True)
  End With

  Set fso = CreateObject("Scripting.FileSystemObject")
  Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
  RangetoHTML = ts.readall
  ts.Close
  RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
  "align=left x:publishsource=")

  TempWB.Close savechanges:=False

  Kill TempFile
  Set ts = Nothing
  Set fso = Nothing
  Set TempWB = Nothing
End Function
Hi Sathis, how are you man.. this is Ravi here. Glad to see your post and helping others and learning new things.
 
Hi Ravi,

Its nine two eight two one zero nine seven eight seven
ur number is switched off, that's ok.

My doubt is - I have 2 excel sheets and am trying to link each other and after linking I have closed the source file. now the links work perfectly. Again, when I open the source file all my links getting #Ref error, I really don't know the reason, I have tried many ways not not getting resolved. can you give me some ideas here. Am using excel 2013.

If your phone is available just give me a Buzz to my number - 9941690340
 
Hi,

Lets go by one requirement at a time

First selecting the range from the sheet 'Insert Data' and mailing it based on the mail ids available in the sheet 'Email Distrubution List'

Try out the below code and come back

Note: Subject for the mail is not defined in your excel file

Code:
Sub Mail_Selection_Range_Outlook_Body()
  Dim rng As Range
  Dim OutApp As Object
  Dim OutMail As Object
  Dim StrBody As String

  Set rng = Nothing
  On Error Resume Next
  Set rng = Sheets("Insert Data").Range("C2:D8")
  On Error GoTo 0

  With Application
  .EnableEvents = False
  .ScreenUpdating = False
  End With
  Set OutApp = CreateObject("Outlook.Application")
  Set OutMail = OutApp.CreateItem(0)

  StrBody = "<p style='font-family:Calibri;font-size:16'>Hi " & Sheets("Email Distrubution List").Range("A2").Value & "," & "<br><br>" & _
  "<p style='font-family:Calibri;font-size:16'>Please find below given project status details as on " & Format(Date, "dd-mm-yyyy")
  On Error Resume Next
  With OutMail
  .Display
  .To = Sheets("Email Distrubution List").Range("B2").Value
  .CC = Sheets("Email Distrubution List").Range("B3").Value
  .BCC = Sheets("Email Distrubution List").Range("B4").Value
  .Subject = "Test"
  .HTMLBody = StrBody & RangetoHTML(rng) & "<br>" & .HTMLBody
  .Display  'or use .Display
  End With
  On Error GoTo 0
  With Application
  .EnableEvents = True
  .ScreenUpdating = True
  End With
  Set OutMail = Nothing
  Set OutApp = Nothing
End Sub

Function RangetoHTML(rng As Range)
  Dim fso As Object
  Dim ts As Object
  Dim TempFile As String
  Dim TempWB As Workbook
  TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

  rng.Copy
  Set TempWB = Workbooks.Add(1)
  With TempWB.Sheets(1)
  .Cells(1).PasteSpecial Paste:=8
  .Cells(1).PasteSpecial xlPasteValues, , False, False
  .Cells(1).PasteSpecial xlPasteFormats, , False, False
  .Cells(1).Select
  Application.CutCopyMode = False
  On Error Resume Next
  .DrawingObjects.Visible = True
  .DrawingObjects.Delete
  On Error GoTo 0
  End With

  With TempWB.PublishObjects.Add( _
  SourceType:=xlSourceRange, _
  Filename:=TempFile, _
  Sheet:=TempWB.Sheets(1).Name, _
  Source:=TempWB.Sheets(1).UsedRange.Address, _
  HtmlType:=xlHtmlStatic)
  .Publish (True)
  End With

  Set fso = CreateObject("Scripting.FileSystemObject")
  Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
  RangetoHTML = ts.readall
  ts.Close
  RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
  "align=left x:publishsource=")

  TempWB.Close savechanges:=False

  Kill TempFile
  Set ts = Nothing
  Set fso = Nothing
  Set TempWB = Nothing
End Function
Sathish,

I tried the above code for attaching specified range in outlook, but what I want is - I need to add few more lines after pasting the data, for Eg. "Note: this should complete end of taoday". so where I should these code in the above program. I tried couple of lines and that's didn't worked for me...
Any luck on this ??
 

Manish2007

New Member
Hi Satish,

Could you please help me to write a code which includes data to be copied from one excel sheet (Reporting) having filter for a specific value taken from another sheet (Email Owners) into outlook email body and then perform the same action till my other sheet (Email Owners) list is complete.

Email owner shet;


Reporting Sheet

Field1AccountSum_Rpt CCY Bal YTD
75041001211482393
75042030705101-245
750420312393340
75042031239382-2,809,158
75042031981075-156,020
76012031238387-908,380
76014722701613-764
76014722708440-5,965
76472031258677-2,094,476
7647203195865326
76472032106225-2
764721938299866,444
76474722720867-15
76474722781573-371
764747239000020
764758517000027
76501001206528421
 

vletm

Excel Ninja
Manish2007
You should open a new thread
as written in Forum Rules which You've already read
Please reread those and continue after that.
 
Top