Outlook 2010 VBA - Add user

[ricje20]

Hey, lang niet meer geweest hier ;p ik heb een beetje hulp nodig bij Microsoft outlook 2010 VBA

Ik heb het in het engels geschreven omdat ik het op nog een ander forum geplaatst heb, als ik het nog even moet vertalen kan je het gerust vragen

got a little problem, I hope someone can help me.

(Outlook 2010 VBA)

this is my current code, what i need is when i click on a mail (only the mail i clicked on, not every mail in the folder/same place) it has to check if the Sender of the mail is already in my contacts or in the Addressbook 'All Users', and if it's not a one of those yet, open the AddContact window and fill in his/her information

what doesn't work yet is:

• most important of all, it doesn't run the script when i click on a mail
  
• the current check if the contact already exsist doesn't work and goes with a vbMsgBox (yes or no and response stuff) wich is not what i want/need if the contact already exsist then nothing has to happen.
  

I hope i gave enough information and someone can help me out here

Sub AddAddressesToContacts(objMail As Outlook.MailItem)
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
''don't want or need a vbBox/ask box, this a part of the current contactcheck
''wich doesn't work and is totaly wrong 
Dim response As VbMsgBoxResult
Dim bContinue As Boolean
Dim sSenderName As String
On Error Resume Next
Set oNS = Application.GetNamespace("MAPI")
Set folContacts = oNS.GetDefaultFolder(olFolderContacts)
Set colItems = folContacts.Items
''this selects the mail that is currently selected.
''what i want is that the sender of the new incoming mail gets added to contacts
''(ofcourse, if that contact doesn't exsist yet)
''so the new incoming mail gotta be selected.
For Each obj In Application.ActiveExplorer.Selection
If obj.Class = olMail Then
Set oContact = Nothing
bContinue = True
sSenderName = ""
Set oMail = obj
sSenderName = oMail.SentOnBehalfOfName
If sSenderName = ";" Then
sSenderName = oMail.SenderName
End If
Set oContact = colItems.Find("[FullName] = '" & sSenderName & "'")
''this part till the --- is wrong, i need someting to check if the contact
''already exsists. Any ideas?
If Not (oContact Is Nothing) Then
   response = vbAbort
If response = vbAbort Then
   bContinue = False
End If
End If
''---------
If bContinue Then
Set oContact = colItems.Add(olContactItem)
With oContact
.Email1Address = oMail.SenderEmailAddress
.Email1DisplayName = sSenderName
.Email1AddressType = oMail.SenderEmailType
.FullName = oMail.SenderName
'.Save
oContact.Display

End With
End If
End If
Next
Set folContacts = Nothing
Set colItems = Nothing
Set oContact = Nothing
Set oMail = Nothing
Set obj = Nothing
Set oNS = Nothing
End Sub

- - - Updated - - -

uhm, sorry dat ik op me eigen post reageer, maar kon me vorige bericht niet meer bewerken omdat dat na 3 minuten niet meer kan? o.o

de code box is crappy daar dus hier is ie even opnieuw

Sub AddAddressesToContacts(objMail As Outlook.MailItem)

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

''don't want or need a vbBox/ask box, this a part of the current contactcheck
''wich doesn't work and is totaly wrong 
Dim response As VbMsgBoxResult

Dim bContinue As Boolean
Dim sSenderName As String

On Error Resume Next

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

''this selects the mail that is currently selected.
''what i want is that the sender of the new incoming mail gets added to contacts
''(ofcourse, if that contact doesn't exsist yet)
''so the new incoming mail gotta be selected.
For Each obj In Application.ActiveExplorer.Selection

If obj.Class = olMail Then

Set oContact = Nothing
bContinue = True
sSenderName = ""

Set oMail = obj

sSenderName = oMail.SentOnBehalfOfName
If sSenderName = ";" Then
sSenderName = oMail.SenderName
End If

Set oContact = colItems.Find("[FullName] = '" & sSenderName & "'")

''this part till the --- is wrong, i need someting to check if the contact
''already exsists. Any ideas?
If Not (oContact Is Nothing) Then
   response = vbAbort
If response = vbAbort Then
   bContinue = False
End If
End If
''---------

If bContinue Then
Set oContact = colItems.Add(olContactItem)

With oContact
.Email1Address = oMail.SenderEmailAddress
.Email1DisplayName = sSenderName
.Email1AddressType = oMail.SenderEmailType
.FullName = oMail.SenderName

'.Save

oContact.Display

End With
End If
End If

Next

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

End Sub

26 februari 2013 aangepast door ricje20
code box was te klein en alles werd opgehoopt?

[ricje20]

Hey,

ik heb het al bijna opgelost, de code ziet er wat anders uit, heb het even wat overzichtelijker gemaakt.

Sub AddAddressesToContacts(objMail As Outlook.MailItem)

heb ik vervangen met

Private Sub Application_ItemLoad(ByVal Item As Object)

Hiermee heb ik ervoor gezorgt dat het script wordt uitgevoerd wanneer je op een mailtje in je inbox klikt.

If Not (oContact Is Nothing) Then
   response = vbAbort
If response = vbAbort Then
  bContinue = False
End If
End If

heb ik vervangen met

        If Not oContact Is Nothing Then
              Exit For
        End If

de code hieronderzegt dat wanneer oContact al bestaat, Exit de "for loop", anders gezegd, stop het script.

Set oContact = colItems.Find("[FullName] = '" & sSenderName & "'")

maar nu heb ik nog een probleem.

er staat nu, If Not oContact is Nothing Then.........

oContact staat omschreven als de Naam van de sender van de mail,

dus er word eigenlijk gecheckt of de naam van de zender van de mail al staat in de contactpersonen.

hier wil ik eigenlijk dat hij zoekt op de e-mail.

ik zat al een beetje te zoeken en dacht ongeveer iets van

set oSendermail = ?het e-mailaddress?

        If Not oSendermail Is Nothing Then
           Exit For
        End If
   End If

alleen heb ik geen idee hoe ik hier het e-mailaddress kan zoeken

ik heb al geprobeerd om

oMail.SenderEmailAddress

te gebruiken zoals helemaal onderin de code word gedaan om het e-mailaddress te verkrijgen,

maar hier lukte mij het niet mee.

Ik hoop dat ik duidelijk genoeg ben en dat iemand mij kan helpen.

Private Sub Application_ItemLoad(ByVal Item As Object)

''(Outlook 2010)
''when you click on a mail it runs this script to check if the sender of that mail
''is already a contact, and if he's not, open the pannel to add him to contacts 
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 bContinue As Boolean
Dim sSenderName 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


     ''defines the name of the sender
      sSenderName = oMail.SentOnBehalfOfName


      If sSenderName = ";" Then
           sSenderName = oMail.SenderName
      End If


       ''sets the name of the contact
       Set oContact = colItems.Find("[FullName] = '" & sSenderName & "'")


       ''checks if the contact exsist, if it does exit the for loop
        If Not oContact Is Nothing Then
           Exit For
        End If
   End If


   ''fill in the fields of the "AddContact Pannel"
   If bContinue Then
     Set oContact = colItems.Add(olContactItem)
       With oContact


        .Email1Address = oMail.SenderEmailAddress
        .Email1DisplayName = sSenderName
        .Email1AddressType = oMail.SenderEmailType
        .FullName = oMail.SenderName


         '.Save


         ''displays the add contact pannel
         oContact.Display


       End With
   End If
Next


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

[ricje20]

ooooh

het is me gelukt haha, ik zal de oplossing nog even opgeven

 
       'sets the e-mail address of the sender
        eSender = oMail.SenderEmailAddress


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


       'sets the name of the sender
       Set oContact = colItems.Find("[FullName] = '" & sSenderName & "'")


        'checks if the contact exsist, if it does exit the for loop
        If Not eSender Is Nothing Then
           Exit For
        End If
   End If

ik heb net zoals het eerst gedaan was bij oContact, een eSender (e-mail Sender) gemaakt

eSender = oMail.SenderEmailAddress

en gezegt dat hij in het collom E-mail, het address van de eSender moet zoeken als hij kijkt in de contacts om te checken of hij al bestaat.

      
'als de eSender (e-mail address van de sender van de mail) er wel staat (if not is nothing.. yup mind-fu*k) dan 'exit hij de loop, oftewel, contact bestaat al, stop het script.
If Not eSender Is Nothing Then
           Exit For
        End If
   End If

Ik hoop dat iemand hier iets mee kan haha

Private Sub Application_ItemLoad(ByVal Item As Object)

'(Outlook 2010 VBA)

'when you click on a mail it runs this script to check if the sender of that mail
'is already a contact, and if he's not, open the pannel to add him to contacts

Dim folContacts As Outlook.MAPIFolder
Dim colItems As Outlook.Items
Dim oContact As Outlook.ContactItem
Dim contactFolder As Outlook.Folder
Dim oMail As Outlook.MailItem
Dim obj As Object
Dim oNS As Outlook.NameSpace

Dim bContinue As Boolean
Dim sSenderName 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

       'defines the name of the sender
       sSenderName = oMail.SentOnBehalfOfName
        If sSenderName = ";" Then
           sSenderName = oMail.SenderName
        End If

        eSender = oMail.SenderEmailAddress

        'sets the e-mail address of the sender
        Set eSender = colItems.Find("[E-mail] = '" & eSender & "'")

        'sets the name of the oContact, to the name of the sender
        Set oContact = colItems.Find("[FullName] = '" & sSenderName & "'")

       'checks if the e-mailadress exsist in the contacts, if it does exit the for loop
        If Not eSender Is Nothing Then
           Exit For
        End If
   End If

   'fill in the fields of the "AddContact Pannel"
   If bContinue Then
     Set oContact = colItems.Add(olContactItem)
       With oContact

        .Email1Address = oMail.SenderEmailAddress
        .Email1DisplayName = sSenderName
        .Email1AddressType = oMail.SenderEmailType
        .FullName = oMail.SenderName

        '.Save

       'displays the add contact pannel
        oContact.Display
        MsgBox "Deze persoon staat nog niet in uw Contactpersonen of Adressboek"

       End With
   End If
Next
Set folContacts = Nothing
Set colItems = Nothing
Set oContact = Nothing
Set oMail = Nothing
Set obj = Nothing
Set oNS = Nothing
End Sub

[ricje20]

lol hier zijn we weer.....

hij checkt alleen of het persoon al in de Contacts staat, maar hij moet ook checken of de sender al in het adresboek staat. ik zal even wat fototjes toevoegen van het adresboek dat ik bedoel.

in dat " pad " of hoe het ook heet of hoe ik er ook kom (xD)

moet hij ook checken of de zender van de mail die ik selecteer daarin staat, zoals hij nu al doet in de Contactpersonen.

ik hoop dat iemand me kan helpen

[kweezie wabbit]

Ik denk dat je dan moet werken met AddressLists en AddressEntries.

Voor elke AddressEntry van elke AddressList controleren of de .name van de AddressEntry.GetExchangeUser overeenkomt met de sSenderName

[ricje20]

Hey, bedankt voor de reactie

zou je misschien een klein voorbeeldje willen geven? het ziet er een beetje verwarrent uit :3

dankje!

[kweezie wabbit]

Verder bouwend op de laatste code uit bericht nr 3, ben ik tot het volgende gekomen.

Mijn toevoegingen zijn rood en blauw gemarkeerd.

Als je geen exchange server gebruikt, kan het zijn dat je fouten krijgt.

In dat geval moet je de blauw gemarkeerde lijnen in commentaar zetten.

Als je meerdere adreslijsten hebt of veel entries in de adreslijsten, kan het wel even duren voor je reactie krijgt. Ik heb het getest op het werk met 12 adreslijsten en meer dan 30.000 entries (door de firma bepaald) en outlook heeft hierop een paar keer gehangen, vooral bij een afzender die (nog) niet in de lijsten stond.

Succes er mee.

Private Sub Application_ItemLoad(ByVal Item As Object)

'(Outlook 2010 VBA)

'when you click on a mail it runs this script to check if the sender of that mail
'is already a contact, and if he's not, open the pannel to add him to contacts

Dim folContacts As Outlook.MAPIFolder
Dim colItems As Outlook.Items
Dim oContact As Outlook.ContactItem
Dim contactFolder As Outlook.Folder
Dim oMail As Outlook.MailItem
Dim obj As Object
Dim oNS As Outlook.NameSpace

[color=#ff0000] Dim oALijsten As Outlook.AddressLists
Dim oALijst As Outlook.AddressList
Dim oAEntries As Outlook.AddressEntries
Dim oAEntry As Outlook.AddressEntry
[/color][color=#0000ff]Dim Gebruiker As ExchangeUser[/color]



Dim bContinue As Boolean
Dim sSenderName 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

       'defines the name of the sender
       sSenderName = oMail.SentOnBehalfOfName
        If sSenderName = ";" Then
           sSenderName = oMail.SenderName
        End If

        esender = oMail.SenderEmailAddress

        'sets the e-mail address of the sender
        Set esender = colItems.Find("[E-mail] = '" & esender & "'")

        'sets the name of the oContact, to the name of the sender
        Set oContact = colItems.Find("[FullName] = '" & sSenderName & "'")

       'checks if the e-mailadress exsist in the contacts, if it does exit the for loop
        If Not esender Is Nothing Then
'            MsgBox "Gevonden in contacts: " & sSenderName
           Exit For
[color=#ff0000]         Else
           'checks if the name or the e-mailadress exsist in one of the address lists, if it does exit the for loop
           Set oALijsten = oNS.AddressLists
           esender = oMail.SenderEmailAddress
           teller = 1

           'loop through the available address lists
           Do While teller < oALijsten.Count + 1
               Set oALijst = oALijsten.Item(teller)
               Set oAEntries = oALijst.AddressEntries
               counter = 1

               'loop trough the entries of the address list
               Do While counter < oAEntries.Count + 1
                   Set oAEntry = oAEntries.Item(counter)
                   'check the senders name
                   If sSenderName = oAEntry.Name Then
'                        MsgBox "Adresslijst : " & oALijst.Name & vbCrLf & "Gevonden : " & oAEntry.Name
                       Exit For
[/color][color=#0000ff]                    Else
                   'check the senders mail address
                       Set Gebruiker = oAEntry.GetExchangeUser
                       If Gebruiker.PrimarySmtpAddress = esender Then
'                            MsgBox "mail adres gevonden : " & sSenderName & vbCrLf & "Gevonden : " & Gebruiker.PrimarySmtpAddress
                           Exit For
                       End If[/color][color=#ff0000]
                   End If
                   counter = counter + 1
               Loop
               teller = teller + 1
           Loop[/color]
        End If
   End If

   'fill in the fields of the "AddContact Pannel"
   If bContinue Then
     Set oContact = colItems.Add(olContactItem)
       With oContact

        .Email1Address = oMail.SenderEmailAddress
        .Email1DisplayName = sSenderName
        .Email1AddressType = oMail.SenderEmailType
        .FullName = oMail.SenderName

        '.Save

       'displays the add contact pannel
        oContact.Display
        MsgBox "Deze persoon staat nog niet in uw Contactpersonen of Adressboek"

       End With
   End If
Next
Set folContacts = Nothing
Set colItems = Nothing
Set oContact = Nothing
Set oMail = Nothing
Set obj = Nothing
Set oNS = Nothing
End Sub

28 februari 2013 aangepast door kweezie wabbit

[ricje20]

Hey,

super bedankt voor je hulp,

ik kan het helaas maandag pas uit testen.

je hoort nog van me!

[kweezie wabbit]

Ik kijk er naar uit

[ricje20]

Hey,

super bedankt

de code werkt bijna

wat hij nu doet is de personen in de adresboeken op namen checken, wat eigenlijk de bedoeling is, is dat hij op e-mail adres checkt,

omdat ik zelf bijvoorbeeld, 3 emailadressen heb met precies dezelfde naam.

hier checkt hij op de name

If sSenderName = oAEntry.Name Then
    MsgBox "Adresslijst : " & oALijst.Name & vbCrLf & "Gevonden : " & oAEntry.Name
Exit For

ik denk dat hierin iets veranderd moet worden dat hij op email zoekt, maar ik kwam er niet helemaal uit

ik hoop dat je me nog iets verder kunt helpen

Private Sub Application_ItemLoad(ByVal Item As Object)

'(Outlook 2010 VBA)

'when you click on a mail it runs this script to check if the sender of that mail
'is already a contact, and if he's not, open the pannel to add him to contacts

Dim folContacts As Outlook.MAPIFolder
Dim colItems As Outlook.Items
Dim oContact As Outlook.ContactItem
Dim contactFolder As Outlook.Folder
Dim oMail As Outlook.MailItem
Dim obj As Object
Dim oNS As Outlook.NameSpace

Dim oALijsten As Outlook.AddressLists
Dim oALijst As Outlook.AddressList
Dim oAEntries As Outlook.AddressEntries
Dim oAEntry As Outlook.AddressEntry
'' Dim Gebruiker As ExchangeUser

Dim bContinue As Boolean
Dim sSenderName 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

       'defines the name of the sender
       sSenderName = oMail.SentOnBehalfOfName

        If sSenderName = ";" Then
           sSenderName = oMail.SenderName
        End If
        esender = oMail.SenderEmailAddress

        'sets the e-mail address of the sender
        Set esender = colItems.Find("[E-mail] = '" & esender & "'")

        'sets the name of the oContact, to the name of the sender
        Set oContact = colItems.Find("[FullName] = '" & sSenderName & "'")

       'checks if the e-mailadress exsist in the contacts, if it does exit the for loop
        If Not esender Is Nothing Then
'            MsgBox "Gevonden in contacts: " & sSenderName
           Exit For
        Else

           'checks if the name or the e-mailadress exsist in one of the address lists, if it does exit the for loop
           Set oALijsten = oNS.AddressLists
           esender = oMail.SenderEmailAddress
           teller = 1

           'loop through the available address lists
           Do While teller < oALijsten.Count + 1
               Set oALijst = oALijsten.Item(teller)
               Set oAEntries = oALijst.AddressEntries
               counter = 1


               'loop trough the entries of the address list
               Do While counter < oAEntries.Count + 1
                   Set oAEntry = oAEntries.Item(counter)
                   'check the senders name

                   If sSenderName = oAEntry.Name Then
                       MsgBox "Adresslijst : " & oALijst.Name & vbCrLf & "Gevonden : " & oAEntry.Name
                       Exit For
''                    Else

''                    'check the senders mail address
''                        Set Gebruiker = oAEntry.GetExchangeUser
''                        If Gebruiker.PrimarySmtpAddress = esender Then
''                              'MsgBox "mail adres gevonden : " & sSenderName & vbCrLf & "Gevonden : " & Gebruiker.PrimarySmtpAddress
''                            Exit For
''                        End If
                   End If
                   counter = counter + 1
               Loop
               teller = teller + 1
           Loop
        End If
   End If

   'fill in the fields of the "AddContact Pannel"
   If bContinue Then
     Set oContact = colItems.Add(olContactItem)
       With oContact

        .Email1Address = oMail.SenderEmailAddress
        .Email1DisplayName = sSenderName
        .Email1AddressType = oMail.SenderEmailType
        .FullName = oMail.SenderName

        '.Save

       'displays the add contact pannel
        oContact.Display
        MsgBox "Deze persoon staat nog niet in uw Contactpersonen of Adressboek"

       End With
   End If
Next

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