Outlook 2010 VBA - Add user

[kweezie wabbit]

Vervang dan

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

door

If esender = oAEntry.Address Then      
  MsgBox "Adresslijst : " & oALijst.Name & vbCrLf & "Gevonden : " & oAEntry.Name & vbCrLf & "mail adres gevonden : " & oAEntry.Address
  Exit For

en probeer het dan nog eens.

[ricje20]

Hey

hij geeft nu in dat "infoboxje" het e-mail adres wel weer, maar hij zoekt er nog steeds niet op.

ik weet niet goed hoe ik het moet uitleggen.. ik zal proberen precies te omschrijven wat er moet gebeuren.

--

Ik klik op een e-mail in mijn inbox.

hij zoekt het e-mail adres van de zender van de e-mail en kijkt of het e-mail adres in contactpersonen staat (dit werkt), en hij kijkt of het e-mail adres in een adresboek staat.

wanneer het mailadres in contactpersonen of adresboek gevonden is, (dus al bestaat), moet er niks gebeuren.

wanneer hij nog niet bestaat dan.... (nja dat werkt al )

--

(vanaf hier even uitgaan van de " oude code ")

waar

If sSenderName = oAEntry.Name Then

'                        MsgBox "Adresslijst : " & oALijst.Name & vbCrLf & "Gevonden : " & oAEntry.Name
                       Exit For

nog in staat (dus hij zoekt op naam)

----

'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

hierzo had ik gevonden dat de esender weer word "hernoemd", als ik die regel zo laat staan, voegt hij elk contact toe, (de check werkt dan niet).

Zonder de "esender = oMail.SenderEmailAddress" werkte hij eigenlijk helemaal

behalve, dat hij op de naam zocht. en aan de hand van de naam bepaalde of de zender al in de contactpersonen of adresboek staat.

maar het probleem dan is dat wanneer er iemand meerdere mail adressen heeft, dus dezelfde naam, maar een ander mail adress, bijv. kees derpkenderkonson (kees_derpkenderkonson@hotmail.com), kees derpkenderkonson (kees.derpkenderkonson@gmail.com). dan ziet hij het 2e adress al als een bestaant contact terwijl je alleen het eerste adres nog maar heb.

Ik hoop dat het een beetje te begrijpen is :3, zoniet hoor ik het graag.

(sorry dat ik zoveel op de kleine dingetjes doorga maar het moet in een bedrijf gaan runnen :3)

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 esender to the e-mail address of the sender
        Set esender = colItems.Find("[E-mail] = '" & esender & "'")

        'sets 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

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

                 'email
                 '     If esender = oAEntry.Address Then
                 '      'MsgBox "Adresslijst : " & oALijst.Name & vbCrLf & "Gevonden : " & oAEntry.Name & vbCrLf & "mail adres gevonden : " & oAEntry.Address
                 '       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 sSenderName + " 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]

Oh,

ben er achter gekomen dat het toch niets uitmaakt of je esender = oMail.SenderEmailAddress laat staan of niet >.<

ik dacht eerst te waarnemen dat dit iets deed, maar blijkbaar niet ;p

sorry!

     
   '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

[kweezie wabbit]

Het volledige email adres kan je niet rechtstreeks uit oAEntry halen.

Het volledige email adres kan wel opgehaald worden met oAEntry.GetExchangeUser en daar de property PrimarySmtpAddress uitlezen. Maar dat lukt enkel als je exchange server gebruikt en dat is bij jou dus niet het geval.

Het probleem is dat in oAEntry.Address alleen het gedeelte voor de @ staat.

oAEntry.Address is nochtans een gewone string. Dan zou je bij het aanmaken van de AddressEntry normaal het volledige mail adres kunnen ingeven.

Dergelijke zaken kan ik dus niet testen omdat ik hier op een bedrijfsnetwerk zit waar ik geen toegang heb tot die adreslijsten om ze aan te passen.

Ik zou het thuis moeten nakijken maar dat zal dan iets voor morgen of overmorgen zijn.

[ricje20]

Hey,

Het zou super zijn als u dat morgen/overmorgen zou willen testen :3

zoals het nu is ga ik het alvast proberen los te gooien op een paar computers in het bedrijf.

ik wacht af op uw antwoordt ^.^

[kweezie wabbit]

Helaas kan ik thuis enkel AddressEntries toevoegen in de lijst contacten en die worden reeds correct gecontroleerd.

Als ik het goed begrijp, gaat het dus om iets voor "het bedrijf".

In ons bedrijf (ongeveer 35.000 werknemers en vestigingen in gans Belgie) word het beheer van de (mail)accounts gedaan in Active Directory en heeft elke vestiging zijn eigen lokale mailserver plus een centrale mailserver in Brussel.

Hoe gaat het er bij jullie aan toe?

Hebben jullie dan geen eigen mailserver?

Misschien dat je daar iets kan wijzigen aan de AddressEntries.

Het kan ook zijn dat die gegevens moeten/kunnen aangepast worden in Active Directory maar daar heb ik ook geen verstand van.

[ricje20]

Hey,

Het is gewoon een klein bedrijfje ongeveer 15 mensen

Ik heb net even een mailtje naar de "beheerder" gestuurd

met de vraag:

hebben we een eigen mailserver?

antwoordt:

Jawel, daar draait exchange 2007 op.

... exchange? maar dan zouden die "blauwe regels" ook gelden in het script of is dit weer wat anders?

[kweezie wabbit]

Dan zouden de blauwe regels in het vorige script ook moeten werken.

Ik heb nog een kleine aanpassing gedaan (rode markering) maar dit zou het dan moeten zijn voor een exchange mailserver.

Bij het doorlopen van de entries in de verschillende adreslijsten werd vroeger de loop verlaten als de naam gevonden werd.

Nu word er ook een controle van het mailadres gedaan alvorens de verder te gaan of de loop te verlaten.

Op die manier wordt effectief getest op het mailadres van de afzender, zelfs als de naam meerdere keren voorkomt in de lijst.

Test het uit en laat maar weten of het nu OK is.

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
[color=#ff0000]                    If sSenderName = oAEntry.Name Then
'                        MsgBox "Adresslijst : " & oALijst.Name & vbCrLf & "Gevonden : " & oAEntry.Name
'                       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[/color]
                   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

[ricje20]

Hey,

hmm.. erg moelijk uit te leggen dit

ik klik op een mail

als de naam (email adres weet ik niet want hij voegt hem zoizo toe nu ;p) van de persoon in het adresboek staat voegt hij hem toe (altijd, 1 uitzondering, voor uitzondering zie verder xD).

maar bij contacts, doet hij het nu perfect ;o

Rico Maartense (rico.maartense@gmail.com) staat in contacts

ik klik op Rico Maartense (rico_maartense@hotmail.com) en hij ziet dat het e-mail adres verschilt dus hij voegt hem toe.

maar nu rico maartense al in contacts staat, voegt hij hem niet meer toe, ook al staat rico maartense in het adresboek (die altijd toevoegt) ...

... ik snap zelf amper hoe ik dit moet uitleggen lol.. ik hoop dat je het een beetje begrijpt

de contacts werken nu dus goed en zoekt op e-mail. maar als de naam in het adresboek staat voegt hij hem zoizo toe behalve als de naam al in contacts staat.

Private Sub Application_ItemLoad(ByVal Item As Object)
'(Outlook 2010 VBA)
'by Rico Maartense
'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

'' exchange rule
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 esender to the e-mail address of the sender
        Set esender = colItems.Find("[E-mail] = '" & esender & "'")

        'sets 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)


            'checks the senders name/email-address, if it does exit the for loop
                     If sSenderName = oAEntry.Name Then
'                        MsgBox "Adresslijst : " & oALijst.Name & vbCrLf & "Gevonden : " & oAEntry.Name


                      'exchange rule
'                       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 sSenderName + " staat nog niet in uw Contactpersonen of Adresboek"
       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

6 maart 2013 aangepast door ricje20

[kweezie wabbit]

Kleine aanpassing (rood gemarkeerd)

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
[color=#ff0000]                        If UCase(Gebruiker.Address) = esender Then[/color]
'                            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

Is het nu beter?