Create Task in Outlook using excel vba

[sanits591]

Hi,

I have searched for a code which can create a task in outlook using excel vba, but somehow it is not working. The VBA code is as:

Request to help me out on this.

Sub CreateTaskBatch()
     ' After referencing MS Outlook objects, we can use them in our script
    Dim olApp As Outlook.Application
    Dim olTsk As TaskItem
    Dim RangeStart As Integer ' Used for looping
    Dim RangeEnd As Integer ' Used for looping
    Dim DueDate As Date
    Dim i As Integer
     
     ' Set up the Loop Start Point
    RangeStart = 3
     ' Obtain Range End from the Current User (Loop End iterator)
    
    RangeEnd = InputBox("Please supply the last Row Number for your list of Engineering Requests?", _
    "Range End Required")
     'RangeEnd = InputBox("Please provide the end of the Range (Number)?",
     '"Require Range End", 2, 100, 100, 0)
     ' Incorporate a Backdoor Exit for the Loop, in the event that the User enters incorrect information
     ' or if the User realises that they want to quit this function before it runs.
     'or if nothing is type into Row 2
    If (RangeEnd = -1) Or (Sheets("task").Cells(RangeStart, "A") = "") Then
        olApp = Nothing ' Clear Object from System Memory
        olTsk = Nothing ' Clear Task Object from Memory
        Exit Sub ' Completely close down the Sub
    Else
         ' If the user entered valid data, continue with Memory Addressing
         ' and Create new Object instances
        Set olApp = New Outlook.Application
        Set olTsk = olApp.CreateItem(olTaskItem)
         ' Set up the Looping function
         ' We will use a for..next loop since we know the starting and ending points of this loop
         ' which is from Row 2 (just below column headings) up to whatever row number is last occupied by data
         ' We set these variables at the very top of this Script
         
         ' NOW RUN THE LOOP
        For i = RangeStart To RangeEnd
            With olTsk
                .Subject = Sheets("task").Cells(i, "c") ' I hardcode Column Access for easy maintenance later
                 ' i is the current row number within the loop. With each iteration it will increase to (i + 1)
                 ' Supported by the call to "Next i"
                .StartDate = Sheets("task").Cells(i, "A")
                 
                 ' I noticed that a lot of the records have nothing n the Due Date column. This will cause programming errors
                 ' so I check here if it is empty, and if so: I set the date to today
                If Sheets("task").Cells(i, "b") = "" Then
                    DueDate = Now
                Else
                    .DueDate = Sheets("task").Cells(i, "b")
                End If
                 
                 ' Since the Engineers type/select a Text version as the Status Option, We must parse
                 ' The physical Text. Thus, I hardcode all the text entries they can possibly make here and
                 ' relate my text entry with an actual MS Outlook Status.Object
                Select Case Sheets("Task").Cells(i, "D")
                Case "Completed"
                    .Status = olTaskComplete
                Case "In Progress"
                    .Status = olTaskInProgress
                Case "Deferred"
                    .Status = olTaskDeferred
                Case "Not Started"
                    .Status = olTaskNotStarted
                Case "Waiting on someone"
                    .Status = olTaskWaiting
                End Select
                 
                 ' We will do another Select Statement to establish the Importance/Priority
                Select Case Sheet1.Cells(i, "E")
                Case "(1) High"
                    .Importance = olImportanceHigh
                Case "(2) Normal"
                    .Importance = olImportanceNormal
                Case "(3) Low"
                    .Importance = olImportanceLow
                End Select
                 
                 ' Percentage Completion (Real Number)
                .TotalWork = 100 - Sheets("task").Cells(i, "f")
                .ActualWork = Sheets("task").Cells(i, "f")
                .DateCompleted = Sheets("task").Cells(i, "g")
                .Owner = Sheets("task").Cells(i, "h")
                .Save ' Save the Current Loop Iteration Task
                .ContactNames = "nitin.d.sharma@live.com"
            End With
        Next i ' Move on to the Next Row
    End If
     
    Set olTsk = Nothing
    Set olApp = Nothing
     
    MsgBox "The Engineering Request Tasks have uploaded successfully!", vbInformation
End Sub

 

[sanits591]

Thanks to this forum!

I invested time on it and got this code working with a little bit modification, but at two stages, i.e. datecompleted, & totalwork, i got stuck up, request for help!

Here the code is:

Option Explicit

Sub Create_Task_and_email_it_to_recipient()
'You must set a reference to the Microsoft Outlook Object Library x.x via
'the Tools | Reference...in the VB-editor.
Dim olApp As Outlook.Application
Dim olTask As Outlook.TaskItem
Dim Subject As String
Dim Body As String
Dim StartDate As Date
Dim DueDate As Date
Dim DateCompleted As Date
Dim Status As String
Dim Importance As String
Dim i As Integer
'Dim TotWork As Double
'Dim ActWork As Double
Dim owner As String
Dim ContactNames As String
Dim Name As String
Dim MailID As String
Dim ReminderYesNo As String
Dim ReminderDate As Date
Dim RemPlaySound As String
Dim CategoryMarking As String


Dim wbBook As Workbook
Dim wsMain As Worksheet

Set wbBook = ThisWorkbook
Set wsMain = wbBook.Worksheets("task")

Application.ScreenUpdating = False

For i = 3 To 1000
If Cells(i, 1) = "" Then
Exit Sub

Else

    With wsMain
    Subject = .Cells(i, 3).Value
    StartDate = .Cells(i, 1).Value
    DueDate = .Cells(i, 2).Value
    Body = .Cells(i, 8).Value
    Status = .Cells(i, 4).Value
    Importance = .Cells(i, 5).Value
'    TotWork = 100 - .Cells(i, 6)
'    ActWork = .Cells(i, 6)
'    DateCompleted = .Cells(i, "g")
    owner = Sheets("task").Cells(i, "h")
    'Save ' Save the Current Loop Iteration Task
    ContactNames = "nitin.d.sharma@live.com"
    'Name = .Cells(i, 9)
    MailID = .Cells(i, 9)
    CategoryMarking = .Cells(i, 15)
    ReminderYesNo = .Cells(i, 11)
    ReminderDate = .Cells(i, 12)
    RemPlaySound = .Cells(i, 13)
    End With

On Error GoTo Error_Handling
Set olApp = GetObject(, "Outlook.Application")
Set olTask = olApp.CreateItem(3)


With olTask
.Subject = Subject
.StartDate = StartDate
.DueDate = DueDate
        'for status
        If Cells(i, 4).Value = "Completed" Then
        .Status = olTaskComplete

        ElseIf Cells(i, 4).Value = "In Progress" Then
        .Status = olTaskInProgress

        ElseIf Cells(i, 4).Value = "Deferred" Then
        .Status = olTaskDeferred

        ElseIf Cells(i, 4).Value = "Not Started" Then
        .Status = olTaskNotStarted

        ElseIf Cells(i, 4).Value = "Waiting on someone else" Then
        .Status = olTaskWaiting
        End If
        
        'for type of importance
        If Cells(i, 5).Value = "High - 2" Then
            .Importance = olImportanceHigh
        ElseIf Cells(i, 5).Value = "Normal - 1" Then
            .Importance = olImportanceNormal
        ElseIf Cells(i, 5).Value = "Low - 0" Then
            .Importance = olImportanceLow
        End If

'                 ' Percentage Completion (Real Number)
        '.TotalWork = TotWork
        '.actualwork = ActWork

'for date completed
'        If Cells(i, 7).Value = "" Then
'            .DateCompleted = ""
'        Else
'            .DateCompleted = Cells(i, 7)
'        End If
.owner = Sheets("task").Cells(i, "h")
.Save ' Save the Current Loop Iteration Task
.ContactNames = "nitin.d.sharma@live.com"
.Categories = CategoryMarking
.Body = Body
.Recipients.Add (MailID)
.Assign
'Assign is necessary to "give" the task to someone else. Otherwise, you will take ownership of the Task,
'and you cannot send it to another person.
'The Assign command allows you to watch the status of the task, but gives the ownership to the recipient.
'            .Recipients.Add (sRecipient)
'            oRecipient.Type = 1 '1 = To, use 2 for cc
.ReminderSet = ReminderYesNo
.ReminderTime = ReminderDate
.ReminderPlaySound = RemPlaySound
.ReminderSoundFile = "C:\Windows\Media\Ding.wav"

.Display 'or .send can be for the task if it is to be sent
.Save
End With

End If

Next i

olApp.Quit

Application.ScreenUpdating = True

MsgBox "The task added into Outlook Tasklist and addressed by email to Recipient successfully.", vbInformation

Exit_Here:
Set olTask = Nothing
Set olApp = Nothing
Exit Sub

Error_Handling:
If Err.Number = 429 And olApp Is Nothing Then
Set olApp = CreateObject("Outlook.Application")
Resume Next
Else
MsgBox "Error No: " & Err.Number & "; Description: "
Resume Exit_Here
End If
End Sub

 

[hetterbr]

The below VBA was created by some input from a few people here. it creates a task in outlook.

every time you run it, it checks to ensure that it is not double posting an entry. I have it working quite nicely on a spreadsheet that I am developing for monitoring contracts for our organization.

At this point, it sets the review time as 12am, which works, but I want to have that at at different time. so working on that. but other than that it works well.

enjoy,


Sub CheckBinding()
Dim olApp As Outlook.Application
Set olApp = New Outlook.Application
MsgBox olApp.Name
End Sub
Sub CreateTask()
Dim olApp As New Outlook.Application
Dim olName As Outlook.Namespace
Dim olFolder As Outlook.Folder
Dim olTasks As Outlook.Items
Dim olNewTask As Outlook.TaskItem
Dim strSubject As String
Dim strDate As String
Dim strBody As String
Dim reminderdate As String
Dim ws As Worksheet
Dim LR As Long
Dim i As Long
Set ws = Worksheets("sheet1") 'sheet where dates are
Set wg = Worksheets("sheet2") 'sheet where data is calculated
LR = ws.Range("D1").End(xlDown).Row 'get row for last cell in column D with value
Set olName = olApp.GetNamespace("MAPI")
Set olFolder = olName.GetDefaultFolder(olFolderTasks)
Set olTasks = olFolder.Items
For i = 2 To LR 'assuming the rows have headers, so loop starts on row 2
strSubject = ws.Range("D" & i) 'takes subject from column D
strDate = ws.Range("C" & i) 'takes date from column C
strBody = ws.Range("O" & i) 'takes text from column E and adds it as Body
reminderdate = wg.Range("D" & i) 'Takes date from column D and enters it as the reminder date
Set olNewTask = olTasks.Add(olTaskItem)
'delete task if it exists
'an error is generated if task doesn't exist
On Error Resume Next
olTasks.Item (strSubject)
If Err.Number = 0 Then
olTasks.Item(strSubject).Delete
End If
On Error GoTo 0
'create new task
With olNewTask
.Subject = strSubject
.Status = olTaskInProgress
.Importance = olImportanceNormal
.DueDate = DateValue(strDate)
.Body = strBody
.ReminderSet = True
.remindertime = reminderdate
.TotalWork = 40
.ActualWork = 20
.Save
End With
Next i
End Sub