VBATools

Uzupełenienie danych kontaktów z ksiązki adresowej Outlooka

by on Dec.19, 2011, under Excel, Outlook, Porady

Przypuśćmy że posiadamy listę osób, co do których chcemy dopasować dane zawarte w lokalnej książce adresowej Outlooka. Niech elementem wyróżniającym będzie Nazwisko i Imię szukanej osoby zapisane w kolumnie A:A począwszy od wiersza drugiego. Spodziewanymi danymi będą: Stanowisko, e-mail, telefon GSM, telefon stacjonarny, nazwa firmy, adres firmy. Więcej elementów można dopisać do kodu uzupełniając je analogicznie w następnych kolumnach zakresu.

Kod można uruchomić bez referencji, to też deklaracja stałej numeru domyślnego dla folderu kontaktów. Wprowadzenie jednak kontrolki, pozwoli w razie konieczności zastosować subfoldery po ich nazwie. Opcją w tym przypadku też jest wykorzystanie komendy .PickFolder, dzięki której przypiszemy do zmiennej wskazany folder Outlooka.

Sub outlook_contacts()
Dim komorka As Range, zakres As Range, x&
Set zakres = Range("a2:a" & Cells(Rows.Count, "a").End(xlUp).Row)

Dim olApp As Object 'New Outlook.Application
Set olApp = CreateObject("Outlook.Application")
Dim oFolder As Object 'Outlook.MAPIFolder
Dim oKontakt As Object 'Outlook.ContactItem
Const olFolderContacts = 10
Set oFolder = olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)

Application.ScreenUpdating = False
For Each komorka In zakres
'DoEvents 'tutaj możemy dodać info do paska postępu
 For x = 1 To oFolder.Items.Count
 If oFolder.Items(x).Class = 40 Then
  Set oKontakt = oFolder.Items(x)
   With oKontakt
   'Debug.Print oKontakt.FullName
    If LCase(.LastName) & " " & LCase(.FirstName) = LCase(komorka.Value) Or _
     LCase(.FirstName) & " " & LCase(.LastName) = LCase(komorka.Value) Or _
     LCase(.FileAs) = LCase(komorka.Value) Then
     komorka.Offset(0, 1) = .JobTitle
     komorka.Offset(0, 2) = .Email1Address
     komorka.Offset(0, 3) = CStr(.MobileTelephoneNumber)
     komorka.Offset(0, 4) = CStr(.PrimaryTelephoneNumber)
     komorka.Offset(0, 5) = .CompanyName
     komorka.Offset(0, 6) = .BusinessAddress
     Exit For
    End If
   End With
  End If
 Next
Next komorka
Set zakres = Nothing
Set oFolder = Nothing
Set olApp = Nothing
Set oKontakt = Nothing
Application.ScreenUpdating = True
Beep
End Sub

Aby odszukać dane po adresie Email należy zamienić linijkę warunku na:

If LCase(.Email1Address) = LCase(komorka.Value) Or _
 LCase(.Email2Address) = LCase(komorka.Value) Or _
 LCase(.Email3Address) = LCase(komorka.Value) Then

(c) Shon Oskar – www.VBATools.pl

Wszelkie prawa zastrzeżone. Żadna część ani całość tego artykułu nie może być powielana ani publikowana bez zgody autora.

:, , , ,

Leave a Reply

Recently Active Members

Profile picture of vbatools
Profile picture of Karol Stilger
Profile picture of Joanna Subik
Profile picture of Anorak
Profile picture of marcinmachalowski
Profile picture of programistaaccess
Profile picture of piotrpawlik
Profile picture of Emil Wasilewski
Profile picture of kicekpicek
Profile picture of coldfusion
Profile picture of Gosia Borzęcka
Profile picture of lukaszch
Profile picture of itadministracja
Profile picture of farbenia
Profile picture of Łukasz Kałużny
Profile picture of kabzinski
Profile picture of rtynski
Profile picture of leszekbetlinski
Profile picture of Iv
Profile picture of Justyna Spychała