Kopiering af data i Outlook kontaktpersoner

Mailadressen er altså blevet overført?

Er det stadig aktuelt?

Forslag:
Sub flytFraEMail()
Dim mailApp, nameSpace, kontakter, kontakt
Dim antalKontakter As Long
Dim mail As String, p As Byte, mailDel As String
    Set mailApp = CreateObject("Outlook.Application")
    Set nameSpace = mailApp.GetNamespace("MAPI")
    Set kontakter = nameSpace.GetDefaultFolder(olFolderContacts)
   
    antalKontakter = kontakter.Items.Count
   
    For Each kontakt In kontakter.Items
        mail = kontakt.Email1Address
        p = InStr(mail, "@")
        If p > 0 Then
            mailDel = Left(mail, p - 1)
            kontakt.MiddleName = "(" & mailDel & ")"
            kontakt.Save
        End If
    Next

Virker næsten.

1. Da mailen kommer fra en GAL, skriver den i variablen "mail" stigen der til og ikke mail adressen. eks: "/0=xxx/ou=DKBA/cn=Recipients/cn=xxxx" De sidste x'er er initialerne.
2. Kan du lave den sådan, at det kun sker på dem jeg har markeret :-)

Et forsøg værd..

1. Skulle være rimelig let

2. Hvad/hvordan vil du markere?
-. Alternativt: Kunne der stilles et programmeret spørgsmål

1:Til test

Rem Version 2
Sub flytFraEMail()
Const søgeStreng = "Recipients/cn="
Dim mailApp, nameSpace, kontakter, kontakt
Dim antalKontakter As Long
Dim sti As String, mail As String, p As Byte, mailDel As String
    Set mailApp = CreateObject("Outlook.Application")
    Set nameSpace = mailApp.GetNamespace("MAPI")
    Set kontakter = nameSpace.GetDefaultFolder(olFolderContacts)
   
    antalKontakter = kontakter.Items.Count
   
    For Each kontakt In kontakter.Items
        sti = kontakt.Email1Address
        p = InStr(sti, søgeStreng)
       
        If p > 0 Then
            mailDel = Mid(sti, Len(søgeStreng) + 1)
            kontakt.MiddleName = "(" & mailDel & ")"
            kontakt.Save
        End If
    Next
End Sub

Tak supertekst! Så fik jeg det til at virker. Smid et svar :-)

Fint, selv tak - samt et svar