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.

'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.

'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“?

'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.

'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

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

Klikni a stahuj!