Outlook 2010 VBA - Add user

[ricje20]

Dit is hem bijna

wanneer een persoon dezelfde naam heeft, checkt hij alleen de eerste in de lijst.

bijvoorbeeld:

Rico Maartense (Rico.maartense@gmail.com)

Rico Maartense (Rico_maartense@hotmail.com)

in dit geval checkt hij alleen de eerste (dus gmail), dus als je hotmail en gmail hebt toegevoegd, checkt hij degene die bovenaan staat dus wanneer ik nu op een mail van het hotmail adres klik voegt hij hem toe (ook al bestaat hij al), dit is in de contactpersonen en adresboek.

ik dacht misschien moeten we net zoals we door het adresboek heen "telde", ook door de contactpersonen met dezelfde naam heengaan met een teller

ik hoop van je te horen

- - - Updated - - -

--update--

sorry dat ik zelf nog niet zoveel mee kan doen met de code

ik ben het nog een beetje aan het leren haha, ik leer hier wel een hoop van

[kweezie wabbit]

Ik zal het morgen of overmorgen eens nakijken

Eigenlijk moet er enkel getest worden of het email-adres van de afzender reeds voorkomt in de contacten of in een van de adresboeken, zelfs als de naam reeds is opgeslagen.

Klopt dat?

[ricje20]

Dat is helemaal juist

(gefeliciteerd met 20.000 berichten haha)

[kweezie wabbit]

Ik ben even teruggegaan naar je startbericht waarin je zegt.

... when i click on a mail (...) it has to check if the Sender of the mail is already in my contacts or in the Addressbook 'All Users',

Onderstaande code checkt dus enkel de adreslijsten contacts en all users

Ik heb het al eens gezegd: als er veel adressen in de lijst all users staan, kan het een tijdje duren en krijg je misschien de indruk dat outlook is vastgelopen, maar het komt wel goed.

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

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

        Set oALijsten = oNS.AddressLists
        teller = 1


       'checks if the e-mailadress exsist in the contacts, if it does exit the for loop
       Do While teller < oALijsten.Count + 1
           Set oALijst = oALijsten.Item(teller)
           If oALijst.Name = "Contacts" Then
               Set oAEntries = oALijst.AddressEntries
               counter = 1

               'loop trough the entries of the Contacts address list
               Do While counter < oAEntries.Count + 1
                   Set oAEntry = oAEntries.Item(counter)
                   If UCase(oAEntry.Address) = esender Then
'                        MsgBox "mail adres gevonden contacts : " & sSenderName & vbCrLf & "Gevonden : " & oAEntry.Address
                       Exit For
                   End If
                   counter = counter + 1
               Loop
           End If
           teller = teller + 1
       Loop


       'checks if the e-mailadress exsist in the all users address list, if it does exit the for loop
       teller = 1
       Do While teller < oALijsten.Count + 1
           Set oALijst = oALijsten.Item(teller)
           If oALijst.Name = "All Users" Then
               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)
                   If UCase(oAEntry.Address) = esender Then
'                        MsgBox "mail adres gevonden All Users: " & sSenderName & vbCrLf & "Gevonden : " & oAEntry.Address
                       Exit For
                   End If
                   counter = counter + 1
               Loop
           End If
           teller = teller + 1
       Loop

   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

[kweezie wabbit]

Hallo ricje20.

Heb je de nieuwste versie al kunnen uitproberen?

Is het goed zo of heb je nog opmerkingen?

[ricje20]

Hoi kweezie,

De nieuwe versie checkt alleen in het addressboek. maar de vorige code was wel goed

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

'                       check the senders mail address
                       Set Gebruiker = oAEntry.GetExchangeUser

                       If UCase(Gebruiker.Address) = 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

alleen ben ik nog iets vergeten (had het in het bedrijf geinstalleerd alleen bleek er dus nog 1 ding niet helemaal te kloppen haha)

een beetje vaag maar:

als je in de concepten, een concept klikt , kwam ook het AddContact schermpje naar boven. (zonder ingevulde velden maar dat waarschijnlijk omdat een concept geen "verzender" heeft).

ik dacht, misschien moeten we hier iets in veranderen dat hij alleen doorgaat met de check als je in de box Postvak in zit ofso

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

had al wat dingetjes geprobeerd als .select current folder if postvak in ga door (even op ze meest super simpels gezegt haha), maar kwam er niet uit.

Ik hoop dat je me nog niet zat bent :3

[kweezie wabbit]

In principe is het wel voldoende om enkel de contacten en de lijst "all users" te controleren.

We hoeven dus niet alle adreslijsten af te lopen.

De code is aangepast zodat enkel nog gecheckt wordt als de mail in de inbox staat of in een directe subfolder van de Inbox

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 folInbox 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 folInbox = oNS.GetDefaultFolder(olFolderInbox)
Set colItems = folContacts.Items


For Each obj In Application.ActiveExplorer.Selection

   If obj.Class = olMail Then
      If Not Application.ActiveExplorer.CurrentFolder.Name = "Inbox" And Not Application.ActiveExplorer.CurrentFolder.Parent.Name = "Inbox" Then
'            MsgBox "folder: " & Application.ActiveExplorer.CurrentFolder.Name
           Exit For
'        Else
'            MsgBox "folder: " & Application.ActiveExplorer.CurrentFolder.Name
       End If
       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 e-mail address of the sender
        esender = oMail.SenderEmailAddress

        Set oALijsten = oNS.AddressLists
        teller = 1


       'checks if the e-mailadress exsist in the contacts, if it does exit the for loop
       Do While teller < oALijsten.Count + 1
           Set oALijst = oALijsten.Item(teller)
           If oALijst.Name = "Contacts" Then
               Set oAEntries = oALijst.AddressEntries
               counter = 1

               'loop trough the entries of the Contacts address list
               Do While counter < oAEntries.Count + 1
                   Set oAEntry = oAEntries.Item(counter)
                   If UCase(oAEntry.Address) = esender Then
'                        MsgBox "mail adres gevonden contacts : " & sSenderName & vbCrLf & "Gevonden : " & oAEntry.Address
                       Exit For
                   End If
                   counter = counter + 1
               Loop
           End If
           teller = teller + 1
       Loop


       'checks if the e-mailadress exsist in the all users address list, if it does exit the for loop
       teller = 1
       Do While teller < oALijsten.Count + 1
           Set oALijst = oALijsten.Item(teller)
           If oALijst.Name = "All Users" Then
               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)
                   If UCase(oAEntry.Address) = esender Then
'                        MsgBox "mail adres gevonden All Users: " & sSenderName & vbCrLf & "Gevonden : " & oAEntry.Address
                       Exit For
                   End If
                   counter = counter + 1
               Loop
           End If
           teller = teller + 1
       Loop

   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]

Hoi kweezie,

De code werkte nog niet helemaal, dus heb wat kleine aanpassinkjes gedaan, nu doet hij het

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 folInbox 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 folInbox = oNS.GetDefaultFolder(olFolderInbox)
Set colItems = folContacts.Items

For Each obj In Application.ActiveExplorer.Selection

   If obj.Class = olMail Then
      If Not Application.ActiveExplorer.CurrentFolder.Name = "Postvak IN" And Not Application.ActiveExplorer.CurrentFolder.Parent.Name = "Postvak IN" Then
           'MsgBox "folder: " & Application.ActiveExplorer.CurrentFolder.Name
           Exit For

'        Else
           'MsgBox "folder: " & Application.ActiveExplorer.CurrentFolder.Name
       End If

       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 e-mail address of the sender
        esender = oMail.SenderEmailAddress
        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
'                       check the senders mail address
                       Set Gebruiker = oAEntry.GetExchangeUser

                       If UCase(Gebruiker.Address) = 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

Nu dat laatste dingetje nog, in een vorige post had ik het niet goed uitgelegd zie ik net

wanneer een persoon dezelfde naam heeft, checkt hij alleen de eerste in de lijst.

bijvoorbeeld:

Rico Maartense (Rico.maartense@gmail.com)

Rico Maartense (Rico_maartense@hotmail.com)

in dit geval checkt hij alleen de eerste (dus gmail), dus als je hotmail en gmail hebt toegevoegd, checkt hij degene die bovenaan staat dus wanneer ik nu op een mail van het hotmail adres klik voegt hij hem toe (ook al bestaat hij al), dit is in de contactpersonen

Daar moet bijgezegd worden,

Wanneer een persoon toevoegd met dezelfde naam, vraag hij of je er een nieuw contact van wilt maken, of het mailadres wil toevoegen bij dat bestaande contact, wanneer je voor dat laatste kiest, komt het er zo in je contacten uit te zien (screenshot)

in dit geval checkt hij alleen de eerste (dus hotmail), dus als je hotmail en gmail hebt toegevoegd, checkt hij degene die bovenaan staat dus wanneer ik nu op een mail van het gmail adres klik, voegt hij hem toe (ook al bestaat hij al), dit is in de contactpersonen

(in oorspronkelijk stond er ook bij dat het in adresboek was maar dat is nu niet het geval)

[ricje20]

--update--

zag hier staan

     Set oContact = colItems.Add(olContactItem)
       With oContact
        .Email1Address = oMail.SenderEmailAddress
        .Email1DisplayName = sSenderName
        .Email1AddressType = oMail.SenderEmailType
        .FullName = oMail.SenderName

Email 1 Address en Email 1 DisplayName

moeten we dan niet ergens zorgen dat hij ook Email 2 checkt?

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

        If Not esender Is Nothing Then
           'MsgBox "Gevonden in contacts: " & sSenderName
           Exit For

misschien dat we hier dan moeten zorgen dat hij mail addres 2 langsgaat? of zit ik daar fout te proberen

19 maart 2013 aangepast door ricje20

[kweezie wabbit]

Probeer het eens met deze code.

        If Not esender Is Nothing Then
           [b]If oContact.Email1Address = oMail.SenderEmailAddress Or oContact.Email2Address = oMail.SenderEmailAddress Or oContact.Email3Address = oMail.SenderEmailAddress Then
               'MsgBox "Gevonden in contacts: " & sSenderName
               Exit For
           End If[/b]
        Else