mr_malkovich
Senior Member
- Outlook version
- Email Account
- Exchange Server
Hi all, I have an excel file full of emails to be checked. Those emails are the ones to be flag marked as complete in outlook contact file. What I want to do is a macro that can scan through the excel file and compare to a contact folder in Outlook so that when the email matches a contact file's email, it will change the flag status. For now, I have this code but it won't work. Please advice me on this. Thank you.
Sub UpdateContacts()
Dim olApp As Object
Dim olNs As Object
Dim cFolder As Object
Dim groupFolder As Object
Dim strGroup As String
Dim myContacts As Object
Dim myItem As Object
Dim strAddress As String
Dim strFix As String
Dim blnCreated As Boolean
Dim i As Integer
Dim FoldersArray As Variant
Sheets("dj confirmed").Select
On Error Resume Next
Set olApp = CreateObject("Outlook.Application")
Set olNs = olApp.GetNamespace("MAPI")
FolderPath = "anas@dunndealpr.com\Contacts\test flag"
FoldersArray = Split(FolderPath, "\")
Set cFolder = olApp.Session.Folders.Item(FoldersArray(0))
If Not cFolder Is Nothing Then
For i = 1 To UBound(FoldersArray, 1)
Dim SubFolders As Object
Set SubFolders = cFolder.Folders
Set cFolder = SubFolders.Item(FoldersArray(i))
If cFolder Is Nothing Then
MsgBox "Folder Not Found"
End If
Next
End If
Debug.Print cFolder
i = 1
Set myContacts = cFolder.items
Do Until Trim(Cells(i, 1).Value) = ""
strAddress = Cells(i, 1)
Set myItem = myContacts.Find("[Email1Address]='" & strAddress & "'")
If TypeName(myItem) = "ContactItem" Then
If Not TypeName(myItem) = "Nothing" Then
myItem.FlagStatus = olFlagComplete
myItem.Save
End If
End If
i = i + 1
Loop
Set olApp = Nothing
End Sub
Sub UpdateContacts()
Dim olApp As Object
Dim olNs As Object
Dim cFolder As Object
Dim groupFolder As Object
Dim strGroup As String
Dim myContacts As Object
Dim myItem As Object
Dim strAddress As String
Dim strFix As String
Dim blnCreated As Boolean
Dim i As Integer
Dim FoldersArray As Variant
Sheets("dj confirmed").Select
On Error Resume Next
Set olApp = CreateObject("Outlook.Application")
Set olNs = olApp.GetNamespace("MAPI")
FolderPath = "anas@dunndealpr.com\Contacts\test flag"
FoldersArray = Split(FolderPath, "\")
Set cFolder = olApp.Session.Folders.Item(FoldersArray(0))
If Not cFolder Is Nothing Then
For i = 1 To UBound(FoldersArray, 1)
Dim SubFolders As Object
Set SubFolders = cFolder.Folders
Set cFolder = SubFolders.Item(FoldersArray(i))
If cFolder Is Nothing Then
MsgBox "Folder Not Found"
End If
Next
End If
Debug.Print cFolder
i = 1
Set myContacts = cFolder.items
Do Until Trim(Cells(i, 1).Value) = ""
strAddress = Cells(i, 1)
Set myItem = myContacts.Find("[Email1Address]='" & strAddress & "'")
If TypeName(myItem) = "ContactItem" Then
If Not TypeName(myItem) = "Nothing" Then
myItem.FlagStatus = olFlagComplete
myItem.Save
End If
End If
i = i + 1
Loop
Set olApp = Nothing
End Sub