VBA Tools

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.