Email based on Criteria ....

**Kenneth Hobson** · Nov 29th 2017

1)

Code

Set f = ws2.Columns("E").Find(ws.Cells(c.Row, "H"), ws2.[E1])

2)
a. If it was already processed, the log sheet knows it. Why would you want to send it again? You may need change this but maybe the formula for c would be sufficient.

Code

If c < 95 Or c > 100 Then GoTo NextC 'Not due yet so skip.

b. Yes, but there are lots of considerations. e.g. Were all entries processed?
(1) What if you delete Data rows? Just change the unique column formula. e.g. All Data rows deleted. The first formula would be to add the last unique number to Row() in the formula. Doing it this way, your log sheet would likely never need to be changed until you get to the last row...

3) Do it like I did the .To but use .CC. Multiple CC's or TO's can be done just like you do in Outlook. It can be a Group that exists in the user's Outlook AddressBook or semi-colon delimited. e.g. [email protected];[email protected].
You may need to do an IF to make sure that the value for CC <> "".

4) You said that you wanted one user. If you want ALL then delete the username IF. If you want limited users, say your username at work and username at home or others then add OR's. If you have many but still limited, a Select Case might be more best. My rule for such is usually 4 or more.

Code

If user <> "PrakashPC" or user <> "ken" Then Exit Sub

prakash24 · Nov 29th 2017

Thank you sir ,
I just got these error . is it because of outlook ????

**Kenneth Hobson** · Nov 29th 2017

I don't know. Debug one line at a time by pressing F8 to see where it happens.

prakash24 · Nov 29th 2017

sir after f8 on each line ..its showing at this place , Run-time error 462 said the remote server machine doesn't exist or unavailable . Even my outlook is also open

Code

.GetInspector.Display
      Set Word = .GetInspector.WordEditor
      Set wr = Word.Content
      wr = body

**Kenneth Hobson** · Nov 29th 2017

Did you Compile from the Debug menu before the Run? If you did, it should tell you if the Outlook and WORD objects were set. Obviously, Outlook is from the Suite, not the online version.

prakash24 · Nov 29th 2017

Yes, and its not even allowing me to run macro. showing

[SIZE=13px]Run-time error 462 said the remote server machine doesn't exist or unavailable[/SIZE]

**Kenneth Hobson** · Nov 30th 2017

I don't need it but maybe you can try before the End With:

Code

Set wr = Nothing
Set Word = Nothing

prakash24 · Nov 30th 2017

Thank you sir , its working amazing ...and you are really a Great Person and a Great Teacher .

prakash24 · Dec 3rd 2017

Quote from Kenneth Hobson

Hello Sir,
Hope you are doing great , sir everything is working perfect but the only this is with the below code because as my file is in network drive and every computer has different version of outlook sometime getting error in some computers , Compile error in hidden module .
is it possible to remove outlook version limitations??? and also do I have to do tools>reference>object library for every computer???

Thank you

Code

Sub EmailByDateDue2()
  Dim ws As Worksheet, ws2 As Worksheet, r As Range, c As Range
  Dim u$, d$
  Dim f As Range, sig$, SentOnBehalfOfName$, body$, user$
  'Tools > References > Microsoft Outlook xx.0 Object Library
  Dim olApp As Outlook.Application, olMail As Outlook.MailItem
  'Tools > References > Microsoft Word xx.0 Object Library
  Dim Word As Document, wr As Word.Range

**Kenneth Hobson** · Dec 3rd 2017

While there are ways to set references for the user, late binding is the way most get around those issues. Some will code in early binding and then make the production version using late binding. To do that, one needs to: (1) change Dim variable types to Object, (2) Change Set lines, and (2) change constant variables to their values.

e.g.

Code

Sub EmailByDateDue()
  Dim ws As Worksheet, ws2 As Worksheet, r As Range, c As Range
  Dim f As Range, sig$, SentOnBehalfOfName$, body$, user$
  'Late binding
  Dim olApp As Object, olMail As Object, Word As Object, wr As Object


  'Early binding
  'Tools > References > Microsoft Outlook xx.0 Object Library
  'Dim olApp As Outlook.Application, olMail As Outlook.MailItem
  'Tools > References > Microsoft Word xx.0 Object Library
  'Dim Word As Document, wr As Word.Range


'****************** INPUTs ***************************************
  Set ws = Worksheets("Data")
  Set ws2 = Worksheets("Email sent Report")
  'Signature file path, must exist.
  SentOnBehalfOfName = "[email protected]"
  sig = ThisWorkbook.Path & "\sig.rtf"
  user = Environ("username")
'****************** END INPUTs ***********************************


  If user <> "Kenneth Hobson" Then Exit Sub


  '100 day column
  Set r = ws.Range("G2", ws.Cells(Rows.Count, "G").End(xlUp))


  'Set olApp = New Outlook.Application  'Early binding
  Set olApp = CreateObject("Outlook.Applicaiton") 'Late binding


  For Each c In r
    If c > 100 Then GoTo NextC  'Not due yet so skip.
    Set f = ws2.Columns("A").Find(ws.Cells(c.Row, "A"), ws2.[A1])
    If Not f Is Nothing Then GoTo NextC


    Set olMail = olApp.CreateItem(0)  'olMailItem=0
    With olMail
      .Importance = 1 'olImportanceNormal=1
      .To = ws.Cells(c.Row + 1, "C")
      .SentOnBehalfOfName = SentOnBehalfOfName
      .Subject = "100 Day Reminder"
      body = "Name: " & ws.Cells(c.Row, "C") & vbCrLf
      body = body & "Amount: " & ws.Cells(c.Row, "D") & vbCrLf
      body = body & "Serial No.: " & ws.Cells(c.Row, "A")


      .GetInspector.Display
      Set Word = .GetInspector.WordEditor
      Set wr = Word.Content
      wr = body


      GetObject(sig).Content.Copy
      wr.Collapse Direction:=0  'wdCollapseEnd=0
      wr.Paste  'Paste at end


      '.DeferredDeliveryTime = Now + TimeValue("00:10:00")
      .Display
      '.Send


      'Write entry to log sheet.
      Set f = ws2.Cells(Rows.Count, "A").End(xlUp).Offset(1)
      f = ws.Cells(c.Row, "A")  'Serial Number
      f.Offset(, 1) = ws.Cells(c.Row, "C") 'Name
      f.Offset(, 2) = ws.Cells(c.Row + 1, "C") 'Email
      f.Offset(, 3) = Date 'Reminder Sent
      f.Offset(, 3).NumberFormat = "mm/dd/yyyy"
    End With
NextC:
  Next c


  On Error Resume Next
  Set olMail = Nothing
  Set olApp = Nothing
End Sub

Display More

prakash24 · Dec 3rd 2017

Thank You sir, I will try this and get back to you tomorrow.

prakash24 · Dec 3rd 2017

Sir after running the code I just got this error. I changed ------

[SIZE=13px]Dim variable types to Object------Change Set lines-----change constant variables to their values.

I also Unchecked it from[/SIZE]

[SIZE=12px]Tools > References > Microsoft Outlook xx.0 Object Library
Tools > References > Microsoft Word xx.0 Object Library[/SIZE]

or Do I Have to keep it Checked in one system..

**Kenneth Hobson** · Dec 5th 2017

Post the code or workbook so I can check.

prakash24 · Dec 6th 2017

Quote from Kenneth Hobson

Post the code or workbook so I can check.

Good morning sir,
Thank you for your frequent replies. Please find the attachment I changed the below line while getting the errors and few columns.

Set olApp = GetObject(, "Outlook.Application") 'Late binding

Set olApp = CreateObject("Outlook.Applicaiton") 'Late binding

and

one quick question sir ,

If i want the entry should write from row 5 of column A , then where i have to make changes ... i tried like this but it didn’t work for me .

Set f = ws2.Columns("A").Find(ws.Cells(c.Row, "A"), ws2.[A5])

Set f = ws2.Cells(Rows.Count, "A").End(xlUp).Offset(1)

**Kenneth Hobson** · Dec 8th 2017

When you get an object using GetObject(), you need to check that no error occurred. e.g. Outlook was not open.

I fear that would overwrite data but to write to a ws2 cell A5"

Code

ws2.[A5] = "whatever value you want"

prakash24 · Dec 8th 2017

yes, your are right sir, Active X components error 429 is occurring in both codes. when outlook is closed, Sometimes error of Automation and Hidden Modules error in other PC's. Either its Getobject() or CreateObject().

**Kenneth Hobson** · Dec 8th 2017

The error 432 in post #34 was likely due to the sig file not existing. I thought that I had showed you how to check for that and skip it. Here I show you how to abort the macro if it does not exist.

The getUserName is likely an API which was not in the file in post #34.

After I changed your Column I to Column G for the "100 day" check, it worked fine.

Code

Sub EmailByDateDue3()
  Dim ws As Worksheet, ws2 As Worksheet, r As Range, c As Range
  Dim f As Range, sig$, SentOnBehalfOfName$, body$, user$
  'Late binding
  Dim olApp As Object, olMail As Object, Word As Object, wr As Object


  'Early binding
  'Tools > References > Microsoft Outlook xx.0 Object Library
  'Dim olApp As Outlook.Application, olMail As Outlook.MailItem
  'Tools > References > Microsoft Word xx.0 Object Library
  'Dim Word As Document, wr As Word.Range


'****************** INPUTs ***************************************
  Set ws = Worksheets("Data")
  Set ws2 = Worksheets("Email sent Report")
  'Signature file path, must exist.
  SentOnBehalfOfName = "[email protected]"
  sig = "C:\Users\PrakashPC\Desktop\New folder\Signature.rtf"
  user = Environ("username")
'****************** END INPUTs ***********************************
  If Dir(sig) = "" Then
    MsgBox sig, vbApplicationModal, "Macro Ending - File Does Not Exist"
    Exit Sub
  End If


  If user <> "PrakashPC" Or getUserName() <> "prakash" Then Exit Sub


  '100 day column
  Set r = ws.Range("G2", ws.Cells(Rows.Count, "G").End(xlUp))


  'Set olApp = New Outlook.Application  'Early binding
  'Set olApp = GetObject(, "Outlook.Application") 'Late binding
  Set olApp = CreateObject("Outlook.Application")


  For Each c In r
     If c < 95 Or c > 100 Then GoTo NextC 'Not due yet so skip.
    Set f = ws2.Columns("A").Find(ws.Cells(c.Row, "A"), ws2.[A1])
    If Not f Is Nothing Then GoTo NextC


    Set olMail = olApp.CreateItem(0)  'olMailItem=0
    With olMail
      .Importance = 1 'olImportanceNormal=1
      .To = ws.Cells(c.Row + 1, "e")
      .SentOnBehalfOfName = SentOnBehalfOfName
      .Subject = "100 Day Reminder"
      body = "Name: " & ws.Cells(c.Row, "e") & vbCrLf
      body = body & "Amount: " & ws.Cells(c.Row, "f") & vbCrLf
      body = body & "Serial No.: " & ws.Cells(c.Row, "A")


      .GetInspector.Display
      Set Word = .GetInspector.WordEditor
      Set wr = Word.Content
      wr = body


      GetObject(sig).Content.Copy
      wr.Collapse Direction:=0  'wdCollapseEnd=0
      wr.Paste  'Paste at end


      '.DeferredDeliveryTime = Now + TimeValue("00:10:00")
      .Display
      '.Send


      'Write entry to log sheet.
      Set f = ws2.Cells(Rows.Count, "A").End(xlUp).Offset(1)
      f = ws.Cells(c.Row, "A")  'Serial Number
      f.Offset(, 1) = ws.Cells(c.Row, "e") 'Name
      f.Offset(, 2) = ws.Cells(c.Row + 1, "e") 'Email
      f.Offset(, 3) = Date 'Reminder Sent
      f.Offset(, 3).NumberFormat = "dd/mm/yyyy"
      f.Offset(, 4) = ws.Cells(c.Row, "AS")
    End With
NextC:
  Next c


  On Error Resume Next
  Set olMail = Nothing
  Set olApp = Nothing
End Sub

Display More

prakash24 · Dec 8th 2017

Perfect...Thank you, soo Much, sir ... ...

prakash24 · Dec 11th 2017

[SIZE=13px]

Quote from Kenneth Hobson

[/SIZE]

Hello sir,

I just got an error, Everything is working fine when outlook is open.

1) but at the time with closed outlook .. error of automation “disconnected from client “ error is coming when uncommenting (" “.send "” )with closed outlook.......//////

When (" '“ ‘.send is for only comment “") with outlook closed then its fine ...

and

2) sometimes also getting an error of outlook contact library.

Please assist. Thank you ..

**Kenneth Hobson** · Dec 11th 2017

Those are two separate issues that any Outlook macro might see. They could have been asked in two separate threads/topics.

1. Is easily solved by leaving Outlook open.
a. I doubt that I would see that error. The usual problem is that the sent Emails are only sent from OutBox when Outlook opens. You can test if Outlook is open and open to avoid that issue. https://www.rondebruin.nl/win/s1/outlook/openclose.htm

2. I am guessing that rather than an Email address with the @ character, you have used an Alias which is a group. If it does not exist in your Contact addressbook, then it errors. To Resolve that, one would use well, Resolve. e.g.

Code

'https://www.mrexcel.com/forum/excel-questions/1029977-how-can-i-attach-object-file-attached-worksheet-email.html
Sub Main()
  Dim S$, T$, sig$, ole$
  'Tools > References > Microsoft Outlook xx.0 Object Library > OK
  Dim olApp As Outlook.Application, olMail As Outlook.MailItem
  'Tools > References > Microsoft Word xx.0 Object Library > OK
  Dim Word As Document, wr As Word.Range, rTo As Recipient, wos As Word.Selection


  'INPUTS to change if needed...........................................................
  S = "Hello World Example" 'Subject
  T = "[email protected]"       'To
  ole = "oleFile1"          'OLE object's name.
  sig = ThisWorkbook.Path & "\sig.rtf" 'contents to copy for signature.
  'End INPUTS...........................................................................


  'Get Outlook application
  Set olApp = New Outlook.Application


  'Make email, send/display.
  Set olMail = olApp.CreateItem(olMailItem)
  With olMail 'olApp.CreateItem(olMailItem)
    .Subject = S
    .Importance = olImportanceNormal


    'Set the recipient(s) for To field and resolve.
    Set rTo = .Recipients.Add(T)
    rTo.Resolve
    rTo.Type = olTo 'olTo, olcc, olbcc
    If rTo.Resolved = False Then
      Debug.Print T & "email address: Resolved=False"
      '.To = T  'Using rTo above for .To instead.
      GoTo TheEnd
    End If


    'Setup WordEditor parts:
    .GetInspector.Display
    Set Word = .GetInspector.WordEditor
    Set wr = Word.Range
    wr.Font.Name = "Arial"
    wr.Font.Size = 18


    'Body, introductory text:
    'wr.typetext "..."
    wr.Text = "Dear VBA Enthusiast, " & vbCrLf & vbCrLf & _
          "I hope that you find this example of copied Excel Range " _
          & "and embedded OLEObject using WordEditor in Outlook " _
          & "useful." & String(2, vbCrLf)


    'Body, range A1, copy/paste:
    Set wos = Word.Windows(1).Selection
    Sheet1.Range("A1").CopyPicture xlScreen, xlPicture
    wr.Collapse Direction:=wdCollapseEnd
    'Word.Range(End:=Word.Content.End - 2).PasteAndFormat wdPasteDefault
    wr.Paste


    wr.Collapse Direction:=wdCollapseEnd
    Word.Range.InsertAfter String(2, vbCrLf)
    'Word.Selection.EndKey Unit:=wdStory
    'Selection.InsertBreak Type:=wdPageBreak
    'word.Selection.Paste


    'Body, copy/paste OLEObject
    Word.Range.InsertAfter " " & String(2, vbCrLf)
    wr.Collapse Direction:=wdCollapseEnd
    'Word.Range(Start:=Word.Content.End - 2).PasteAndFormat wdPasteDefault
    Sheet1.OLEObjects(ole).Copy
    olMail.GetInspector.Display
    Sheet1.[A1].Select
    .GetInspector.Display
    wr.PasteSpecial Placement:=wdInLine, DataType:=wdPasteOLEObject


    'Body, copy/paste contents of sig.rtf, signature...
    'Adjust String()'s vbCrLf number to be below the oldObject due to its size.
    wr.InsertParagraphAfter
    wr.InsertBreak Type:=wdSectionBreakNextPage
    wr.InsertAfter String(22, vbCrLf)
    wr.Collapse Direction:=wdCollapseEnd
    'https://msdn.microsoft.com/en-us/vba/word-vba/articles/selection-insertfile-method-word
    wr.InsertFile sig, , , False, False


    'Word.Range(Start:=Word.Content.End - 2).PasteAndFormat wdPasteDefault
    'GetObject(sig).Range.Copy
    'wr.PasteSpecial Placement:=wdInLine, DataType:=wdPasteRTF
    'wr.Paste


    '.Attachments.Add e 'e is the full path to a file.
    .Display
    '.Send
  End With


TheEnd:
  Set olMail = Nothing
  Set olApp = Nothing
End Sub

Display More

Email based on Criteria ....

Participate now!

Share