Prevent duplicates from being entered into the Task list

  • Thread starter Thread starter ryguy7272
  • Start date Start date
R

ryguy7272

I decided to start a new post because my other was answered, and I was
starting to get off the initial topic with a new question. How can I prevent
duplicates from being entered into the Task list? I may open an Excel tool on
Monday and update tasks for individuals. By the end of the week, as some time
has passed and new tasks are required, but some remain the same (or may not
be done until the following week, or instance), I want to run the code again,
but I don't want to enter the same name and time into my Task list (because
it is already there). I only want to enter the name and time if the name
and/or time is different. Can this be done? I am controlling everything from
Excel.

Below is my code; everything works fine...just want to set up a method to
prevent duplicate Tasks from being entered into the Task list in Outlook:
Sub GetOutlookReference()

Range("K2:K100").Clear
Range("E2:E100").Select
Selection.Copy
Range("K2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.NumberFormat = "m/d/yyyy"
Range("A1").Select


'Outlook objects
Dim olApp As Outlook.Application

'Obtain a reference to Outlook
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")

'*********************************************
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim l As Integer

i = 2
j = 2
k = 2
l = 2

Do Until Cells(i, 5).Value = ""
'*********************************************
Dim objApp As Object
Dim OutTask As Object

Set objApp = CreateObject("Outlook.Application")
Set OutTask = objApp.CreateItem(olTaskItem)
With OutTask
.StartDate = Cells(i, 5).Value
.Subject = Cells(j, 3).Value
.Body = Cells(k, 1).Value & " - " & Cells(l, 4).Value
.Importance = olImportanceHigh
'.Display
.ReminderSet = True
'.ReminderTime = [NextPM]
'.DueDate = [NextPM]
'.ReminderPlaySound = True
'.ReminderSoundFile = "C:\WINNT\Media\Ding.wav"
.Save
'.Close
End With
'*********************************************
l = l + 1
k = k + 1
j = j + 1
i = i + 1
Loop

'If Outlook isn't running, start it and remember
If olApp Is Nothing Then
Set olApp = CreateObject("Outlook.Application")
End If

' If Outlook still isn't running, Outlook cannot open or is not installed
If olApp Is Nothing Then
Call MsgBox("Outlook could not be opened. Exiting macro.", _
vbCritical, Application.Name)
End If

'Send the emial from here
If Range("L1").Value > Range("K1").Value Then
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

Set Sourcewb = ActiveWorkbook

'Copy the sheet to a new workbook
ActiveSheet.Copy
Set Destwb = ActiveWorkbook


With Destwb
If Val(Application.Version) < 12 Then

FileExtStr = ".xls": FileFormatNum = -4143
Else

If Sourcewb.Name = .Name Then
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Your answer is NO in the security dialog"
Exit Sub
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
End With


'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & "\"
TempFileName = "Task Roll Ups... " & Sourcewb.Name & " " & Format(Now,
"dd-mmm-yy h-mm-ss")

Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)

With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr,
FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.To = "(e-mail address removed)"
.CC = ""
.BCC = ""
.Subject = "Task Roll Ups"
.Body = "Please see attached..."
.Attachments.Add Destwb.FullName
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Display
End With
On Error GoTo 0
.Close SaveChanges:=False
End With

'Delete the file you have send
Kill TempFilePath & TempFileName & FileExtStr

Set OutMail = Nothing
Set OutApp = Nothing

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End If

End Sub

I feel like a lost sheep; not sure what to do next... Any help would be
greatly appreciated.

Regards,
Ryan--
 
Answered already in your other thread.




ryguy7272 said:
I decided to start a new post because my other was answered, and I was
starting to get off the initial topic with a new question. How can I
prevent
duplicates from being entered into the Task list? I may open an Excel tool
on
Monday and update tasks for individuals. By the end of the week, as some
time
has passed and new tasks are required, but some remain the same (or may
not
be done until the following week, or instance), I want to run the code
again,
but I don't want to enter the same name and time into my Task list
(because
it is already there). I only want to enter the name and time if the name
and/or time is different. Can this be done? I am controlling everything
from
Excel.

Below is my code; everything works fine...just want to set up a method to
prevent duplicate Tasks from being entered into the Task list in Outlook:
Sub GetOutlookReference()

Range("K2:K100").Clear
Range("E2:E100").Select
Selection.Copy
Range("K2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.NumberFormat = "m/d/yyyy"
Range("A1").Select


'Outlook objects
Dim olApp As Outlook.Application

'Obtain a reference to Outlook
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")

'*********************************************
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim l As Integer

i = 2
j = 2
k = 2
l = 2

Do Until Cells(i, 5).Value = ""
'*********************************************
Dim objApp As Object
Dim OutTask As Object

Set objApp = CreateObject("Outlook.Application")
Set OutTask = objApp.CreateItem(olTaskItem)
With OutTask
.StartDate = Cells(i, 5).Value
.Subject = Cells(j, 3).Value
.Body = Cells(k, 1).Value & " - " & Cells(l, 4).Value
.Importance = olImportanceHigh
'.Display
.ReminderSet = True
'.ReminderTime = [NextPM]
'.DueDate = [NextPM]
'.ReminderPlaySound = True
'.ReminderSoundFile = "C:\WINNT\Media\Ding.wav"
.Save
'.Close
End With
'*********************************************
l = l + 1
k = k + 1
j = j + 1
i = i + 1
Loop

'If Outlook isn't running, start it and remember
If olApp Is Nothing Then
Set olApp = CreateObject("Outlook.Application")
End If

' If Outlook still isn't running, Outlook cannot open or is not installed
If olApp Is Nothing Then
Call MsgBox("Outlook could not be opened. Exiting macro.", _
vbCritical, Application.Name)
End If

'Send the emial from here
If Range("L1").Value > Range("K1").Value Then
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

Set Sourcewb = ActiveWorkbook

'Copy the sheet to a new workbook
ActiveSheet.Copy
Set Destwb = ActiveWorkbook


With Destwb
If Val(Application.Version) < 12 Then

FileExtStr = ".xls": FileFormatNum = -4143
Else

If Sourcewb.Name = .Name Then
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Your answer is NO in the security dialog"
Exit Sub
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
End With


'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & "\"
TempFileName = "Task Roll Ups... " & Sourcewb.Name & " " & Format(Now,
"dd-mmm-yy h-mm-ss")

Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)

With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr,
FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.To = "(e-mail address removed)"
.CC = ""
.BCC = ""
.Subject = "Task Roll Ups"
.Body = "Please see attached..."
.Attachments.Add Destwb.FullName
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Display
End With
On Error GoTo 0
.Close SaveChanges:=False
End With

'Delete the file you have send
Kill TempFilePath & TempFileName & FileExtStr

Set OutMail = Nothing
Set OutApp = Nothing

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End If

End Sub

I feel like a lost sheep; not sure what to do next... Any help would be
greatly appreciated.

Regards,
Ryan--
Click to expand...
 
I know you gave me an answer Ken, but I don't know what it means. I googled
around for an answer this morning and I am still without a solution. If you
have a sub, or a function, or something else, please share. Otherwise, I
will just keep searching... Perhaps a solution will present itself soon. :)

Regards,
Ryan--

--
RyGuy


Ken Slovak - said:
Answered already in your other thread.




ryguy7272 said:
I decided to start a new post because my other was answered, and I was
starting to get off the initial topic with a new question. How can I
prevent
duplicates from being entered into the Task list? I may open an Excel tool
on
Monday and update tasks for individuals. By the end of the week, as some
time
has passed and new tasks are required, but some remain the same (or may
not
be done until the following week, or instance), I want to run the code
again,
but I don't want to enter the same name and time into my Task list
(because
it is already there). I only want to enter the name and time if the name
and/or time is different. Can this be done? I am controlling everything
from
Excel.

Below is my code; everything works fine...just want to set up a method to
prevent duplicate Tasks from being entered into the Task list in Outlook:
Sub GetOutlookReference()

Range("K2:K100").Clear
Range("E2:E100").Select
Selection.Copy
Range("K2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.NumberFormat = "m/d/yyyy"
Range("A1").Select


'Outlook objects
Dim olApp As Outlook.Application

'Obtain a reference to Outlook
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")

'*********************************************
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim l As Integer

i = 2
j = 2
k = 2
l = 2

Do Until Cells(i, 5).Value = ""
'*********************************************
Dim objApp As Object
Dim OutTask As Object

Set objApp = CreateObject("Outlook.Application")
Set OutTask = objApp.CreateItem(olTaskItem)
With OutTask
.StartDate = Cells(i, 5).Value
.Subject = Cells(j, 3).Value
.Body = Cells(k, 1).Value & " - " & Cells(l, 4).Value
.Importance = olImportanceHigh
'.Display
.ReminderSet = True
'.ReminderTime = [NextPM]
'.DueDate = [NextPM]
'.ReminderPlaySound = True
'.ReminderSoundFile = "C:\WINNT\Media\Ding.wav"
.Save
'.Close
End With
'*********************************************
l = l + 1
k = k + 1
j = j + 1
i = i + 1
Loop

'If Outlook isn't running, start it and remember
If olApp Is Nothing Then
Set olApp = CreateObject("Outlook.Application")
End If

' If Outlook still isn't running, Outlook cannot open or is not installed
If olApp Is Nothing Then
Call MsgBox("Outlook could not be opened. Exiting macro.", _
vbCritical, Application.Name)
End If

'Send the emial from here
If Range("L1").Value > Range("K1").Value Then
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

Set Sourcewb = ActiveWorkbook

'Copy the sheet to a new workbook
ActiveSheet.Copy
Set Destwb = ActiveWorkbook


With Destwb
If Val(Application.Version) < 12 Then

FileExtStr = ".xls": FileFormatNum = -4143
Else

If Sourcewb.Name = .Name Then
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Your answer is NO in the security dialog"
Exit Sub
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
End With


'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & "\"
TempFileName = "Task Roll Ups... " & Sourcewb.Name & " " & Format(Now,
"dd-mmm-yy h-mm-ss")

Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)

With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr,
FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.To = "(e-mail address removed)"
.CC = ""
.BCC = ""
.Subject = "Task Roll Ups"
.Body = "Please see attached..."
.Attachments.Add Destwb.FullName
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Display
End With
On Error GoTo 0
.Close SaveChanges:=False
End With

'Delete the file you have send
Kill TempFilePath & TempFileName & FileExtStr

Set OutMail = Nothing
Set OutApp = Nothing

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End If

End Sub

I feel like a lost sheep; not sure what to do next... Any help would be
greatly appreciated.

Regards,
Ryan--
Click to expand...
Click to expand...
 
I found this code on the web:
Sub Macro1()
Dim oldTask As TaskItem, newTask As TaskItem, j As Integer

Dim iCounter As Integer

Set myNameSpace = GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(olFolderTasks)
Set myItems = myFolder.Items

myItems.Sort "[File As]", olDescending
totalcount = myItems.Count
j = 1
While ((j < totalcount) And (myItems(j).Class <> olTask))
j = j + 1
Wend

Set oldTask = myItems(j)
For i = j + 1 To totalcount
If (myItems(i).Class = olTask) Then
'(newTask.Body = oldTask.Body) And _
Set newTask = myItems(i)
If ((newTask.Subject = oldTask.Subject)) Then
' (newTask.DueDate = oldTask.DueDate) And _
newTask.Mileage = "DELETEME"
iCounter = iCounter + 1
newTask.Save
End If
Set oldTask = newTask
End If
Next i
If iCounter = 0 Then
MsgBox "No duplicate Tasks were detected in " & totalcount & " Tasks!",
vbInformation, "No duplicates"
Else
MsgBox iCounter & " duplicate Tasks were detected and flagged!",
vbInformation, "Duplicates detected"
End If
End Sub

The logic looks sound, and it seems like it should work, but it does not
detect any duplicates in my Tasks folder, and I know there are several
duplicates in the folder. Any thoughts?

Regards,
Ryan---

--
RyGuy


ryguy7272 said:
I know you gave me an answer Ken, but I don't know what it means. I googled
around for an answer this morning and I am still without a solution. If you
have a sub, or a function, or something else, please share. Otherwise, I
will just keep searching... Perhaps a solution will present itself soon. :)

Regards,
Ryan--

--
RyGuy


Ken Slovak - said:
Answered already in your other thread.




ryguy7272 said:
I decided to start a new post because my other was answered, and I was
starting to get off the initial topic with a new question. How can I
prevent
duplicates from being entered into the Task list? I may open an Excel tool
on
Monday and update tasks for individuals. By the end of the week, as some
time
has passed and new tasks are required, but some remain the same (or may
not
be done until the following week, or instance), I want to run the code
again,
but I don't want to enter the same name and time into my Task list
(because
it is already there). I only want to enter the name and time if the name
and/or time is different. Can this be done? I am controlling everything
from
Excel.

Below is my code; everything works fine...just want to set up a method to
prevent duplicate Tasks from being entered into the Task list in Outlook:
Sub GetOutlookReference()

Range("K2:K100").Clear
Range("E2:E100").Select
Selection.Copy
Range("K2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.NumberFormat = "m/d/yyyy"
Range("A1").Select


'Outlook objects
Dim olApp As Outlook.Application

'Obtain a reference to Outlook
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")

'*********************************************
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim l As Integer

i = 2
j = 2
k = 2
l = 2

Do Until Cells(i, 5).Value = ""
'*********************************************
Dim objApp As Object
Dim OutTask As Object

Set objApp = CreateObject("Outlook.Application")
Set OutTask = objApp.CreateItem(olTaskItem)
With OutTask
.StartDate = Cells(i, 5).Value
.Subject = Cells(j, 3).Value
.Body = Cells(k, 1).Value & " - " & Cells(l, 4).Value
.Importance = olImportanceHigh
'.Display
.ReminderSet = True
'.ReminderTime = [NextPM]
'.DueDate = [NextPM]
'.ReminderPlaySound = True
'.ReminderSoundFile = "C:\WINNT\Media\Ding.wav"
.Save
'.Close
End With
'*********************************************
l = l + 1
k = k + 1
j = j + 1
i = i + 1
Loop

'If Outlook isn't running, start it and remember
If olApp Is Nothing Then
Set olApp = CreateObject("Outlook.Application")
End If

' If Outlook still isn't running, Outlook cannot open or is not installed
If olApp Is Nothing Then
Call MsgBox("Outlook could not be opened. Exiting macro.", _
vbCritical, Application.Name)
End If

'Send the emial from here
If Range("L1").Value > Range("K1").Value Then
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

Set Sourcewb = ActiveWorkbook

'Copy the sheet to a new workbook
ActiveSheet.Copy
Set Destwb = ActiveWorkbook


With Destwb
If Val(Application.Version) < 12 Then

FileExtStr = ".xls": FileFormatNum = -4143
Else

If Sourcewb.Name = .Name Then
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Your answer is NO in the security dialog"
Exit Sub
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
End With


'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & "\"
TempFileName = "Task Roll Ups... " & Sourcewb.Name & " " & Format(Now,
"dd-mmm-yy h-mm-ss")

Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)

With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr,
FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.To = "(e-mail address removed)"
.CC = ""
.BCC = ""
.Subject = "Task Roll Ups"
.Body = "Please see attached..."
.Attachments.Add Destwb.FullName
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Display
End With
On Error GoTo 0
.Close SaveChanges:=False
End With

'Delete the file you have send
Kill TempFilePath & TempFileName & FileExtStr

Set OutMail = Nothing
Set OutApp = Nothing

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End If

End Sub

I feel like a lost sheep; not sure what to do next... Any help would be
greatly appreciated.

Regards,
Ryan--
Click to expand...
Click to expand...
Click to expand...
 
That code would iterate the entire contents of the folder, which would be
slow if a lot of items are in there.

First decide what properties make the task a duplicate. Then open the Object
Browser and select Items. Go to the Restrict method in the right-hand pane
and click the Help button. That will show you a number of examples of using
Restrict to return a restricted collection of those items that might be
duplicates.

For example you might set your restriction on Subject and on DueDate. The
help shows how to use both string tests and date tests. When you get back
the restricted collection if Count = 0 then you have no potential dupes. If
Count > 0 then examine each item in the restricted collection more closely
to decide if it really is a dupe.




ryguy7272 said:
I found this code on the web:
Sub Macro1()
Dim oldTask As TaskItem, newTask As TaskItem, j As Integer

Dim iCounter As Integer

Set myNameSpace = GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(olFolderTasks)
Set myItems = myFolder.Items

myItems.Sort "[File As]", olDescending
totalcount = myItems.Count
j = 1
While ((j < totalcount) And (myItems(j).Class <> olTask))
j = j + 1
Wend

Set oldTask = myItems(j)
For i = j + 1 To totalcount
If (myItems(i).Class = olTask) Then
'(newTask.Body = oldTask.Body) And _
Set newTask = myItems(i)
If ((newTask.Subject = oldTask.Subject)) Then
' (newTask.DueDate = oldTask.DueDate) And _
newTask.Mileage = "DELETEME"
iCounter = iCounter + 1
newTask.Save
End If
Set oldTask = newTask
End If
Next i
If iCounter = 0 Then
MsgBox "No duplicate Tasks were detected in " & totalcount & " Tasks!",
vbInformation, "No duplicates"
Else
MsgBox iCounter & " duplicate Tasks were detected and flagged!",
vbInformation, "Duplicates detected"
End If
End Sub

The logic looks sound, and it seems like it should work, but it does not
detect any duplicates in my Tasks folder, and I know there are several
duplicates in the folder. Any thoughts?

Regards,
Ryan---

--
RyGuy


ryguy7272 said:
I know you gave me an answer Ken, but I don't know what it means. I
googled
around for an answer this morning and I am still without a solution. If
you
have a sub, or a function, or something else, please share. Otherwise, I
will just keep searching... Perhaps a solution will present itself soon.
:)

Regards,
Ryan--
Click to expand...
Click to expand...
 
Hey Ken! Again, thanks for the info. I know I should look in the Object
Browser to understand the Classes and Items better. The Restrict examples
were good, but unfortunately I'm still not getting it. I'm not sure this is
a 'Restrict' issue. I'm not trying to restrict Tasks to a certain type (such
as Business, as shown in the examples). Is it too complex for you to send me
an example on how to count Tasks (i.e. it requires too much customization) or
do you just want me to learn by trial and error how to do this?

This is what I have now, and I still end up with dupes in my Tasks folder:
Dim oldTask As TaskItem, newTask As TaskItem, a As Integer
Dim bCounter As Integer
Set myNameSpace = GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(olFolderTasks)
Set myItems = myFolder.Items
totalcount = myItems.Count
a = 1
While ((a < totalcount) And (myItems(a).Class <> olTask))
a = a + 1
Wend
Set oldTask = myItems(a)
For b = a + 1 To totalcount

If (myItems(b).Class = olTask) Then
Set newTask = myItems(b)
If ((newTask.Subject = oldTask.Subject)) Then
newTask.Subject = Delete
bCounter = bCounter + 1
newTask.Save
End If
Set oldTask = newTask
End If
Next b
....etc...

I can only assume that the items in the Task folder are not being counted
properly because I can never seem to identify these dupes, and thus I always
end up with several dupes in the Task folder. I believe the whole problem
boils down to this issue. I guess I'll keep at it for a while longer. If
anyone knows how to resolve this issue, please let me know.


Regards,
Ryan--


--
RyGuy


Ken Slovak - said:
That code would iterate the entire contents of the folder, which would be
slow if a lot of items are in there.

First decide what properties make the task a duplicate. Then open the Object
Browser and select Items. Go to the Restrict method in the right-hand pane
and click the Help button. That will show you a number of examples of using
Restrict to return a restricted collection of those items that might be
duplicates.

For example you might set your restriction on Subject and on DueDate. The
help shows how to use both string tests and date tests. When you get back
the restricted collection if Count = 0 then you have no potential dupes. If
Count > 0 then examine each item in the restricted collection more closely
to decide if it really is a dupe.




ryguy7272 said:
I found this code on the web:
Sub Macro1()
Dim oldTask As TaskItem, newTask As TaskItem, j As Integer

Dim iCounter As Integer

Set myNameSpace = GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(olFolderTasks)
Set myItems = myFolder.Items

myItems.Sort "[File As]", olDescending
totalcount = myItems.Count
j = 1
While ((j < totalcount) And (myItems(j).Class <> olTask))
j = j + 1
Wend

Set oldTask = myItems(j)
For i = j + 1 To totalcount
If (myItems(i).Class = olTask) Then
'(newTask.Body = oldTask.Body) And _
Set newTask = myItems(i)
If ((newTask.Subject = oldTask.Subject)) Then
' (newTask.DueDate = oldTask.DueDate) And _
newTask.Mileage = "DELETEME"
iCounter = iCounter + 1
newTask.Save
End If
Set oldTask = newTask
End If
Next i
If iCounter = 0 Then
MsgBox "No duplicate Tasks were detected in " & totalcount & " Tasks!",
vbInformation, "No duplicates"
Else
MsgBox iCounter & " duplicate Tasks were detected and flagged!",
vbInformation, "Duplicates detected"
End If
End Sub

The logic looks sound, and it seems like it should work, but it does not
detect any duplicates in my Tasks folder, and I know there are several
duplicates in the folder. Any thoughts?

Regards,
Ryan---

--
RyGuy


ryguy7272 said:
I know you gave me an answer Ken, but I don't know what it means. I
googled
around for an answer this morning and I am still without a solution. If
you
have a sub, or a function, or something else, please share. Otherwise, I
will just keep searching... Perhaps a solution will present itself soon.
:)

Regards,
Ryan--
Click to expand...
Click to expand...
Click to expand...
 
Well, first of all for Restrict it would be something like this, assuming
your test is on Subject:

' previous code
Set myItems = myFolder.Items
Dim colRestrict as Outlook.Items
Set colRestrict = myItems.Restrict("[Subject] = " & Chr(34) &
newTask.Subject & Chr(34))
If colRestrict.Count = 0 Then ' no items with that Subject
'blah, blah, whatever
Else ' there is at least one dupe
' find the dupe and delete it
If colRestrict.Count = 1 Then
colRestrict.Items(1).Delete
Else
For i = colRestrict.Count To 1 Step -1
colRestrict.Items(i).Remove
Next
End If

When deleting items from a collection using a For loop never use a count up
loop. As you delete the index gets decremented so you will miss 1/2 of the
items. Use a count down loop as shown.

I think that Restrict example on Subject is probably the sort of thing you
need.
 
Resolved
http://www.microsoft.com/office/com...a30-85c950897aab&cat=&lang=en&cr=US&sloc=&p=1



--
RyGuy


Ken Slovak - said:
Well, first of all for Restrict it would be something like this, assuming
your test is on Subject:

' previous code
Set myItems = myFolder.Items
Dim colRestrict as Outlook.Items
Set colRestrict = myItems.Restrict("[Subject] = " & Chr(34) &
newTask.Subject & Chr(34))
If colRestrict.Count = 0 Then ' no items with that Subject
'blah, blah, whatever
Else ' there is at least one dupe
' find the dupe and delete it
If colRestrict.Count = 1 Then
colRestrict.Items(1).Delete
Else
For i = colRestrict.Count To 1 Step -1
colRestrict.Items(i).Remove
Next
End If

When deleting items from a collection using a For loop never use a count up
loop. As you delete the index gets decremented so you will miss 1/2 of the
items. Use a count down loop as shown.

I think that Restrict example on Subject is probably the sort of thing you
need.




ryguy7272 said:
Hey Ken! Again, thanks for the info. I know I should look in the Object
Browser to understand the Classes and Items better. The Restrict examples
were good, but unfortunately I'm still not getting it. I'm not sure this
is
a 'Restrict' issue. I'm not trying to restrict Tasks to a certain type
(such
as Business, as shown in the examples). Is it too complex for you to send
me
an example on how to count Tasks (i.e. it requires too much customization)
or
do you just want me to learn by trial and error how to do this?

This is what I have now, and I still end up with dupes in my Tasks folder:
Dim oldTask As TaskItem, newTask As TaskItem, a As Integer
Dim bCounter As Integer
Set myNameSpace = GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(olFolderTasks)
Set myItems = myFolder.Items
totalcount = myItems.Count
a = 1
While ((a < totalcount) And (myItems(a).Class <> olTask))
a = a + 1
Wend
Set oldTask = myItems(a)
For b = a + 1 To totalcount

If (myItems(b).Class = olTask) Then
Set newTask = myItems(b)
If ((newTask.Subject = oldTask.Subject)) Then
newTask.Subject = Delete
bCounter = bCounter + 1
newTask.Save
End If
Set oldTask = newTask
End If
Next b
...etc...

I can only assume that the items in the Task folder are not being counted
properly because I can never seem to identify these dupes, and thus I
always
end up with several dupes in the Task folder. I believe the whole problem
boils down to this issue. I guess I'll keep at it for a while longer. If
anyone knows how to resolve this issue, please let me know.


Regards,
Ryan--
Click to expand...
Click to expand...
 
Back
Top