VBA: konverzní sešit Excel pro Outlook kontakty

[d1amond]

Zdravím,
nevěděl by mi někdo naťuknout konverzní sešit v Excel na import kontaktů do Outlook? Neznám objektové knihovny Outlook, proto se ptám. Stačilo by i nastínit např. jméno, email a skupinu, zbytek už bych si dodělal. Problém možná bude s verzemi, takže bych to potřeboval už od 2003. Předem díky, pokud se někdo najde

[Reklama]

[Uziv00]

Jestli jde o to, vybrat z určeného sešitu a listu e-mailové adresy a importovat je do adresního řádku outlooku pro odeslání zprávy všem najednou, tak to umím pomocí vbs.

[d1amond]

Jde o to, dostat je do adresáře.

[Uziv00]

Mrknu, jestli by to šlo. Předpokládám jméno, příjmení, funkce, a jedna buňka s názvem skupiny.Outlook jako objekt ve vbs existuje, ale musím zjistit, jestli se dá dostat do adresáře. Ale nebude to hned :(

[Uziv00]

Upravuji...Určitě to umí FullName a email.address, takže funkce nebude...

[d1amond]

Díky i za ten čas...

[Uziv00]

Ahoj,
takže něco jsem stvořil i to funguje. Nevím ale jestli podle tvých představ.
Je třeba mít xls soubor s kontakty kde musí být něco v buňce A (skript ji testuje na prázdnost), dále v buňce B plné jméno a v buňce C e-mailová adresa.
Skript po spuštění nahraje položky do kontaktů outlooku. Předpokládá se profil Outlook, pokud máš jiný, je třeba to ve skriptu uvést. první řádek tabulky je ignorován.

Kód: Vybrat vše

Const olFolderContacts = 10
Const olContactItem = 2
Dim excApp, excWkb, excWks, olkApp, olkSes, olkFld, olkCon, lngRow
Set olkApp = CreateObject("Outlook.Application")
Set olkSes = olkApp.GetNamespace("MAPI")
'Zde změňte jméno profilu jak potřebujete
olkSes.Logon "Outlook"
Set olkFld = olkSes.GetDefaultFolder(olFolderContacts)
Set excApp = CreateObject("Excel.Application")
'Zde zadejte jméno souboru včetně cesty
Set excWkb = excApp.Workbooks.Open("C:\eeTesting\kontakty.xls")
For Each excWks In excWkb.Sheets
    lngRow = 2
    Do Until excWks.Cells(lngRow, "A") = ""
        Set olkCon = olkFld.Items.Find("[FullName] = '" & excWks.Cells(lngRow, 2) & "'")
        If TypeName(olkCon) = "Nothing" Then
            Set olkCon = olkApp.CreateItem(olContactItem)
            With olkCon
                .FullName = excWks.Cells(lngRow, "B")
                .Email1Address = excWks.Cells(lngRow, "C")
                .Save
            End With
        End If
        lngRow = lngRow + 1
    Loop
Next
Set olkCon = Nothing
Set olkFld = Nothing
olkSes.Logoff
Set olkSes = Nothing
Set olkApp = Nothing
Set excWks = Nothing
excWkb.Close False
Set excWkb = Nothing
excApp.Quit
Set excApp = Nothing
msgbox "Import kompletní", vbInformation + vbOKOnly, "Import Contacts"


Jo, ještě dodatek - zkopírovat do notepadu, uložit s příponou .vbs.