Excel Forum - Porady, Pomoc,  Excel Help, Excel FAQ Strona Główna
 FAQ  RegulaminRegulamin  Szukaj   Użytkownicy   Grupy   Rejestracja   Profil   Twoje wiadomości   Zaloguj 


Poprzedni temat «» Następny temat
ID tematu: 69584 Skopiuj do schowka Outlook 2019 - dane z książki adresowej
Autor Wiadomość
Marti 
ExcelSpec



Wersja: Win Office 2019
Pomógł: 98 razy
Posty: 997
Wysłany: 16-12-2020, 09:38   Outlook 2019 - dane z książki adresowej

Witam.
Jak pobrać z Outlook (książka adresowa) do Excela (np. numery telefonów,adres email, ...) konkretnie jednego pracownika na podstawie imienia i nazwiska?
_________________
Najlepszym dowodem na to, że w kosmosie istnieje inteligencja, jest to, że się z nami nie kontaktują.
ID posta: 396618 Skopiuj do schowka
 
 
Artik 



Wersja: Win Office 365
Pomógł: 3133 razy
Posty: 10378
Wysłany: 22-12-2020, 00:31   

Przykład ze strony docs.microsoft.com, autorstwa Denisa Valentina (leciutko zmodyfikowany przeze mnie). Wymagane dodanie referencji do biblioteki Microsoft Outlook x.x Object Library.
Kod:

Sub Import_Contacts()

    'Outlook objects.
    Dim olApp       As Outlook.Application
    Dim olNamespace As Outlook.Namespace
    Dim olFolder    As Outlook.MAPIFolder
    Dim olConItems  As Outlook.Items
    Dim olItem      As Object

    'Excel objects.
    Dim wbBook      As Workbook
    Dim wsSheet     As Worksheet

    'Location in the imported contact list.
    Dim lnContactCount As Long

    Dim strDummy    As String

    'Turn off screen updating.
    Application.ScreenUpdating = False

    'Initialize the Excel objects.
    Set wbBook = ThisWorkbook
    Set wsSheet = wbBook.Worksheets(1)

    'Format the target worksheet.
    With wsSheet
        .Range("A1").CurrentRegion.Clear
        .Cells(1, 1).Value = "Company / Private Person"
        .Cells(1, 2).Value = "Street Address"
        .Cells(1, 3).Value = "Postal Code"
        .Cells(1, 4).Value = "City"
        .Cells(1, 5).Value = "Contact Person"
        .Cells(1, 6).Value = "Email"
        With .Range("A1:F1")
            .Font.Bold = True
            .Font.ColorIndex = 10
            .Font.Size = 11
        End With
    End With

    wsSheet.Activate

    'Initialize the Outlook variables with the MAPI namespace and the default Outlook folder of the current user.
    Set olApp = New Outlook.Application
    Set olNamespace = olApp.GetNamespace("MAPI")
    Set olFolder = olNamespace.GetDefaultFolder(10)
    Set olConItems = olFolder.Items

    'Row number to place the new information on; starts at 2 to avoid overwriting the header
    lnContactCount = 2

    'For each contact: if it is a business contact, write out the business info in the Excel worksheet;
    'otherwise, write out the personal info.
    For Each olItem In olConItems
        If TypeName(olItem) = "ContactItem" Then
            With olItem
                If InStr(olItem.CompanyName, strDummy) > 0 Then
                    Cells(lnContactCount, 1).Value = .CompanyName
                    Cells(lnContactCount, 2).Value = .BusinessAddressStreet
                    Cells(lnContactCount, 3).Value = .BusinessAddressPostalCode
                    Cells(lnContactCount, 4).Value = .BusinessAddressCity
                    Cells(lnContactCount, 5).Value = .FullName
                    Cells(lnContactCount, 6).Value = .Email1Address
                Else
                    Cells(lnContactCount, 1) = .FullName
                    Cells(lnContactCount, 2) = .HomeAddressStreet
                    Cells(lnContactCount, 3) = .HomeAddressPostalCode
                    Cells(lnContactCount, 4) = .HomeAddressCity
                    Cells(lnContactCount, 5) = .FullName
                    Cells(lnContactCount, 6) = .Email1Address
                End If
               
                If Len(Trim(Cells(lnContactCount, 6).Value)) > 0 Then
                    wsSheet.Hyperlinks.Add Anchor:=Cells(lnContactCount, 6), _
                                           Address:="mailto:" & Cells(lnContactCount, 6).Value, _
                                           TextToDisplay:=Cells(lnContactCount, 6).Value
                End If
            End With
            lnContactCount = lnContactCount + 1
        End If
    Next olItem

    'Null out the variables.
    Set olItem = Nothing
    Set olConItems = Nothing
    Set olFolder = Nothing
    Set olNamespace = Nothing
    Set olApp = Nothing

    'Sort the rows alphabetically using the CompanyName or FullName as appropriate, and then autofit.
    With wsSheet
        .Range("A2", Cells(2, 6).End(xlDown)).Sort key1:=Range("A2"), order1:=xlAscending
        .Range("A:F").EntireColumn.AutoFit
    End With

    'Turn screen updating back on.
    Application.ScreenUpdating = True

    MsgBox "The list has successfully been created!", vbInformation

End Sub

Artik
_________________
Persistence is a virtue in the world of programming.
ID posta: 396925 Skopiuj do schowka
 
 
Marti 
ExcelSpec



Wersja: Win Office 2019
Pomógł: 98 razy
Posty: 997
Wysłany: 22-12-2020, 08:08   

Niestety ten kod nie działa. On nie przeszukuje całej listy adresowej. Chcę wyszukać nr telefonu (np. Kowalski Marek) z pośród wszystkich pracowników - gdzie Kowalski Marek to będzie zmienna, bo za każdym razem będę szukać danych kogoś innego.
_________________
Najlepszym dowodem na to, że w kosmosie istnieje inteligencja, jest to, że się z nami nie kontaktują.
ID posta: 396931 Skopiuj do schowka
 
 
Artik 



Wersja: Win Office 365
Pomógł: 3133 razy
Posty: 10378
Wysłany: 23-12-2020, 01:53   

Marti napisał/a:
Niestety ten kod nie działa.
Ooo, to jest spore nadużycie. :-) Kod działa, lecz nie spełnia Twoich oczekiwań. :mrgreen:
Jeżeli w trybie krokowym przejrzysz właściwości zmiennej olFolder, to zobaczysz że w folderze Kontakty wszystko jest. Tyle, że pozostałe adresy mogą się znajdować w kolejnych podfolderach. Należałoby stworzyć funkcję rekurencyjną do przeszukiwania całej struktury folderu.

Możesz też spróbować użyć tego kodu, ale podmienić jedna linię na poniższą
Kod:
Set olFolder = olNamespace.GetDefaultFolder(33) '(10)
To folder Contact Search. Tyle, że nie wiem, czy zwróci Ci wszystkie adresy.
Nie wiem, nie znam się, zarobiony jestem. ;-)

Artik
_________________
Persistence is a virtue in the world of programming.
ID posta: 396962 Skopiuj do schowka
 
 
Wyświetl posty z ostatnich:   
Odpowiedz do tematu
Nie możesz pisać nowych tematów
Nie możesz odpowiadać w tematach
Nie możesz zmieniać swoich postów
Nie możesz usuwać swoich postów
Nie możesz głosować w ankietach
Nie możesz załączać plików na tym forum
Możesz ściągać załączniki na tym forum
Dodaj temat do Ulubionych
Wersja do druku

Skocz do:  

Powered by phpBB modified by Przemo © 2003 phpBB Group
Theme xandgreen created by spleen& Programosy modified v0.3 by warna
Opieka techniczna www.marketingNET.pl

Archiwum

Strona używa plików cookies.

Kliknij tutaj, żeby dowiedzieć się jaki jest cel używania cookies oraz jak zmienić ustawienia cookie w przeglądarce.
Korzystając ze strony użytkownik wyraża zgodę na używanie plików cookies, zgodnie z bieżącymi ustawieniami przeglądarki.
Sprawdź, w jaki sposób przetwarzamy dane osobowe