Hello,
No one replied until now, so I'm including the code I meant, maybe I should have done it in the first place. I only need to pass data from an Excel worksheet to Outlook, defining/updating tasks or events for my own use, I don't need to send mail to anyone.
Can anyone please explain in a general way what the different parts of this code do, and if possible modify it to send data from the worksheet "Sheet1", range A2:A & lastrow in column A to the outlook tasks or events? What happens if some of the tasks defined in Excel are already present in Outlook?
Sub EmailTasks()
Dim objOut As Object
Dim objTask As Object
Dim objMenu As Object
Dim objCommand As Object
Dim blnCrt As Boolean
Dim aryMail() As String
Dim strMail As String
Dim intaddr As Integer
Dim i As Integer
Dim c As Range
Dim r As Range
Dim j As Long
j = ActiveSheet.[A65536].End(xlUp).Row
If j < 5 Then Exit Sub
With ActiveSheet
Set r = .Range(.[A5], .Cells(j, 1))
End With
On Error Resume Next
Set objOut = GetObject(, "Outlook.Application")
If objOut Is Nothing Then
Set objOut = CreateObject("Outlook.Application")
blnCrt = True
If objOut Is Nothing Then
MsgBox "Unable to start Outlook."
Exit Sub
End If
End If
On Error GoTo 0
For Each c In r.Cells
If c.Value <> vbNullString Then
Set objTask = objOut.CreateItem(3)
With objTask
.Display
.Assign
.Subject = Sheets("Master List").Range("A1").Value 'mudar folha
.Body = c & " - " & c.Offset(0, 1).Value
.DueDate = c.Offset(0, 4).Value
.ReminderTime = DateAdd("ww", -1, .DueDate)
End With
ReDim aryMail(0) As String
strMail = c.Offset(0, 2)
intaddr = 0
Do While InStr(1, strMail, Chr(10)) <> 0
If intaddr > 0 Then
ReDim Preserve aryMail(UBound(aryMail) + 1) As String
aryMail(UBound(aryMail)) = Left(strMail, InStr(1, strMail, Chr(10)) - 1)
strMail = Mid(strMail, InStr(1, strMail, Chr(10)) + 1, Len(strMail) - InStr(1, strMail, Chr(10)))
intaddr = intaddr + 1
Else
aryMail(0) = Left(strMail, InStr(1, strMail, Chr(10)) - 1)
strMail = Mid(strMail, InStr(1, strMail, Chr(10)) + 1, Len(strMail) - InStr(1, strMail, Chr(10)))
intaddr = intaddr + 1
End If
Loop
If Len(strMail) > 0 Then
If intaddr > 0 Then
ReDim Preserve aryMail(UBound(aryMail) + 1) As String
aryMail(UBound(aryMail)) = Trim(strMail)
Else
aryMail(0) = Trim(strMail)
End If
End If
With objTask
For i = 0 To UBound(aryMail)
.Recipients.Add aryMail(i)
Next
Set objMenu = objOut.ActiveInspector.CommandBars("Tools")
Set objCommand = objMenu.Controls("Check Names")
objCommand.Execute
Set objMenu = Nothing
Set objCommand = Nothing
On Error Resume Next
.Send
If Err <> 0 Then
.Close 1
Set objTask = objOut.CreateItem(3)
With objTask
.Display
.Subject = Sheets("Master List").Range("A1").Value
.Body = c & " - " & c.Offset(0, 1).Value
.DueDate = c.Offset(0, 4).Value
.ReminderTime = DateAdd("ww", -1, .DueDate)
.Close (0)
End With
End If
On Error GoTo 0
End With
Set objTask = Nothing
End If
Next
If blnCrt = True Then objOut.Quit
Set objTask = Nothing
Set objOut = Nothing
Set r = Nothing
End Sub
Thank you very much for any help.
Best Regards,
MrDoc
