Thread: email range based on date value

Hi all,
Im having trouble with a worksheet that i am running,

the worksheet data is:
B3: ACTIONS C3: DATE D3: COMMENTS
B4: TASK1 C4: 25/1/10 D4: RANDOM COMMENT HERE
B5: TASK2 C5: 4/3/10 D5: RANDOM COMMENT HERE
B6: TASK3 C6: 3/3/10 D6: RANDOM COMMENT HERE
B7: TASK4 C7: 19/5/10 D7: RANDOM COMMENT HERE

and so on untill about row 200 or so

what i need is:

if c4 > todays date + 10 then email cells b4, c4 and d4 (in the body of the email) to whoever@something.com
if c5 > todays date + 10 then email cells b5, c5 and d5 (in the body of the email) to whoever@something.com

I would prefer if the emails could be seperate rather than all tasks being on one email, but it doesnt matter

i am using this for a kinda work to list so for example if out of the whole sheet there was only 2 dates due i would recieve 2 emails and could work through them, when they are finished i would delete the emails then delete them from the excel sheet

I know its a kinda funny request but it would make my life a lot easier.

Also if anyone does come up with anything could you please explain what the different parts of the macro are doing so i can learn from it and possibly help others in the future.

P.s i use outlook express 6

thanks for your help

Hello ''your code here,

This was quite a challenge. The macro will read the data on the worksheet, combine the cell information and then email it provided the date is greater than 10 days from today. Once the email is displayed, you will need to click Send or Cancel. This process will be repeated until there are no more emails to be sent.

What makes this tricky is allowing the user to manually send the email fro Outlook Express and return back to Excel. Seems like it should be easy. This code will show you that there is a lot more "under the hood" to make this happen. The real work is done by the API (Application Programming Interface) code.

In the macro SendEmails you will need to change the recipient's email address (SendTo) and the subject line (Subject) to what you want to use. If you want to send the emails to more than one recipient, let me know.

[bPlace this Code in a Separate VBA Module[/b]

Code:

'Written: March 17, 2010
'Author:  Leith Ross
'Summary: Start Outlook Express and send emails from a worksheet.

 Private Const NORMAL_PRIORITY_CLASS = &H20&
 Private Const WAIT_INFINITE = -1&
 Private Const SYNCHRONIZE = &H100000

 Private Type STARTUPINFO
      cb As Long
      lpReserved As String
      lpDesktop As String
      lpTitle As String
      dwX As Long
      dwY As Long
      dwXSize As Long
      dwYSize As Long
      dwXCountChars As Long
      dwYCountChars As Long
      dwFillAttribute As Long
      dwFlags As Long
      wShowWindow As Integer
      cbReserved2 As Integer
      lpReserved2 As Long
      hStdInput As Long
      hStdOutput As Long
      hStdError As Long
 End Type

 Private Type PROCESS_INFORMATION
      hProcess As Long
      hThread As Long
      dwProcessId As Long
      dwThreadID As Long
 End Type

 Private Declare Function CreateProcess _
   Lib "kernel32" _
     Alias "CreateProcessA" _
       (ByVal lpApplicationName As String, _
        ByVal lpCommandLine As String, _
        ByVal lpProcessAttributes As Long, _
        ByVal lpThreadAttributes As Long, _
        ByVal bInheritHandles As Long, _
        ByVal dwCreationFlags As Long, _
        ByVal lpEnvironment As Long, _
        ByVal lpCurrentDirectory As String, _
        ByRef lpStartupInfo As STARTUPINFO, _
        ByRef lpProcessInformation As PROCESS_INFORMATION) As Long

 Private Declare Function WaitForSingleObject _
   Lib "kernel32.dll" _
     (ByVal hHandle As Long, _
      ByVal dwMilliseconds As Long) As Long
      
 Private Declare Function CloseHandle _
   Lib "kernel32" _
     (ByVal hObject As Long) As Long
  
'This converts long file names to short names with no spaces
 Private Declare Function GetShortPathName _
   Lib "kernel32.dll" _
     Alias "GetShortPathNameA" _
       (ByVal longPath As String, _
        ByVal shortPath As String, _
        ByVal shortBufferSize As Long) As Long
 
Sub SendEmailFromOE(ByVal SendTo As String, ByVal Subject As String, ByVal Msg As String)

  Dim cmdline As String
  Dim PI As PROCESS_INFORMATION
  Dim progPath As String
  Dim shortBuffer As String
  Dim SI As STARTUPINFO
  Dim StartPath As String
  Dim RetVal As Long
  
    'Get path to Outlook Express
     App = Environ("ProgramFiles") & "\Outlook Express\msimn.exe"
    
    'Setup the command line arguments
     cmdline = " /mailurl:MailTo:" & SendTo & "?Subject=" & Subject & "&Body=" & Msg
         
    'Set the length of the StartupInfo block
     SI.cb = Len(SI)
     
    'Start the shelled application:
     RetVal = CreateProcess(lpApplicationName:=App, _
                            lpCommandLine:=cmdline, _
                            lpProcessAttributes:=0, _
                            lpThreadAttributes:=0, _
                            bInheritHandles:=1, _
                            dwCreationFlags:=NORMAL_PRIORITY_CLASS, _
                            lpEnvironment:=0, _
                            lpCurrentDirectory:=StartPath, _
                            lpStartupInfo:=SI, _
                            lpProcessInformation:=PI)

    'Wait for Outlook Express to close
     RetVal = WaitForSingleObject(PI.hProcess, WAIT_INFINITE)
     
    'Free the handle to be reused
     CloseHandle PI.hProcess
     
End Sub

Sub SendEmails()

 'Send emails and allow user to send them manually one at a time.
 
  Dim Cell As Range
  Dim DueDate As Date
  Dim Rng As Range
  Dim RngEnd As Range
  Dim Wks As Worksheet
  
    SendTo = "towhomever@something.com"  '<<<<< Change Recipient Email Address
    Subject = "Subject line text"        '<<<<< Change Subject Line

    Set Wks = Worksheets("Sheet1")
    
   'Dynamically size the range
    Set Rng = Wks.Range("B4")
    Set RngEnd = Wks.Cells(Rows.Count, Rng.Column).End(xlUp)
    
   'Exit if there is no data
    If RngEnd.Row < Rng.Row Then Exit Sub
    
   'Cells B3:D3 to Bx:Dx
    Set Rng = Wks.Range(Rng, RngEnd).Resize(ColumnSize:=3)
      
      DueDate = Int(Now()) + 10
      
     'Check dates and send email
      For Each Cell In Rng.Columns(2).Cells
        If Cell > DueDate Then
           Msg = Cell.Offset(0, -1) & " " & Cell & " " & Cell.Offset(0, 1)
           SendEmailFromOE SendTo, Subject, Msg
        End If
      Next Cell
      
End Sub

Hello your code goes here,

Actually, it didn't take me that long to do. Your question isn't cheeky. The problem with fully automating your email process is that Outlook Express does not support automation. There is no easy way to click the "Send" button nor any VBA code to directly access it. It is very easy do what you want with Outlook because it was designed for automation. Truthfully, if want to automate the process then you need to use Outlook.

Hello Pete,

I changed the code to search for the dates in column "E" and extract the cells in column "A:F". The cells are separated by spaces. Yo may want to add new line characters to format the mail message the way you want.

Code:

Sub SendEmails()

 'Send emails and allow user to send them manually one at a time.
 
  Dim Cell As Range
  Dim DueDate As Date
  Dim Rng As Range
  Dim RngEnd As Range
  Dim Wks As Worksheet
  
    SendTo = "towhomever@something.com"  '<<<<< Change Recipient Email Address
    Subject = "Subject line text"        '<<<<< Change Subject Line

    Set Wks = Worksheets("Sheet1")
    
   'Get the size the date column
    Set Rng = Wks.Range("E4")
    Set RngEnd = Wks.Cells(Rows.Count, Rng.Column).End(xlUp)
    
   'Exit if there is no data
    If RngEnd.Row < Rng.Row Then Exit Sub
    
   'Cells A4:F4 to Ax:Fx
    Set Rng = Wks.Range(Rng, RngEnd).Offset(0, -4).Resize(ColumnSize:=6)
      
      DueDate = Int(Now()) + 10
      
     'Check dates and send email
      For Each Cell In Rng.Columns(5).Cells
        If Cell > DueDate Then
           Msg = Cell.Offset(0, -4) & " " _
               & Cell.Offset(0, -3) & " " _
               & Cell.Offset(0, -2) & " " _
               & Cell.Offset(0, -1) & " " _
               & Cell.Offset(0, 0) & " " _
               & Cell.Offset(0, 1)
           SendEmailFromOE SendTo, Subject, Msg
        End If
      Next Cell
      
End Sub

Originally Posted by Leith Ross

Hello Pete,

I changed the code to search for the dates in column "E" and extract the cells in column "A:F". The cells are separated by spaces. Yo may want to add new line characters to format the mail message the way you want.

Code:

Sub SendEmails()

 'Send emails and allow user to send them manually one at a time.
 
  Dim Cell As Range
  Dim DueDate As Date
  Dim Rng As Range
  Dim RngEnd As Range
  Dim Wks As Worksheet
  
    SendTo = "towhomever@something.com"  '<<<<< Change Recipient Email Address
    Subject = "Subject line text"        '<<<<< Change Subject Line

    Set Wks = Worksheets("Sheet1")
    
   'Get the size the date column
    Set Rng = Wks.Range("E4")
    Set RngEnd = Wks.Cells(Rows.Count, Rng.Column).End(xlUp)
    
   'Exit if there is no data
    If RngEnd.Row < Rng.Row Then Exit Sub
    
   'Cells A4:F4 to Ax:Fx
    Set Rng = Wks.Range(Rng, RngEnd).Offset(0, -4).Resize(ColumnSize:=6)
      
      DueDate = Int(Now()) + 10
      
     'Check dates and send email
      For Each Cell In Rng.Columns(5).Cells
        If Cell > DueDate Then
           Msg = Cell.Offset(0, -4) & " " _
               & Cell.Offset(0, -3) & " " _
               & Cell.Offset(0, -2) & " " _
               & Cell.Offset(0, -1) & " " _
               & Cell.Offset(0, 0) & " " _
               & Cell.Offset(0, 1)
           SendEmailFromOE SendTo, Subject, Msg
        End If
      Next Cell
      
End Sub

--------------------
Hi

It is still going through outlook express. Will it not work with MIcrosoft Outlook ?

regards
sanjay