VBATools

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