Problems with Outlook Express and Tasks

[Billy]

I am having a problem folks with code from Access to Outlook. My
program is pulling a report from a DB, which works fine, attaches it
to a email and sends it out. Which all work fine. But when it comes
to adding a task to the persons accouant is where the problem comes.
The tasks are made when todays date-end date of a contract < 60 and
This is run every time. The problem is when the first time it goes
through it is fine, but when the next time it runs it makes the same
task added to the account and that is not what I want. If the task
already exsists I do not want it added. Period. I have inclueded my
code below. Thank you for your help.

Billy


Function ContractCheck()

'Start of Error traper: Like we would have errors
'On Error GoTo BillyErrors:

Dim NowDate As Date
Dim DateEnd As Date
Dim TimeLeft As Single
Dim db As Database
Dim Rec As Recordset
Dim Message As Outlook.MailItem
Dim Task As Outlook.TaskItem
Dim fsokey As Object
Dim fsopress As Object
Dim Shell As Object

Set db = CurrentDb()

Set Rec = db.OpenRecordset("Contacts")

'Create a Mail Item
Set Message = Outlook.CreateItem(olMailItem)


'Set a Windows Shell session
Set Shell = CreateObject("Wscript.Shell")

'Set the FSO As an object to be able to run and make the VBS script
Set fsokey = CreateObject("Scripting.FileSystemObject")

'create the vbs script file
Set fsopress = fsokey.createTextFile("Pass.vbs")

'Create/Open Windows Scrpit
fsopress.WriteLine "Set fsokey=CreateObject(""WScript.Shell"")"

fsopress.WriteLine "While fsokey.AppActivate (""Microsoft
Outlook"")=TRUE"

'End of looping for the file
fsopress.WriteLine "Wend"

'Send Keys action which sends the command in to do Ctrl(%) and S which
will click the Send button automaticly
fsopress.WriteLine "fsokey.SendKeys ""%S"", True"

'End of VBS file
fsopress.close


'To Email Address
'Message.To = "(e-mail address removed)"
Message.To = "(e-mail address removed)"

DoCmd.OutputTo acOutputReport, "ContractRenewals", "RichTextFormat",
"C:\ContractRenewals.rtf", False

'Body of Email
Message.Body = "Attached is a report of contracts that expire within
the next 60 days." & vbNewLine & vbNewLine & vbNewLine

'Subject of Email
Message.Subject = "Contracts"

'Attach Report of Contracts that are going to expire in 60 Days
Message.Attachments.Add ("C:\ContractRenewals.rtf")

'Sets Importance to High
Message.Importance = olImportanceHigh

'Display message for getting around the security patch
Message.Display

'Runs Shell script of Pass.vbs
Shell.Run ("Pass.vbs")

Dim TaskName As NameSpace
Dim TaskFolder As MAPIFolder
Set TaskName = Outlook.GetNamespace("MAPI")
Set TaskFolder = TaskName.GetDefaultFolder(olFolderTasks)


For Each Task In TaskFolder.Items

Do While Not Rec.EOF

'Task Reminder Set
Set Task = Outlook.CreateItem(olTaskItem)

NowDate = DateTime.Date
DateEnd = Nz(Rec("End_Date"))
TimeLeft = (DateEnd) - (NowDate)


If TimeLeft <= 60 And TimeLeft > 0 And Task.Subject = "" Then

Task.Subject = Rec("Company") & " " & " " & "Contract Expires in:" & "
" & TimeLeft & " " & "days"
Task.Body = Rec("Company") & " " & vbNewLine & "Contract Expires in:"
& " " & TimeLeft & " " & "days" & _
vbNewLine & "Contract Link:" & " " & Rec("Contract")
Task.DueDate = DateAdd("d", TimeLeft, Now)
Task.ReminderTime = DateAdd("ww", 1, "01/19/2004 8:00AM")
Task.Importance = olImportanceHigh
Task.GetRecurrencePattern = (1)
Task.ReminderSet = True
Task.Status = olTaskInProgress
Task.Save

Rec.MoveNext
Else

Rec.MoveNext

End If
Loop
Next

Rec.close

BillyErrors:

If Err Then

MsgBox Err.Description, vbOKOnly, "Error"

End If
End Function

 

[Sue Mosher [MVP]]

I don't see anything in your code that checks to see whether the item
already exists. You can use the MAPIFolder.Items.Find method for this.
Alternatively, update the database to show that a task has already been
created for that record.
--
Sue Mosher, Outlook MVP
Author of
Microsoft Outlook Programming - Jumpstart for
Administrators, Power Users, and Developers