extracting email id ,name from outlook REMOVING DUPLICATE CONTACT ENTRIES

[indiewolf]

how do i extract email id , name from outlook email and transfer it to contacts in outlook.

how do i use the vb editor in outlook to perform this task.

i would like to create a button , which upon pressing exports the email id, name (from an email) to contacts.

kindly help

[indiewolf]

ok i have tried using robdog888 solution to one of the problems here.


this is the code but kindly lemmo know what i do to add email id and name of the sender as i press the "save to contacts" from "tool"


there are changes to be made in the oSaveAs_Click event.

Option Explicit
'Behind ThisOutlookSession
Private oCBTools As Office.CommandBarPopup
Private oCBSaveMe As Office.CommandBarButton
 
Public WithEvents oSaveAs As Office.CommandBarButton
 
Private Sub SyncButton(btn As Office.CommandBarButton)
    Set oSaveAs = btn
    If btn Is Nothing Then
        MsgBox "Sync. of '" & btn.Caption & "' button event failed!", vbCritical + vbOKOnly
    End If
End Sub
 
Private Sub Application_MAPILogonComplete()
    Set oCBTools = Application.ActiveExplorer.CommandBars("Menu Bar").Controls("&Tools")
    Set oCBSaveMe = Application.ActiveExplorer.CommandBars("Menu Bar").FindControl(msoControlButton, 1, "888", True, True)
    If TypeName(oCBSaveMe) = "Nothing" Then
        Set oCBSaveMe = oCBTools.Controls.Add(msoControlButton, 1, "888", , True)
    End If
    With oCBSaveMe
        .BeginGroup = True
        .Caption = "Send to Contacts..."
        .Enabled = True
        .Style = msoControlCustom
        .Tag = "888"
        .Visible = True
    End With
    Call SyncButton(oCBSaveMe)
End Sub
 
Private Sub oSaveAs_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
    
    Dim oSel As Outlook.Selection
    Dim oEmail As Outlook.MailItem
    Dim sSub As String
    
    Set oSel = Application.ActiveExplorer.Selection
    If oSel.Class = olMail Then
        Set oEmail = oSel
        'Use the email subject as the filename
        sSub = oEmail.SenderEmailAddress
        
       
       sSud = oEmail.SenderName
        Outlook.olContact
        
        Set oEmail = Nothing
        MsgBox "Saved"
    End If
    Set oSel = Nothing
    
End Sub

kindly help
its urgent
cheers

[RobDog888]

If oSel.Class = olMail Then
    Set oEmail = oSel
    'Use the email subject as the filename
    sAddy = oEmail.SenderEmailAddress
    sID = oEmail.EntryID
    sFullName = oEmail.FullName
    sSenderName = oEmail.SenderName
    Set oEmail = Nothing
    MsgBox "Saved"
End If

[indiewolf]

hi rob
first of all many many thanks
no i was wrong the code is not working at all

it is not importing the email address or name of any received email to contacts once i click the tools>send to contact
kindly help
cheers

my code now is

Private Sub oSaveAs_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
    
    Dim oSel As Outlook.Selection
    Dim oEmail As Outlook.MailItem
    Dim sSub As String
    Dim sAddy As String
    Dim sID As String
    Dim sFullName As String
    Dim sSenderName As String
    
    Set oSel = Application.ActiveExplorer.Selection
    
    If oSel.Class = olMail Then
    Set oEmail = oSel
    'Use the email subject as the filename
    sAddy = oEmail.SenderEmailAddress
    sID = oEmail.EntryID
    sFullName = oEmail.FullName
    sSenderName = oEmail.SenderName
    Set oEmail = Nothing
    MsgBox "Saved"
End If
    
    Set oSel = Nothing
    
End Sub

[RobDog888]

Did you make another selection and then reclick on the menu item?

[indiewolf]

yes i did
it is not happening

it is not adding anything to "outlook contacts"


kindly help

[indiewolf]

Did you make another selection and then reclick on the menu item?

may i ask where is the code for adding it to outlook contacts?

[RobDog888]

There is none as I thought you had it somewhere else since you were saving the props to variables.

[indiewolf]

no i dont have it

kindly show me how to go about that

becoz the main function is to import it to the contact which is what i am unable to do

[RobDog888]

Private Sub oSaveAs_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
 
    Dim oSel As Outlook.Selection
    Dim oEmail As Outlook.MailItem
    Dim oContact As Outlook.ContactItem
 
    Set oSel = Application.ActiveExplorer.Selection
    If oSel.Class = olMail Then
        Set oEmail = oSel
        Set oContact = Application.CreateItem(olContactItem)
        With oContact
            .Subject = oEmail.Subject
            .Email1Address = oEmail.SenderEmailAddress
            .FullName = oEmail.SenderName
            .Body = oEmail.Body
            .Save
            .Display
        End With
        MsgBox "Saved"
        Set oEmail = Nothing
        Set oContact = Nothing
    End If
    Set oSel = Nothing
 
End Sub

[indiewolf]

no it is not working !!


it is still not exporting anything to the contacts.

kindly help
cheers mate

[RobDog888]

Place a breakpoint on the click event. Then step through the code and see where the error is. Does it give an error message?

[indiewolf]

Place a breakpoint on the click event. Then step through the code and see where the error is. Does it give an error message?

i did place abreakpoint at the start of private... by pressing f9
but how do i know where is the error message?
i did not understand . kindly explain again.
cheers

this is how the whole code is
could you please have a look

Option Explicit
'Behind ThisOutlookSession
Private oCBTools As Office.CommandBarPopup
Private oCBSaveMe As Office.CommandBarButton
 
Public WithEvents oSaveAs As Office.CommandBarButton
 
Private Sub SyncButton(btn As Office.CommandBarButton)
    Set oSaveAs = btn
    If btn Is Nothing Then
        MsgBox "Sync. of '" & btn.Caption & "' button event failed!", vbCritical + vbOKOnly
    End If
End Sub
 
Private Sub Application_MAPILogonComplete()
    Set oCBTools = Application.ActiveExplorer.CommandBars("Menu Bar").Controls("&Tools")
    Set oCBSaveMe = Application.ActiveExplorer.CommandBars("Menu Bar").FindControl(msoControlButton, 1, "888", True, True)
    If TypeName(oCBSaveMe) = "Nothing" Then
        Set oCBSaveMe = oCBTools.Controls.Add(msoControlButton, 1, "888", , True)
    End If
    With oCBSaveMe
        .BeginGroup = True
        .Caption = "Send to Contacts..."
        .Enabled = True
        .Style = msoControlCustom
        .Tag = "888"
        .Visible = True
    End With
    Call SyncButton(oCBSaveMe)
End Sub
 
 
 
 
Private Sub oSaveAs_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
    
     Dim oSel As Outlook.Selection
    Dim oEmail As Outlook.MailItem
    Dim oContact As Outlook.ContactItem
 
    Set oSel = Application.ActiveExplorer.Selection
    If oSel.Class = olMail Then
        Set oEmail = oSel
        Set oContact = Application.CreateItem(olContactItem)
        With oContact
            .Subject = oEmail.Subject
            .Email1Address = oEmail.SenderEmailAddress
            .FullName = oEmail.SenderName
            .Body = oEmail.Body
            .Save
            .Display
        End With
        MsgBox "Saved"
        Set oEmail = Nothing
        Set oContact = Nothing
    End If
    Set oSel = Nothing
 
End Sub

[RobDog888]

If the code is running then if you had placed a breakpoint on the click event your code will stop there when you click on the menu item. It will be a yellow highlighted line. By pressing F8 you will step through the code. When it errors or ? it will tell you the issue.

[indiewolf]

If the code is running then if you had placed a breakpoint on the click event your code will stop there when you click on the menu item. It will be a yellow highlighted line. By pressing F8 you will step through the code. When it errors or ? it will tell you the issue.

thanks much for the above.
error @ the code below.
the yellow line follows these lines of code when f8 is pressed.

Set oSel = Application.ActiveExplorer.Selection
    If oSel.Class = olMail Then
 Set oSel = Nothing
 
End Sub

cheers

[indiewolf]

kindly help
still waiting

[indiewolf]

kindly help

[RobDog888]

And what is the error?

[indiewolf]

And what is the error?

it doesnt specify the error. only a highlighted yellow line .

cheers

[RobDog888]

It it on the same line as your breakpoint? If it is then press F8 to increment and ste to the next line of code to be processed. this is the debugging part.

[indiewolf]

well i keep on pressing f8 after the yellow line and it moves on the code i specified above..the error one.it highlights the above error code with yellow and that is all it does.

yes it is on the same line as the breakpoint. oh its so confusing.

here is the entire code:
can u copy-paste it in thisoutlooksession as see what is wrong.
cheers

Option Explicit
'Behind ThisOutlookSession
Private oCBTools As Office.CommandBarPopup
Private oCBSaveMe As Office.CommandBarButton
 
Public WithEvents oSaveAs As Office.CommandBarButton
 
Private Sub SyncButton(btn As Office.CommandBarButton)
    Set oSaveAs = btn
    If btn Is Nothing Then
        MsgBox "Sync. of '" & btn.Caption & "' button event failed!", vbCritical + vbOKOnly
    End If
End Sub
 
Private Sub Application_MAPILogonComplete()
    Set oCBTools = Application.ActiveExplorer.CommandBars("Menu Bar").Controls("&Tools")
    Set oCBSaveMe = Application.ActiveExplorer.CommandBars("Menu Bar").FindControl(msoControlButton, 1, "888", True, True)
    If TypeName(oCBSaveMe) = "Nothing" Then
        Set oCBSaveMe = oCBTools.Controls.Add(msoControlButton, 1, "888", , True)
    End If
    With oCBSaveMe
        .BeginGroup = True
        .Caption = "Send to Contacts..."
        .Enabled = True
        .Style = msoControlCustom
        .Tag = "888"
        .Visible = True
    End With
    Call SyncButton(oCBSaveMe)
End Sub
 
 
 
 
Private Sub oSaveAs_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
    
     Dim oSel As Outlook.Selection
    Dim oEmail As Outlook.MailItem
    Dim oContact As Outlook.ContactItem
 
    Set oSel = Application.ActiveExplorer.Selection
    If oSel.Class = olMail Then
        Set oEmail = oSel
        Set oContact = Application.CreateItem(olContactItem)
        With oContact
            .Subject = oEmail.Subject
            .Email1Address = oEmail.SenderEmailAddress
            .FullName = oEmail.SenderName
            .Body = oEmail.Body
            .Save
            .Display
        End With
        MsgBox "Saved"
        Set oEmail = Nothing
        Set oContact = Nothing
    End If
    Set oSel = Nothing
 
End Sub

[RobDog888]

I do not get an error but you are saying you get an error as you step thriugh the code so then what is the nessage disaply?

This is behind your thisoutlooksession class? You are only selecting one email item?

[indiewolf]

i put the breakpoint. close the visualbasic editor. close outlook. again open outlook . select an email message. use the save to contacts... button and it takes me to the highlighted yellow section wherein i put the breakpoint.

if i dont put a breakpoint and just open outlook , select an email or multiple emails and click save to contacts... from tools> save to contacts.. , i am not able to add any contact email id or name to my contacts.

i have this code in
Project1(VbaProject.OTM)>microsoft office outlook>ThisOutlookSession (as nodes in visual basic editor)

is that the problem? class?

kindly help
cheers

[indiewolf]

kindly help
cheers

[RobDog888]

The code is only handling a single email selection so if you select multiple it will cause an error. We can handle multiple selections later.

The class shouldnt be an issue.

When you breakpoint with the code do you press F8 and step through it?

[indiewolf]

i did everything. i have pasted the code above. and i have pasted the same thing in thisoutlooksession.
macros are enabled .
as soon as i start outlook, i select an email, click send to contacs, nothing happens.
what could be the problem.

kindly help

[indiewolf]

i place the breakpoint in the code. press f8 (step into) nothing happens. the cursor remain still.

it is only after i close outlook and start it again , select email, press send to contacts that it takes me to thisoutlooksession code page...highlights the breakpoint...and then when i click f8 it takes me to the lines(error code) which i had mentioned above.(see posts above)

these lines are also highlted as yellow..and after pressing f8 until end class the colour disappears the code returns to normalcy. but still does not run.

what is the next step that i can do? should i paste the code in another module..run ..what ?
kindly help to get me rid of this problem. its been a week now

DO I HAVE TO ADD ANY REFERENCES?
cheers

[indiewolf]

Private Sub oSaveAs_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
    
     Dim oSel As Outlook.Selection
    Dim oEmail As Outlook.MailItem
    Dim oContact As Outlook.ContactItem
Dim Item As Outlook.MailItem
    Set oSel = Application.ActiveExplorer.Selection
   For Each Item In oSel
   If Item.Class = olMail Then
    Set oEmail = Item
   
        Set oContact = Application.CreateItem(olContactItem)
       With oContact
            .Subject = oEmail.Subject
            .Email1Address = oEmail.SenderEmailAddress
            .FullName = oEmail.SenderName
            .Body = oEmail.Body
            .Save
            .Display
        End With
        MsgBox "Saved"
        Set oEmail = Nothing
        Set oContact = Nothing
    
    Set oSel = Nothing
 End If
Next
End Sub

finally i cud solve it. BUT BUT But

THE ENTRIES IN THE contact list are duplicating! what should i do to avoid that.
kindly help
cheers

[RobDog888]

You will need to search your contacts programmatically to see if a contact already exists. Then either prompt the user that it exists and if they want to overwrite or duplicate or cancel.

[indiewolf]

sorry! how do i go about it?
could you show me something.

cheers
well ihave this code but it has errors as well as it just puts a flag instead of really deleting.
can u please help
cheers

Public Sub deleteduplicatecontacts()
Dim oldcontact As ContactItem, newcontact As ContactItem, j As Integer
Set mynamespace = GetNamespace("MAPI")
Set myfolder = mynamespace.GetDefaultFolder(olFolderConta  cts)
Set myitems = myfolder.Items
myitems.Sort "[File As]", olDescending
totalcount = myitems.Count
j = 1
While ((j < totalcount) And (myitems(j).Class <> olContact))
  j = j + 1
Wend
Set oldcontact = myitems(j)
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 = "DELETEMESEYMOUR"
      newcontact.Save
    End If
    Set oldcontact = newcontact
 
  End If
Next i
End Sub

[indiewolf]

Public Sub deleteduplicatecontacts()
Dim oldcontact As ContactItem, newcontact As ContactItem, j As Integer
Dim mynamespace As NameSpace
Dim myitems As Items
Dim myfolder As Folders
Dim i As Integer
Dim totalcount As Integer
 
Set mynamespace = GetNamespace("MAPI")
 
Set myfolder = mynamespace.GetDefaultFolder(olFolderContacts)
Set myitems = myfolder.Items
myitems.Sort "[File As]", olDescending
totalcount = myitems.Count
j = 1
While ((j < totalcount) And (myitems(j).Class <> olContact))
  j = j + 1
Wend
Set oldcontact = myitems(j)
'For i = j + 1 To totalcount
For i = totalcount To (j + 1) Step -1
 
  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.Delete  
      newcontact.Save
    End If
    Set oldcontact = newcontact
 
  End If
Next i
End Sub

kindly help
type mismatch error

kindly help

[indiewolf]

kindly help, code above.
cheers

[RobDog888]

Why are you doing this?

While ((j < totalcount) And (myitems(j).Class <> olContact))

Your counting all items that are NOT contacts? Shouldnt you be just getting the first and Last name from the selected email and execute a .Find or .Restrict on the respective contact itmes fields?

[indiewolf]

can you please rectify the code.
i tried but am not able to do it.

kindly help
cheers

[indiewolf]

kindly help
cheers

[indiewolf]

Public Sub deleteduplicatecontacts()
Dim oldcontact As ContactItem, newcontact As ContactItem, j As Integer
Dim mynamespace As Outlook.NameSpace
Dim myitems As Items
Dim myfolder As Outlook.MAPIFolder
Dim i As Integer
Dim totalcount As Integer
 
Set mynamespace = GetNamespace("MAPI")
 
Set myfolder = mynamespace.GetDefaultFolder(olFolderContacts)
Set myitems = myfolder.Items
myitems.Sort "[File As]", olDescending
totalcount = myitems.Count
j = 1
While ((j < totalcount) And (myitems(j).Class <> olContact))
  j = j + 1
Wend
Set oldcontact = myitems(j)
'For i = j + 1 To totalcount
For i = totalcount To (j + 1) Step -1
 
  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.Delete  '= "DELETEMESEYMOUR" 'FTPSite
      newcontact.Save
    End If
    Set oldcontact = newcontact
 
  End If
Next i
End Sub

above is the latest code. but now i have error : array index out of bounds
kindly help
cheers