automatisk gemning af e-mailadresser i outlook 2003

Ja det kan man godt.
Er du nu helt sikker på at det er det du vil? Tænk på spam! Det kan blive et hyr at holde rede på.

Jeg har ikke lige en macro der kan gøre det, men jeg er da frisk på at lave den.

Ja det er jeg helt sikker på. Det er nu ikke mig der skal bruge den, men ja, jeg vil gerne have sådan en.

OK - Kigger lige på det ...

det er fint nok, hvis jeg bare får et program, der kan gemme adresserne automatisk efter at jeg har besvaret en mail

Beklager at jeg gør det lidt besværligt, det var mig der ikke var præcis nok i udgangspunktet.

Det jeg søger er et program, lige som i linket nedenfor, bare et der er gratis (og lovligt) i stedet for

http://www.mapilab.com/outlook/add_contacts/

Nå da - nu har jeg lavet det meste til 'NewMailEx' eventet.
Måske kan dette alligevel bruges.


Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    Dim mai As Object
    Dim intInitial As Integer
    Dim intFinal As Integer
    Dim strEntryId As String
    Dim intLength As Integer
   
    intInitial = 1
    intLength = Len(EntryIDCollection)
    intFinal = InStr(intInitial, EntryIDCollection, ",")
    Do While intFinal <> 0
        strEntryId = Strings.Mid(EntryIDCollection, intInitial, (intFinal - intInitial))
        Set mai = Application.Session.GetItemFromID(strEntryId)
        addContactFromSender mai
        intInitial = intFinal + 1
        intFinal = InStr(intInitial, EntryIDCollection, ",")
    Loop
    strEntryId = Strings.Mid(EntryIDCollection, intInitial, (intLength - intInitial) + 1)
    Set mai = Application.Session.GetItemFromID(strEntryId)
    addContactFromSender mai
End Sub

Private Function isContact(ByVal email As String)
    Dim NS As NameSpace
    Dim fldr As MAPIFolder
    Dim cont As ContactItem
    Set NS = Application.GetNamespace("MAPI")
    Set fldr = NS.GetDefaultFolder(olFolderContacts)
    isContact = False
    Dim idx As Integer
    For idx = 1 To fldr.Items.Count
        Set cont = fldr.Items.item(idx)
        If email = cont.Email1Address Or _
          email = cont.Email2Address Or _
          email = cont.Email3Address Then isContact = True
    Next idx
End Function

Private Sub ShowSender(ByVal item As mailItem)
    MsgBox item.Subject & " from (" & item.SenderEmailAddress & ")"
End Sub

Private Sub addContactFromSender(ByVal mail As mailItem)
    If (MsgBox("Tilføj " & mail.SenderEmailAddress & " til Kontakter?", vbQuestion, "Bekræft ...") = vbYes) Then
        If isContact(mail.SenderEmailAddress) Then Return
        Dim myItem As ContactItem
        Set myItem = Application.CreateItem(olContactItem)
        myItem.Email1Address = mail.SenderEmailAddress
        If (mail.SenderName <> "") Then myItem.FullName = mail.SenderName
    End If
End Sub

Jeg er slet ikke inde i alt sådan noget med coder osv. så ved slet ikke hvordan jeg skal bruge den.

Men det er helt fint, hvis bare vi får det til at virke :-)

Hvis du vil være behjælpelig med at vejlede mig i hvordan jeg får den installeret, så er jeg da frisk på at prøve den

OK:

1.  I outlook taster du Alt-F11 for at åbne VisualBasic Editor.
2.  Dobbeltklik på 'ThisOutlookSession'
3.  Indsæt koden
4  Tast Ctrl-S

(5. Afvent modtagelse af e-mail for at teste)

okay - det prøver jeg lige så

Bemærk: Det sker med det samme når der motages en ny e-mail (efter en bekræftelse)

Umiddelbart kan jeg ikke se noget der hedder 'Thisoutlooksession'

Tror jeg fandt det i en undermappe til projekt1 over til venstre

Nu tror jeg at jeg har gjort det jeg skulle. Men vinduet er der stadig efter at jeg har trykket på ctrl-s

Har prøvet at sende en mail til mig selv fra en anden konto, men den gemmer ikke adressen

Programmet kontrollerer om adressen findes, og opretter ikke doubletter.
Findes din anden mail-adresse ikke på listen ?

nej det gør den ikke :-) tror det er for besværligt. Jeg synes ikke den ser ud til at gemme det, har du da testet om den virker ved dig selv?

det er ikke for at være ubehøvlet eller noget, men jeg afviser svaret i første omgang, så er der måske lidt flere der kikker med - du skal nok få dine point alligevel, hvis det viser sig at det kommer op at køre

Jeg har vis overset et par fejl, og det er ikke testet grundigt nok.
Jeg vender tilbage...  ;-)

Jeg skal helst bruge den i morgen formiddag, ellers blive jeg nød til at finde en anden løsning - men det er fint at du arbejder på det synes jeg

Nu er den der (håber jeg). Jeg har testet denne udgave og har oprettet en kotakt med den.


Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    Dim mai As Object
    Dim intInitial As Integer
    Dim intFinal As Integer
    Dim strEntryId As String
    Dim intLength As Integer
   
    intInitial = 1
    intLength = Len(EntryIDCollection)
    intFinal = InStr(intInitial, EntryIDCollection, ",")
    Do While intFinal <> 0
        strEntryId = Strings.Mid(EntryIDCollection, intInitial, (intFinal - intInitial))
        Set mai = Application.Session.GetItemFromID(strEntryId)
        addContactFromSender mai
        intInitial = intFinal + 1
        intFinal = InStr(intInitial, EntryIDCollection, ",")
    Loop
    strEntryId = Strings.Mid(EntryIDCollection, intInitial, (intLength - intInitial) + 1)
    Set mai = Application.Session.GetItemFromID(strEntryId)
    addContactFromSender mai
End Sub

Private Function isContact(ByVal email As String, fldr As MAPIFolder)
    Dim cont As ContactItem
    isContact = False
    Dim idx As Integer
    For idx = 1 To fldr.Items.Count
        Set cont = fldr.Items.item(idx)
        If email = cont.Email1Address Or _
          email = cont.Email2Address Or _
          email = cont.Email3Address Then isContact = True
    Next idx
End Function

Private Sub ShowSender(ByVal item As mailItem)
    MsgBox item.Subject & " from (" & item.SenderEmailAddress & ")"
End Sub

Private Function askAdd(ByVal mail As mailItem) As Boolean
    askAdd = (MsgBox("Tilføj " & mail.SenderEmailAddress & " til Kontakter?", vbYesNo + vbQuestion, "Bekræft ...") = vbYes)
End Function

Private Sub addContactFromSender(ByVal mail As mailItem)
    Dim NS As NameSpace
    Dim fldr As MAPIFolder
    Dim found As Boolean
    Set NS = Application.GetNamespace("MAPI")
    Set fldr = NS.GetDefaultFolder(olFolderContacts)
    found = isContact(mail.SenderEmailAddress, fldr)
    If Not found And askAdd(mail) Then
        Dim myItem As ContactItem
        Set myItem = fldr.Items.Add(olContactItem)
        myItem.Email1Address = mail.SenderEmailAddress
        If (mail.SenderName <> "") Then myItem.FullName = mail.SenderName
        myItem.Display
    End If
End Sub

Det prøver jeg lige så

PS: evt
  efter:
    myItem.Display
  indsæt:
    fldr.Display

1) For det første er det gamle vindue der stadig, når jeg trykker alt F11

2) Når jeg sletter teksten i det og sætter den nye ind, sker der intet.

Ser ikke ud til at virke

Det ser ikke ud til at den vil gemme den, ved snart ikke om jeg gider prøve mere

Lige et svar mere ;)

PS:
Hvis man ikke gemmer, når vinduet med den nye kontakt åbnes, bliver kontakten ikke oprettet. Der er alså mulighed for at fortryde.

Nu tror jeg at jeg stopper, nu fryser mit outlook når jeg starter, den bliver hængende ved "binder data" neders til venstre, noget lort.

Visual Basic Vinduet lukkes med Alt-F4 eller det lille kryds øverst til højre.

Jeg har fået det til at virke fint her.

Læg lige den lange tekst ind igen, sådan som den skal være, uden at jeg skal lave nogle tilføjleser i den. hvis jeg ikke kan få outlook igang igen, lukker jeg

Min kommentar (09/11-2006 00:33:46) er ikke nødvendig for funktion, så brug bare koden fra (09/11-2006 00:31:27)

Er der problemer med selve outlook programmet?

jeg kører lige reg mech lige nu og genstarter computeren om lidt, så ser jeg om den vil i gang igen.

Microsoft har ikke altid en fornuftig fejlmeddelelse, men så kan man 'spamme' dem med en fejlrapport hvis programmet går død.

Nu har jeg fået programmet igang igen.

Er det ikke muligt helt at slette det første jeg lavede, og så prøve at lave det helt på ny?

Det er da fint at du har tålmodighed til at sidde så længe med det

Det virker bare ikke hos mig

"Tålmodighed er en dyd" som en gammel programmør jeg kendte sagde. Man skal beside en stædig tålmodighed for at få computere til at makke ret. Især når man vil programmere dem.  :-P

Slette: Ctrl-A  +  Del
        Markér alt -> Delete-tast 

Kopiere Ctrl-C
Indsætte Ctrl-V

:P Pyh ha. Din Outlook kører godt nok igen?

Prøv at forklare hvead der sker når det ikke virker...

Jeg er sikker på at den ikke gemmer det på min computer.

10 Minutter mere, så gider jeg ikke mere, og opgiver det

Når jeg går ind og skal lave den står der over til venstre VBAprojekt 1, den dobbelklikker jeg på, så kommer jeg til microsoft outlook, den har en en undermappe der hedder thissession, den klikker jeg på.

Jeg markerer hele teksten i boksen, og så skifter det i vinduet foroven til general (før var det application)

Så sætter jeg den nye tekst ind:
I vinduet over til højre står der addcontact for sender.

Der sker intet når jeg trykker på control og s

Det er den her tekst jeg kopierer ind

Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    Dim mai As Object
    Dim intInitial As Integer
    Dim intFinal As Integer
    Dim strEntryId As String
    Dim intLength As Integer
   
    intInitial = 1
    intLength = Len(EntryIDCollection)
    intFinal = InStr(intInitial, EntryIDCollection, ",")
    Do While intFinal <> 0
        strEntryId = Strings.Mid(EntryIDCollection, intInitial, (intFinal - intInitial))
        Set mai = Application.Session.GetItemFromID(strEntryId)
        addContactFromSender mai
        intInitial = intFinal + 1
        intFinal = InStr(intInitial, EntryIDCollection, ",")
    Loop
    strEntryId = Strings.Mid(EntryIDCollection, intInitial, (intLength - intInitial) + 1)
    Set mai = Application.Session.GetItemFromID(strEntryId)
    addContactFromSender mai
End Sub

Private Function isContact(ByVal email As String, fldr As MAPIFolder)
    Dim cont As ContactItem
    isContact = False
    Dim idx As Integer
    For idx = 1 To fldr.Items.Count
        Set cont = fldr.Items.item(idx)
        If email = cont.Email1Address Or _
          email = cont.Email2Address Or _
          email = cont.Email3Address Then isContact = True
    Next idx
End Function

Private Sub ShowSender(ByVal item As MailItem)
    MsgBox item.Subject & " from (" & item.SenderEmailAddress & ")"
End Sub

Private Function askAdd(ByVal mail As MailItem) As Boolean
    askAdd = (MsgBox("Tilføj " & mail.SenderEmailAddress & " til Kontakter?", vbYesNo + vbQuestion, "Bekræft ...") = vbYes)
End Function

Private Sub addContactFromSender(ByVal mail As MailItem)
    Dim NS As NameSpace
    Dim fldr As MAPIFolder
    Dim found As Boolean
    Set NS = Application.GetNamespace("MAPI")
    Set fldr = NS.GetDefaultFolder(olFolderContacts)
    found = isContact(mail.SenderEmailAddress, fldr)
    If Not found And askAdd(mail) Then
        Dim myItem As ContactItem
        Set myItem = fldr.Items.Add(olContactItem)
        myItem.Email1Address = mail.SenderEmailAddress
        If (mail.SenderName <> "") Then myItem.FullName = mail.SenderName
        myItem.Display
    End If
End Sub

Alt hvad du beskriver er normalt hvad angår visual basic.

Du har dermed indsat koden rigtigt i Outlook basic-vinduet og kan lukke det.

Hvad sker der så når du modtager en mail?

PS: Man kan ikke se den gemmer med Ctrl-S, men den gør det.

PPS: Har man ikke gemt, vil Outlook spørge inden man lukker.

Der sker intet anderledes end når jeg plejer at modtage mails

Der burde ikke komme noget når det er fra en kontaktperson.
Ér det ikke en kontaktperson:
  1. Spørges om e@mail.adr skal tilføjes kontakter.
  2. Den nye kontakts vindue åbnes.
  Man kan nu skrive evt. supplerende oplysninger og gemme
  eller fortryde ved at lukke.

Virker kun på indbakke.

Det er ikke fra en kontakt person. Jeg gider ikke mere, køber programmet, jeg henviser til foroven. Du får dine points for besværet alligevel

øv al'så  - :(  det virker jo her.

Jeg ved ikke rigtigt hvad jeg mere kan gøre...

Held og lykke ;o)

... og tak for points ...