Attribute VB_Name = "MarkTools"
Public Sub MarkDuplicateContacts()
Dim oldcontact As ContactItem, newcontact As ContactItem, j As Integer
Dim lCount As Long
Set mynamespace = GetNamespace("MAPI")
Set myfolder = mynamespace.GetDefaultFolder(olFolderContacts)
Set myitems = myfolder.Items
'Sort Contacts
myitems.Sort "[File As]", olDescending
totalcount = myitems.Count
j = 1
'Find first valid contact
While ((j < totalcount) And (myitems(j).Class <> olContact))
  j = j + 1
Wend
Set oldcontact = myitems(j)
'Process each contact from there on
'This loop compares only contacts before and after the current one
'since the list is sorted, this should work correctly as contacts
'with the same name WILL be next to each other
'This is a standard linear algorithm with a performance of O(N) (in Big O notation)
'(or so i think :))
For i = j + 1 To totalcount
  If (myitems(i).Class = olContact) Then
    Set newcontact = myitems(i)
    'if((newcontact.lastmodificationtime = oldcontact.lastmodificationtime) and
    If ((newcontact.LastNameAndFirstName = oldcontact.LastNameAndFirstName) And _
        (newcontact.FileAs = oldcontact.FileAs) And _
        (newcontact.PagerNumber = oldcontact.PagerNumber) And _
        (newcontact.HomeTelephoneNumber = oldcontact.HomeTelephoneNumber) And _
        (newcontact.BusinessTelephoneNumber = oldcontact.BusinessTelephoneNumber) And _
        (newcontact.BusinessAddress = oldcontact.BusinessAddress) And _
        (newcontact.Email1Address = oldcontact.Email1Address) And _
        (newcontact.HomeAddress = oldcontact.HomeAddress) And _
        (newcontact.CompanyName = oldcontact.CompanyName)) Then
      'use FTPSite as a flag to mark duplicates
      newcontact.FTPSite = "DELETE.ME.I.AM.A.DUPE"
      newcontact.Save
      lCount = lCount + 1
    End If
    Set oldcontact = newcontact
  End If
Next i
MsgBox lCount & " Duplicate contacts found."
End Sub

Public Sub MarkBlankNumberContacts()
Dim oldcontact As ContactItem, newcontact As ContactItem, j As Integer
Dim lCount As Long
Set mynamespace = GetNamespace("MAPI")
Set myfolder = mynamespace.GetDefaultFolder(olFolderContacts)
Set myitems = myfolder.Items
'Sort Contacts
myitems.Sort "[File As]", olDescending
totalcount = myitems.Count
j = 1
l = 0
'Find first valid contact
While ((j < totalcount) And (myitems(j).Class <> olContact))
  j = j + 1
Wend
'Process each contact from there on
'Check if ALL the possible phone number fields are blank...
'IF and only IF all are blank then can we mark the contact
For i = j + 1 To totalcount
  If (myitems(i).Class = olContact) Then
    Set newcontact = myitems(i)
    If ((newcontact.AssistantTelephoneNumber = vbNullString) And _
        (newcontact.BusinessFaxNumber = vbNullString) And _
        (newcontact.BusinessTelephoneNumber = vbNullString) And _
        (newcontact.Business2TelephoneNumber = vbNullString) And _
        (newcontact.CarTelephoneNumber = vbNullString) And _
        (newcontact.CompanyMainTelephoneNumber = vbNullString) And _
        (newcontact.HomeFaxNumber = vbNullString) And _
        (newcontact.HomeTelephoneNumber = vbNullString) And _
        (newcontact.Home2TelephoneNumber = vbNullString) And _
        (newcontact.MobileTelephoneNumber = vbNullString) And _
        (newcontact.OtherFaxNumber = vbNullString) And _
        (newcontact.OtherTelephoneNumber = vbNullString) And _
        (newcontact.PrimaryTelephoneNumber = vbNullString) And _
        (newcontact.RadioTelephoneNumber = vbNullString) And _
        (newcontact.PagerNumber = vbNullString)) Then
      'use FTPSite as a flag to mark Deletion
      newcontact.FTPSite = "DELETE.ME.NO.NUMBERS"
      newcontact.Save
      lCount = lCount + 1
    End If
  End If
Next i
MsgBox lCount & " Contacts with no numbers found."
End Sub

Sub DisplayViewDef()
'Displays the XML definition of a View object

    Dim olApp As Outlook.Application
    Dim objName As Outlook.NameSpace
    Dim objViews As Outlook.Views
    Dim objView As Outlook.View

    Set olApp = New Outlook.Application
    Set objName = olApp.GetNamespace("MAPI")
    Set objViews = objName.GetDefaultFolder(olFolderInbox).Views
     
    'Return a view called Table View if it already exists, else create one
    Set objView = objViews.Item("Table View")
    If objView Is Nothing Then
          Set objView = objViews.Add("Table View", olTableView, olViewSaveOptionAllFoldersOfType)
    End If
    MsgBox olApp.ActiveExplorer.CurrentView.XML
    MsgBox objView.XML
End Sub