Solved: Issue with an auto contact adder

[DuncanW]

Hi there, new to this forum, and to VBA so please keep that in mind!
I am using outlook 2000.

Now I have a few questions:
The code pasted below is working for the most part, it adds the contact with the info I need to be added. If the email address is found, it prompts me and asks if I want to add again. My problems are the following:

#1) If I were to click yes, it adds the contact again, but for some reason the second time it gets added, the email address ends up being the first and last name (contained in the body of the email selected) I cant figure out why this is happening! This is my main concern at this point!

#2) If anyone has the time to help me out beyond that, based on the code below, I would ideally like it to trigger on every new email received, when I can get it to do that, I will change the yes/no prompt to a warning that this email exists and it just wont add it. What I have now triggers on a new email, but it only runs on whatever item is highlighted, is there a way to base it on new emails? or would this require new code altogether?

ANY help with this would be greatly appreciated!

Thank you.

Private Sub Application_NewMail()

Call AddAddressesToContacts
MsgBox "test"

End Sub

Public Sub AddAddressesToContacts()
Dim folContacts As Outlook.MAPIFolder
Dim colItems As Outlook.Items
Dim oContact As Outlook.ContactItem
Dim oMail As Outlook.MailItem
Dim obj As Object
Dim oNS As Outlook.NameSpace

Dim response As VbMsgBoxResult

Dim bContinue As Boolean

Dim sSenderName As String
Dim emailz As String

On Error Resume Next

Set oNS = Application.GetNamespace("MAPI")
Set folContacts = oNS.GetDefaultFolder(olFolderContacts)
Set colItems = folContacts.Items

For Each obj In Application.ActiveExplorer.Selection
If obj.Class = olMail Then
Set oContact = Nothing

bContinue = True
sSenderName = ""

Set oMail = obj

sSenderName = oMail.Body
emailz = oMail.Subject
If sSenderName = ";" Then
sSenderName = oMail.Body
emailz = oMail.Subject
End If

Set oContact = colItems.Find("[E-mail] = '" & emailz & "'")

If Not (oContact Is Nothing) Then
response = MsgBox(oMail.Subject & " Already exists in contacts! Add anyways?", vbQuestion + vbYesNo, "Contact Adder")
If response = vbNo Then
bContinue = False
End If
End If

If bContinue = True Then
Set oContact = colItems.Add(olContactItem)
With oContact
.Body = "Club PFM Member!"

.Email1Address = emailz

.FullName = sSenderName

.Save
End With
End If
End If
emailz = ""
Next


Set folContacts = Nothing
Set colItems = Nothing
Set oContact = Nothing
Set oMail = Nothing
Set obj = Nothing
Set oNS = Nothing
End Sub

[DuncanW]

Ok so I took it a little further...This seems to work well to do what I need, although I still have that issue where sometimes the email address is replaced by the first and last name. I think this happens when the contact is added, when the emails are the same, would I be right to assume this? and whats a good work around.

outlook 2000, code is below.

I would also like to trigger this on all new emails, I used the newmailex function to call AddAddressesToContacts, but this doesnt work and I have no idea why!


Public Sub AddAddressesToContacts()
Dim folContacts As Outlook.MAPIFolder
Dim folContacts2 As Outlook.MAPIFolder
Dim folContacts3 As Outlook.MAPIFolder
Dim colItems As Outlook.Items
Dim colItems2 As Outlook.Items
Dim colItems3 As Outlook.Items
Dim oContact As Outlook.ContactItem
Dim oContact2 As Outlook.ContactItem
Dim oContact3 As Outlook.ContactItem
Dim oMail As Outlook.MailItem
Dim obj As Object
Dim oNS As Outlook.NameSpace

Dim response As VbMsgBoxResult

Dim bContinue As Boolean

Dim sSenderName As String
Dim emailz As String

On Error Resume Next

Set oNS = Application.GetNamespace("MAPI")
Set folContacts = oNS.GetDefaultFolder(olFolderContacts)
Set folContacts2 = oNS.GetDefaultFolder(olFolderContacts).Folders("Awaiting Invitation")
Set folContacts3 = oNS.GetDefaultFolder(olFolderContacts).Folders("Added To Mail List")
Set colItems = folContacts.Items
Set colItems2 = folContacts2.Items
Set colItems3 = folContacts3.Items


For Each obj In Application.ActiveExplorer.Selection
If obj.Class = olMail Then
Set oContact = Nothing
Set oContact2 = Nothing
Set oContact3 = Nothing

bContinue = True
sSenderName = ";"

Set oMail = obj

sSenderName = oMail.Body
emailz = oMail.Subject
If sSenderName = ";" Then
sSenderName = oMail.Body
emailz = oMail.Subject
End If

Set oContact = colItems.Find("[E-mail] = '" & emailz & "'")
Set oContact2 = colItems2.Find("[E-mail] = '" & emailz & "'")
Set oContact3 = colItems3.Find("[E-mail] = '" & emailz & "'")

'start checks
'default folder
If Not (oContact Is Nothing) Then

response = MsgBox(emailz & " Already exists in contacts! Add anyways?", vbQuestion + vbYesNo, "Contact Adder")
If response = vbNo Then
bContinue = False
End If
End If
'awaiting invitation
If Not (oContact2 Is Nothing) Then

response = MsgBox(emailz & " Already exists in contacts! Add anyways?", vbQuestion + vbYesNo, "Contact Adder")
If response = vbNo Then
bContinue = False
End If
End If
'added to mail list
If Not (oContact3 Is Nothing) Then

response = MsgBox(emailz & " Already exists in contacts! Add anyways?", vbQuestion + vbYesNo, "Contact Adder")
If response = vbNo Then
bContinue = False
End If
End If

'end checks
If bContinue = True Then
Set oContact = colItems.Add(olContactItem)
With oContact
.Body = "Club PFM Member!"
.Email1Address = emailz
.BusinessAddress = emailz
.FullName = sSenderName
.Save
End With
'testing start
'testing end
End If
End If
emailz = ""
Next


Set folContacts = Nothing
Set folContacts2 = Nothing
Set folContacts3 = Nothing
Set colItems = Nothing
Set colItems2 = Nothing
Set colItems3 = Nothing
Set oContact = Nothing
Set oContact2 = Nothing
Set oContact3 = Nothing
Set oMail = Nothing
Set obj = Nothing
Set oNS = Nothing
End Sub


Any help, comments, or points in the right direction would be greatly appreciated!

Thank you for your time!

[DuncanW]

Ok sorry for the multiple posts, I have played around with some things and I got a little further, and it seems to me this is working now, my last issue, and I am really stumped on this one, is that when more than one email is received, this code only catches one email, not all of them, what should I be doing to have this apply to EVERY new email?

again outlook 2000



Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
' default local Inbox
Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)

On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
Dim Thanks As String
Thanks = "Thank you for joining Club PFM!"
If TypeName(item) = "MailItem" Then
Set Msg = item
'Call AddAddressesToContacts
MsgBox ("New Join!")
MsgBox Msg.Subject
MsgBox Msg.Body
'test field
Dim oout As Object
Dim omsg As Object

Set oout = CreateObject("Outlook.Application")
Set omsg = oout.CreateItem(0)

With omsg
.To = Msg.Subject
.CC = ""
.BCC = ""
.Subject = Thanks
.Body = (Msg.Body & "Thank you for joining Club PFM! You will be receiving your first newsletter with your special Club PFM offer within the next 7 days!")
.Display
End With

' testing
If omsg.Sent Then
MsgBox (" Sent ")
Else
MsgBox (" Not Send ! ")
End If

Set oout = Nothing
Set omsg = Nothing

'end test field
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub

Public Sub AddAddressesToContacts()
Dim folContacts As Outlook.MAPIFolder
Dim folContacts2 As Outlook.MAPIFolder
Dim folContacts3 As Outlook.MAPIFolder
Dim colItems As Outlook.Items
Dim colItems2 As Outlook.Items
Dim colItems3 As Outlook.Items
Dim oContact As Outlook.ContactItem
Dim oContact2 As Outlook.ContactItem
Dim oContact3 As Outlook.ContactItem
Dim oMail As Outlook.MailItem
Dim obj As Object
Dim oNS As Outlook.NameSpace

Dim response As VbMsgBoxResult

Dim bContinue As Boolean

Dim sSenderName As String
Dim emailz As String

On Error Resume Next

Set oNS = Application.GetNamespace("MAPI")
Set folContacts = oNS.GetDefaultFolder(olFolderContacts)
Set folContacts2 = oNS.GetDefaultFolder(olFolderContacts).Folders("Awaiting Invitation")
Set folContacts3 = oNS.GetDefaultFolder(olFolderContacts).Folders("Added To Mail List")
Set colItems = folContacts.Items
Set colItems2 = folContacts2.Items
Set colItems3 = folContacts3.Items


For Each obj In Application.ActiveExplorer.Selection
If obj.Class = olMail Then
Set oContact = Nothing
Set oContact2 = Nothing
Set oContact3 = Nothing

bContinue = True
sSenderName = ";"

Set oMail = obj

sSenderName = oMail.Body
emailz = oMail.Subject
If sSenderName = ";" Then
sSenderName = oMail.Body
emailz = oMail.Subject
End If

Set oContact = colItems.Find("[E-mail] = '" & emailz & "'")
Set oContact2 = colItems2.Find("[E-mail] = '" & emailz & "'")
Set oContact3 = colItems3.Find("[E-mail] = '" & emailz & "'")

'start checks
'default folder
If Not (oContact Is Nothing) Then

response = MsgBox(emailz & " Already exists in contacts! Add anyways?", vbQuestion + vbYesNo, "Contact Adder")
If response = vbNo Then
bContinue = False
End If
End If
'awaiting invitation
If Not (oContact2 Is Nothing) Then

response = MsgBox(emailz & " Already exists in contacts! Add anyways?", vbQuestion + vbYesNo, "Contact Adder")
If response = vbNo Then
bContinue = False
End If
End If
'added to mail list
If Not (oContact3 Is Nothing) Then

response = MsgBox(emailz & " Already exists in contacts! Add anyways?", vbQuestion + vbYesNo, "Contact Adder")
If response = vbNo Then
bContinue = False
End If
End If

'end checks
If bContinue = True Then
Set oContact = colItems.Add(olContactItem)
With oContact
.Body = "Club PFM Member!"
.Email1Address = emailz
.BusinessAddress = emailz
.FullName = sSenderName
.Save
End With
'testing start
'testing end
End If
End If
emailz = ""
Next


Set folContacts = Nothing
Set folContacts2 = Nothing
Set folContacts3 = Nothing
Set colItems = Nothing
Set colItems2 = Nothing
Set colItems3 = Nothing
Set oContact = Nothing
Set oContact2 = Nothing
Set oContact3 = Nothing
Set oMail = Nothing
Set obj = Nothing
Set oNS = Nothing
End Sub

[DuncanW]

Ok so I figured it out! I got it to: upon receiving a new mail, go through every unread message, add the contact information if it didnt already exist, auto reply with a message, and mark as read! The code is pretty sloppy right now but it works! If anyone is interested in seeing what I did to accomplish this, post, and I will leave whatever code I have for you to modify for your own needs!