Ga naar inhoud

Outlook 2010 VBA - Add user

ricje20

Door ricje20
in Archief Microsoft Office

 Delen

Aanbevolen berichten

ricje20 Meewerkend lid

ricje20

Geplaatst:
  • Auteur
Geplaatst:

hoi kweezie, het werkte nog niet,

ik zal even me gedachtengang neerzetten.

Huidige code (met je laatste stukje gegeven code erin)

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
           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
       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 Adresboek, voer als mogelijk ook het telefoon nummer in."
       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

in het volgende stuk 

 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 Adresboek, voer als mogelijk ook het telefoon nummer in."
       End With

Zet je oContact zo neer, dat hij door de velden zoekt van het schermpje om iemand toe te voegen, daarin vind je email1address enzo.

nu zeggen we hier:

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

dat hij in oContact het Email1addres, Email2address enz. moet vinden, maar hiervoor zeggen we

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

we zoeken nu dus het emailaddress in een naamveld.

ik dacht als ik nu (zoals helemaal onderin gedaan word), eerst oContact zet naar colItems.Find(olContactItem)

en dan na het loopje oContact weer zet naar

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

werkt het misschien.

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

       Set oContact = colItems.Find(olContactItem)

        'checks if the e-mailadress exsist in the contacts, if it does exit the for loop
       If Not esender Is Nothing Then
           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
       Else

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

maar dat werkte nog niet

maar zoeken we nu wel echt de al bestaande contactpersonen door?

want volgens mij zoekt hij nu het schermpje door waarmee je een persoon toevoegd.

als een persoon nu als "niet bestaand contactpersoon" word gezien, ziet hij dus niet dat er in de contactpersonen het gevonden e-mailaddress al bestaat onder een contactpersoon als "2e e-mailaddress".

op een of andere manier zouden we dan moeten zorgen dat hij kijkt in de bestaande contacten of het 2e veld e-mailadress overeenkomt met het emailaddress van de zender.. :pcguru:

Ik hoop dat ik een beetje te volgen ben

- - - Updated - - -

--update--

Misschien heb je wat aan dit screenshotje :)

post-20361-1417705352,9363_thumb.jpg

  • Reacties 38
  • Aangemaakt
  • Laatste reactie

Beste reacties in dit topic

Populaire dagen

Beste reacties in dit topic

Populaire dagen

Geplaatste afbeeldingen

kweezie wabbit Grootmeester

kweezie wabbit

Geplaatst:
Geplaatst:

Het was een zware bevalling maar ik denk dat het nu wel goed is.

Dit is de volledige code.

Je moet wel de rode lijnen nog eens goed nakijken of de naam van de adreslijst correct is want ik werk met een engels versie.

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 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
      'If Not Application.ActiveExplorer.CurrentFolder.Name = "Inbox" And Not Application.ActiveExplorer.CurrentFolder.Parent.Name = "Inbox" Then
           Exit For
       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

        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
           [color=#ff0000]If oALijst.Name = "Contacten" Then[/color]
               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)
                   Set oContact = oAEntry.GetContact
                   If Not oContact Is Nothing Then
                       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
                   End If
                   counter = counter + 1
               Loop
           End If
           teller = teller + 1
       Loop

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

           'loop through the available address lists but skip "contacts"
           Do While teller < oALijsten.Count + 1
               Set oALijst = oALijsten.Item(teller)
               'If Not oALijst.Name = "Contacts" Then
               [color=#ff0000]If Not oALijst.Name = "Contacten" Then[/color]
                   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
                           '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
               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

Het heeft even geduurd maar ik ben er dus achter gekomen dat een contact met meerdere mailadressen (zoals op jouw afbeelding hierboven) voor elk mailadres een entry heeft in de adreslijst "contacten" maar slechts 1 vermelding in de map contacten.

Als je de map contacten doorzoekt met het mailadres, wordt er enkel naar het eerste mailadres gekeken.

Dat was ook de reden dat sommige zaken fout liepen bij het opzoeken.

Het volgende kan zich dus voordoen.

Er is reeds een contact op naam van Rico Maartense met onderstaande mailadressen

email1 = Rico Maartense (Rico.maartense@gmail.com)

email2 = Rico Maartense (Rico_maartense@hotmail.com)

Nu komt er een mail binnen van Maartense Rico met Rico_maartense@hotmail.com als afzender.

Dit werd in onze vorige code niet opgevangen omdat de naam nog niet in de map contacten stond en omdat het mailadres niet als eerste stond in een bestaande contact.

Resultaat was een nieuw contact, alhoewel het mailadres reeds gekend was ==> foutje dus :embarassed:

De nieuwe werkt dus op de volgende manier.

Eerst testen we of we wel in de inbox (postvak in) of een directe submap zitten.

If Not Application.ActiveExplorer.CurrentFolder.Name = "Postvak IN" And  Not Application.ActiveExplorer.CurrentFolder.Parent.Name = "Postvak IN"  Then
   Exit For
End If

Dan doorlopen we de contactenlijst in het adresboek (en niet de map contacten)

We halen van elke entry het bijhorende contact op en controleren dan alle emailadressen voor dat contact.

        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
           [color=#ff0000]If oALijst.Name = "Contacten" Then[/color]
               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)
                   Set oContact = oAEntry.GetContact
                   If Not oContact Is Nothing Then
                        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
                   End If
                   counter = counter + 1
               Loop
           End If
           teller = teller + 1
       Loop

Als we geen match hebben voor het emailadres, gaan we verder met de andere adreslijsten maar we slaan de contacten over want die hebben we al gehad.

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

           'loop through the available address lists but skip "contacts"
           Do While teller < oALijsten.Count + 1
               Set oALijst = oALijsten.Item(teller)
               'If Not oALijst.Name = "Contacts" Then
               [color=#ff0000]If Not oALijst.Name = "Contacten" Then[/color]
                   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
                           '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
               End If
               teller = teller + 1
           Loop

Zodra een match met het mailadres van de afzender is gevonden, wordt de procedure verlaten.

Als er geen match gevonden werd, word een nieuw contact aangemaakt.

Bij het opslaan van het nieuwe contact, kan het gebeuren dat er voor die naam al een contact bestaat.

Dan krijg je de keuze om het bestaande contact te updaten of toch een nieuw contact aan te maken.

Hier mag je zelf kiezen wat je doet want het maakt geen verschil bij latere opzoekingen.

Test het maar eens grondig uit en laat dan weten wat je bevindingen zijn.

ricje20 Meewerkend lid

ricje20

Geplaatst:
  • Auteur
Geplaatst:

hoi Kweezie!

Ik ben nog geen fouten tegengekomen :) ziet er super uit!

ik ga hem weer door het bedrijf heen gooien en kijken wat er gebeurt

super bedankt, ik laat nog even weten wanneer ik het in het bedrijf geinstalleerd heb en het allemaal werkt :)

(voor de mensen met hetzelfde probleem)

FINAL CODE (nederlandse versie van outlook):

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 in contacts or addressbook, 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 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
      'If Not Application.ActiveExplorer.CurrentFolder.Name = "Inbox" And Not Application.ActiveExplorer.CurrentFolder.Parent.Name = "Inbox" Then
           Exit For
       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

       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
           If oALijst.Name = "Contactpersonen" 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)
                   Set oContact = oAEntry.GetContact
                   If Not oContact Is Nothing Then
                       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
                   End If
                   counter = counter + 1
               Loop
           End If
           teller = teller + 1
       Loop

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

      'loop through the available address lists but skip "contacts"
       Do While teller < oALijsten.Count + 1
           Set oALijst = oALijsten.Item(teller)

          'If Not oALijst.Name = "Contacts" Then
           If Not oALijst.Name = "Contactpersonen" 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)

                  'check the senders name
                   If sSenderName = oAEntry.Name Then

                      '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
           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, voer als mogelijk ook het telefoon nummer in"
       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

FINAL CODE (engelse versie van outlook):

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 in contacts or addressbook, 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 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
       If Not Application.ActiveExplorer.CurrentFolder.Name = "Inbox" And Not Application.ActiveExplorer.CurrentFolder.Parent.Name = "Inbox" Then
           Exit For
       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

       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
          'If oALijst.Name = "Contactpersonen" 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)
                   Set oContact = oAEntry.GetContact
                   If Not oContact Is Nothing Then
                       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
                   End If
                   counter = counter + 1
               Loop
           End If
           teller = teller + 1
       Loop

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

      'loop through the available address lists but skip "contacts"
       Do While teller < oALijsten.Count + 1
           Set oALijst = oALijsten.Item(teller)

           If Not oALijst.Name = "Contacts" Then
          'If Not oALijst.Name = "Contactpersonen" 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)

                  'check the senders name
                   If sSenderName = oAEntry.Name Then

                      '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
           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, voer als mogelijk ook het telefoon nummer in"
       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

  • 2 weken later...
ricje20 Meewerkend lid

ricje20

Geplaatst:
  • Auteur
Geplaatst:

Kweezie,

ik heb hem in het bedrijf gerunt, maar vrijwel gelijk kreeg ik al de klacht dat hij vast liep en zeeeer traag was. zoals je inderdaad zei ;) sommige hebben veel contacten. hij looptelke contact door als je op een mail klikt, en bij die personen met veel contacten loopt hij idd vast/is hij traag.

Er zijn denk 2 opties,

1. terugkeren naar een iets oudere versie, (waar hij nog niet checkt op de dubbele e-mail adressen bij een contactpersoon)

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

of:

optie 2... misschien wel onmogelijk, zeg maar of je denkt dat het mogelijk is ;) anders is optie 1 ook goed

dat hij op naam zoekt, en wanneer je iemand met dezelfde naam heb, gaat hij de email adressen bij alleen die persoon na....

of zou dit alsnog vertragend zijn?

Ik hoor het nog! :)

- - - Updated - - -

Opzich is optie 1 ook mogelijk ;) dan vertel ik erbij dat ze gewoon geen 2 e-mail adressen onder 1 naam moeten toevoegen, maar gewoon even een nieuw contact ervoor moeten maken.

Ik hoor het nog ;p

  • 2 weken later...
kweezie wabbit Grootmeester

kweezie wabbit

Geplaatst:
Geplaatst:

Je kan alvast deze kleine aanpassing (rood gemerkt) doorvoeren.

    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

[color=#ff0000]       Set oMail = obj

      If Not oMail.UnRead Then
           Exit For
       End If   [/color]       

       Set oContact = Nothing
       bContinue = True
       sSenderName = ""
[color=#ff0000]'        Set oMail = obj[/color]

Hierdoor zal enkel nog voor ongelezen berichten de controle gedaan worden.

Dat zal al een stuk schelen in soepelheid van gebruik.

  • 3 weken later...
ricje20 Meewerkend lid

ricje20

Geplaatst:
  • Auteur
Geplaatst: (aangepast)

Hoi kweezie,

het bedrijf waar ik stage liep en dit scriptje voor schreef bleek naa een aardige tijd toch geen goed bedrijf te zijn voor een stage plek.

er is ondertussen aardig wat tijd overheen gegaan maar ik loop nu stage bij een nieuw bedrijf. het scriptje kan daardoor niet afgemaakt worden :(

echt balen van het scriptje, het zal in ieder geval zeker niet verloren gaan.

Super bedankt voor de hulp en tijd die u hierin gestoken heeft.

ik zal dit markeren als opgelost aangezien er wel meerdere goede oplossingen inziten, maar die alleen niet bij het systeem van het bedrijf pasten.

groetjes,

ricje20

aangepast door ricje20
kweezie wabbit Grootmeester

kweezie wabbit

Geplaatst:
Geplaatst:

Geen probleem hoor; het was "vrije" tijd die ik er heb in gestoken en eigenlijk doe ik dat wel graag, zo wat prutsen met VBA.

Nog veel succes op je nieuwe stageplaats en als je ergens hulp bij nodig hebt, je weet ons wonen nietwaar xD.

:ciao:

Gast
Dit topic is nu gesloten voor nieuwe reacties.
 Delen
Ga naar topic overzicht
Logo

OVER ONS

PC Helpforum helpt GRATIS computergebruikers sinds juli 2006. Ons team geeft via het forum professioneel antwoord op uw vragen en probeert uw pc problemen zo snel mogelijk op te lossen. Word lid vandaag, plaats je vraag online en het PC Helpforum-team helpt u graag verder!

SITEMAP

×
×
  • Nieuwe aanmaken...

Belangrijke informatie

We hebben cookies geplaatst op je toestel om deze website voor jou beter te kunnen maken. Je kunt de cookie instellingen aanpassen, anders gaan we er van uit dat het goed is om verder te gaan.