Jak na propojení Excelu s Outlookem

Úvodní stránka | Blog | Excel VBA | Jak na propojení Excelu s Outlookem

    • Jak na propojení Excelu s Outlookem a proč vlastně? Po článku Jak na propojení Excelu s Wordem je další na řadě poštovní aplikace. Na čtyřech příkladech si ukážeme, čím si tyto dvě aplikace z balíčku Microsoft Office mohou být užitečné.

    Hned na začátku něco, co sám potřebuji velmi často – seznam e-mailových adres, které se potulují v mém Outlooku.

    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    'Tools / References / Microsoft Outlook xx.x Object Library

    Private Sub OutlookNacistAdresyZAdresare()

        Dim objOutlook As Object
        Dim objAddressList As Object
        Dim objAddressEntry As Object

        Dim i As Long
        Dim lngPocetPolozek As Long

        Dim arrAdresy()

        Set objOutlook = CreateObject("Outlook.Application")
        Set objAddressList = objOutlook.Session.AddressLists("Kontakty")

        Application.ScreenUpdating = False

        'počet položek v adresáři
        lngPocetPolozek = objAddressList.AddressEntries.Count

        'dimenzování pole
        ReDim arrAdresy(1 To lngPocetPolozek, 1 To 2)

        'prokaždý záznam v adresáři
        For Each objAddressEntry In objAddressList.AddressEntries

            'počítadlo
            i = i + 1
            'jméno
            arrAdresy(i, 1) = objAddressEntry.Name
            'adresa
            arrAdresy(i, 2) = objAddressEntry.Address

            'Microsoft Exchange
            'Set objAddressEntryDetail = objAddressEntry.GetExchangeUser

        Next objAddressEntry

        'vložení adres do listu
        wshAdresy.Cells(1).Resize(lngPocetPolozek, 2) = arrAdresy

        Application.ScreenUpdating = True

        Set objAddressList = Nothing
        Set objOutlook = Nothing

    End Sub

    Pokud jsou vaše kontakty uloženy v rámci Exchange, detail kontaktů najdete pod objektem objAddressEntryDetail (PropertyAccessor, GetProperty, schema a Microsoft Exchange Property Tags). To není můj případ a tak není jednoduché se dostat k jiným informacích, než je jméno a adresa. Uvedená procedura má i další háček. Outlook není dostatečně aktivní a ani nemotivuje uživatele v tom, aby odesílatele přidávali do svých adresářů. Takže v momentě, kdy chcete projít vaše kontakty, je v adresáři jednoduše nemáte. Proto nabízím i verzi, která vytahá e-maily z doručených zpráv.

    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    58
    59
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    'Tools / References / Microsoft Outlook xx.x Object Library

    Sub OutlookNacistAdresyZDorucenychMailu()

        Dim i As Long
        Dim lngPocetPolozek As Long

        Dim arrAdresy()

        Dim objOutlook As Object
        Dim objNameSpace As Object
        Dim objFolder As Object
        Dim objItem As Object

        Set objOutlook = New Outlook.Application
        Set objNameSpace = objOutlook.GetNamespace("MAPI")
        'olFolderInbox ... 6
        Set objFolder = objNameSpace.GetDefaultFolder(olFolderInbox)

        'počet položek v adresáři
        lngPocetPolozek = objFolder.Items.Count

        'dimenzování pole
        ReDim arrAdresy(1 To lngPocetPolozek, 1 To 1)

        For Each objItem In objFolder.Items

            'je položka typu e-mail?
            'olMail ... 43
            If objItem.Class = olMail Then
                'počítadlo
                i = i + 1
                'přidání adresy odesílatele do pole
                arrAdresy(i, 1) = objItem.SenderEmailAddress
            End If

        Next objItem

        Application.ScreenUpdating = False
       
        With wshAdresy

            'vložení adres do listu
            .Cells(1).Resize(lngPocetPolozek, 1) = arrAdresy

            'odstranění duplicit
            .Range("A:A").RemoveDuplicates Columns:=1, Header:=xlNo

        End With

        'setřídění listu A-Z
        With wshAdresy.Sort
            .SortFields.Clear
            .SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, _
                Order:=xlAscending, DataOption:=xlSortNormal
            .SetRange Range("A:A")
            .Header = xlGuess
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With

        Application.ScreenUpdating = True

        'odstranění proměnných z paměti
        Set objFolder = Nothing
        Set objNameSpace = Nothing
        Set objOutlook = Nothing

    End Sub

    Po převzetí adres je samozřejmě potřeba řešit duplicity a není na škodu si adresy abecedně seřadit. I tak vám ještě zůstane trocha ruční práce – spam, který prošel, „no reply“ adresy apod. A hodit se vám může i tip na zřetězení. Postačí prostý odkaz na oblast vzorcem, stisk F9 (dojde k nahrazení adresy oblasti za hodnoty) a zbavení se drobného balastu. Položky oddělené středníky lze rovnou aplikovat ve zprávě Outlooku. První adresu věnujte políčku Komu a ostatní umístěte do skryté kopie (tlačítko Kopie a v otevřeném dialogu políčko Skrytá). Hromadné e-maily prosím rozesílejte jen v rozumné míře…

    Zřetězení e-mailových adres pro hromadnou korespondenci
    Zřetězení e-mailových adres pro hromadnou korespondenci

    Přitvrdíme. Co si třeba projít všechny zprávy a vypsat jen takové, které obsahují v předmětu slovo „Excel“?

    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    58
    59
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    'Tools / References / Microsoft Outlook xx.x Object Library

    Sub OutlookNacistZpravyDlePredmetu()

        Dim i As Long
        Dim lngPocetPolozek As Long

        Dim arrPoleData()

        Dim objOutlook As Object
        Dim objNameSpace As Object
        Dim objFolder As Object
        Dim objItem As Object

        Set objOutlook = New Outlook.Application
        Set objNameSpace = objOutlook.GetNamespace("MAPI")
        'olFolderInbox ... 6
        Set objFolder = objNameSpace.GetDefaultFolder(olFolderInbox)

        'aktivace patřičného listu
        wshZpravy.Activate
       
        'počet položek v adresáři
        lngPocetPolozek = objFolder.Items.Count

        'dimenzování pole
        ReDim arrPoleData(1 To lngPocetPolozek, 1 To 4)

        For Each objItem In objFolder.Items

            'je položka typu e-mail
            'a obsahuje předmět slovo "Excel"?
            'olMail ... 43
            If (objItem.Class = olMail) And (objItem.Subject Like "*Excel*") Then
           
                'počítadlo
                i = i + 1
               
                'přidání informací do pole
                'čas doručení
                arrPoleData(i, 1) = objItem.ReceivedTime
               
                'jméno
                arrPoleData(i, 2) = objItem.SenderName
               
                'e-mail
                arrPoleData(i, 3) = objItem.SenderEmailAddress
               
                'předmět zprávy
                arrPoleData(i, 4) = objItem.Subject
               
                'obsah
                'arrPoleData(i, 5) = objItem.Body
               
                'kopie CC, BCC
                'arrPoleData(i, 6) = objItem.CC
               
            End If

        Next objItem
       
        'vložení informací do listu
        wshZpravy.Cells(1).Resize(lngPocetPolozek, 4) = arrPoleData

        'odstranění proměnných z paměti
        Set objFolder = Nothing
        Set objNameSpace = Nothing
        Set objOutlook = Nothing

    End Sub

    Něco praktičtějšího? Tak projdeme všechny nepřečtené zprávy, roztřídíme je a uložíme přílohy do složky podle odesílatele.

    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    58
    59
    60
    61
    62
    63
    64
    65
    66
    67
    68
    'Tools / References / Microsoft Outlook xx.x Object Library

    Private Const cstrCesta As String = "D:\Test"

    Sub OutlookUlozeniPrilohDleOdesilatele()

        Dim cstrCestaPriloha As String
       
        Dim objOutlook As Object
        Dim objNameSpace As Object
        Dim objFolderInbox As Object
        Dim objFolderDeletedItems As Object
        Dim objItem As Object

        Set objOutlook = New Outlook.Application
        Set objNameSpace = objOutlook.GetNamespace("MAPI")
        'olFolderInbox ... 6, olFolderDeletedItems ... 3
        Set objFolderInbox = objNameSpace.GetDefaultFolder(olFolderInbox)
        Set objFolderDeletedItems = _
            objNameSpace.GetDefaultFolder(olFolderDeletedItems)

        'pro každou položku v adresáři
        For Each objItem In objFolderInbox.Items

            'je zpráva doposud nepřečtená?
            If objItem.UnRead Then

                With objItem.Attachments
                   
                    'existuje příloha?
                    If .Count > 0 Then

                        'pro všechny přílohy
                        For i = 1 To .Count
                       
                            'cstrCesta ke složce odesílatele
                            cstrCestaPriloha = cstrCesta & objItem.SenderName & ""
                           
                            'vytvoření (neexistující) složky
                            On Error Resume Next
                            MkDir cstrCestaPriloha
                           
                            'uložení přílohy
                            .Item(i).SaveAsFile (cstrCestaPriloha & .Item(i).Filename)
                           
                        Next i
                       
                    End If
                   
                End With

                'nastavení atributu přečtené zprávy
                'objItem.UnRead = False

                'přesun zprávy do složky Odstraněná pošta
                'objItem.Move (objFolderDeletedItems)

                'odstranění zprávy
                'objItem.Delete

            End If

        Next objItem

        'ukončení seance
        'objOutlook.Quit

    End Sub

    Všechny dosavadní příklady fungovaly ve směru z Outlooku do Excelu. Poslední úloha bude opačná. Ze seznamu úkolů v Excelu vytvoříme úkol/událost v Outlooku. Níže uvedená procedura je jiná ještě v jedné věci. Ukazuje druhý způsob, jak se odkázat na aplikaci Outlook bez nutnosti reference (metoda CreateObject). Zatímco v předchozích ukázkách s referencemi jsme si mohli dovolit používat konstanty Outlooku a deklarovat objekty i přímo a nejen jako obecný Object, zde to možné není.

    Propojení Excel - Outlook - událost
    Propojení Excel – Outlook – událost
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    58
    Sub OutlookVytvoritUkolUdalost()

        Dim objOutlook As Object
        Dim objTaskItem As Object
        Dim objAppointmentItem As Object

        Dim intRadek As Integer

        'aktivace patřičného listu
        wshUdalosti.Activate
       
        'volba datového řádku
        intRadek = 2

        'vytvoření instance aplikace Outlook
        Set objOutlook = CreateObject("Outlook.Application")

        'úkol ... olTaskItem ... 3
        'Set objTaskItem = objOutlook.CreateItem(3)

        'With objTaskItem
        '    .Subject = Cells(intRadek, 1).Text
        '    .StartDate = Cells(intRadek, 2).Value
        '    .DueDate = Cells(intRadek, 3).Value
        '    .ReminderTime = Cells(intRadek, 4).Value
        '    .Body = Cells(intRadek, 5).Text
        '    .Save
        'End With

        'událost ... olAppointmentItem ...1
        Set objAppointmentItem = objOutlook.CreateItem(1)
       
        With objAppointmentItem
            'předmět
            .Subject = Cells(intRadek, 1).Text
            'počáteční datum
            .Start = Cells(intRadek, 2).Value
            'konečné datum
            .End = Cells(intRadek, 3).Value + 1
            'celodenní událost
            .AllDayEvent = True
            'upozornění v minutách před poč. datem
            .ReminderMinutesBeforeStart = (Cells(intRadek, 2).Value - _
                Cells(intRadek, 4).Value) * 1440
            'obsah
            .Body = Cells(intRadek, 5).Text
            'místo
            .Location = Cells(intRadek, 6).Text
            'uložení
            .Save
        End With

        'odstranění objektů z paměti
        Set objTaskItem = Nothing
        Set objAppointmentItem = Nothing
        Set objOutlook = Nothing

    End Sub
    Propojení Excel - Outlook - událost
    Propojení Excel – Outlook – událost

    Chcete-li si nastudovat objektový model Outlooku, můžete zavítat na stránky Object model (Outlook VBA reference). Pokud vás to navnadilo podívat se na Outlook blíž, pak jen dobře. Uvědomte si, že i Outlook má události a vy můžete po příchodu zprávy automaticky uložit přílohu a mail zpracovat…

    Příloha:
    excel_propojeni_outlook.zip

    Uložit článek jako PDF