VBA Macro to run email or task from Excel to Outlook

[slohman]

Can someone help I'm using the below macro but it will not recognise that I have blank rows.

I have due dates Column I some cells are blank because they are not due, I have subject in Column A, I have Body of Email in Column B & Column M

It works fine for the first 10 rows as they have dates but when there is a blank it just doesn't send any further emails. I think I need to change from range to cells but I have tried everything.

Sub emailTask()
Dim dateRow As Integer
With Sheets("Data1")
    dateRow = .Range("I4").End(xlDown).Row
    For i = 4 To dateRow
        If .Range("I" & i).Value < Date And Not .Range("E" & i) = "SENT" Then
            Call emailSue(i)
        End If
        
    Next i
End With
End Sub


Sub emailSue(i)
    Dim OutApp  As Object
    Dim OutMail  As Object
    
    On Error GoTo errorKey
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
    On Error Resume Next
    With OutMail
        .Subject = Sheets("Data1").Range("A" & i) & ""
        .Body = Sheets("Data1").Range("B" & i) & " - " & Sheets("Data1").Range("L" & i) & ""
        .Recipients.Add ("sue@safeplay.com.au")
        .Recipients.ResolveAll
        .Send    'direct send, if you want manual send, delete this row
    End With
    Sheets("Data1").Range("E" & i) = "SENT"
    
ContinueIt:
    Set OutMail = Nothing
    Set OutApp = Nothing
    Exit Sub
errorKey:
    MsgBox Err.Description
    Resume ContinueIt
End Sub

http://www.excelforum.com/excel-gen...m-excel-to-outlook.html?p=3327614#post3327614
http://www.ozgrid.com/forum/showthread.php?t=180820&p=675116#post675116

 

[Domenic]

Try...

Sub emailTask()
    Dim LastRow As Long
    With Sheets("Data1")
        LastRow = .Cells(.Rows.Count, "I").End(xlUp).Row
        If LastRow >= 4 Then
            For i = 4 To LastRow
                If Len(.Range("I" & i)) > 0 Then
                    If .Range("I" & i).Value < Date And Not .Range("E" & i) = "SENT" Then
                        Call emailSue(i)
                    End If
                End If
            Next i
        Else
            MsgBox "No data is available.", vbExclamation
        End If
    End With
End Sub

 

[slohman]

That worked great but I keep getting a allow or deny message when trying to send the email through Outlook you have to allow for each email and that is very time consuming. I have been trying to maybe use a task vba. I still need it to put a "Sent" when I have made a task so it doesn't duplicate everytime I run the macro but I cant seem to fix my code. This is what I have so far but with this also I don't think it will go past blank cells.

Sub CreateTasks()
    Dim olApp As Outlook.Application
    Dim olTask As Object
    Dim LastRow As Long
    Dim i As Long
    
    Set olApp = CreateObject("Outlook.Application")
    
    LastRow = Cells(Rows.Count, "I").End(xlUp).Row
    
    For i = 4 To LastRow
        If Cells(i, "I").Value <> "" Then
            Set olTask = olApp.CreateItem(3) 'olTaskItem
            With olTask
                .Subject = Cells(i, "A").Value & " - " & Cells(i, "B").Value
                .Body = "Please chase up - " & Cells(i, "L").Value & ""
                .Status = 1 'olTaskInProgress
                .Importance = 2 'olImportanceHigh
                .ReminderSet = True
                .ReminderTime = Cells(i, "I").Value + TimeValue("09:00:00")
                .Save
            End With
        End If
    Next i
        
End Sub

 

[Domenic]

To deal with the security warning, have a look here...

Disable the mail security dialog to Send/not Send the mail

 

[slohman]

That's great I will do a test. Is there anyway of getting a TASK instead of a email? That will put the send in once a task has been added to outlook. It just needs to be like the email vba macro but send a task.

 

[slohman]

I have revised the code to try and make a task/appointment but with no luck i get a user-defined type not defined error

Sub emailTask()    Dim LastRow As Long
    With Sheets("Data1")
        LastRow = .Cells(.Rows.Count, "I").End(xlUp).Row
        If LastRow >= 4 Then
            For i = 4 To LastRow
                If Len(.Range("I" & i)) > 0 Then
                    If .Range("I" & i).Value < Date And Not .Range("G" & i) = "SENT" Then
                        Call emailsue(i)
                    End If
                End If
            Next i
        Else
            MsgBox "No data is available.", vbExclamation
        End If
    End With
End Sub
Sub emailsue(i)
Dim OLApp As Outlook.Application
Dim OLAI As Outlook.AppointmentItem
Set OLApp = New Outlook.Application
Set OLAI = OLApp.CreateItem(olAppointmentItem)
With OLAI
        .Subject = Sheets("Data1").Range("A" & i) & ""
        .Body = Sheets("Data1").Range("B" & i) & " - " & Sheets("Data1").Range("M" & i) & ""
        .Start = Sheets("Date1").Range("I" & i).Value + TimeValue(time1 & ":09:00")
        .End = .Start + "00:30"
        .Location = Sheets("Data1").Range("M" & i)
    End With
    Sheets("Data1").Range("G" & i) = "SENT"
    
ContinueIt:
    Set OLAI = Nothing
    Set OLApp = Nothing
    Exit Sub
errorKey:
    MsgBox Err.Description
    Resume ContinueIt
End Sub

 

[Domenic]

You'll need to set a reference to the Microsoft Outlook Object Library as follows...

Visual Basic Editor (Alt+F11) > Tools > References > select/check Microsoft Outlook Object Library > OK

Also, you'll need to save your appointment. So you can add the following...

.Save

However, since you're marking your data as "SENT", it looks like you'll probably want to create a Meeting, instead of an Appointment.

 

[slohman]

I had already put the reference to Microsoft outlook. You mention about the save where would I put that. Or how would I change to a meeting? I don't know how to do that.