Citire si forwardare email din Outlook Exchange cu aplicatie Excel

[csaba1960]

Buna
Pentru un partener dezvolt o aplicatie care cu un cod VBA din Excel va citi din Outlook emailurile dintr-un account, in functie de subject le va prelucra dupa care cu subject modificat le va forwarda la un set de adrese.
Programul realizat pot sa-l testez cu Outlook clasic pe desktop.
Intrebarea mea este va functiona si cu Outlook pe serverul Exchange ce are clientul. Nu sunt sigur ca setul de instructiuni la amandoua sunt identice.

Pun alaturi o secventa de cod, care descarca de pe un acccount emailurile care contin un cuvant cheie si le pune intr-un tabel dintr-un sheet cu body-ul trunchiat la un numar de caractere. Dupa care le forwardeaza la o alta adresa de email si emailuri prelucrate la muta intr-un alt folder.

Cod: Selectaţi tot

Sub forwardEM()
Dim selectAcc As String, textCautat As String, luNg As Integer, folderTrs As Object
Dim i As Long, ii As Long
Dim MsgFwd As Object, Recip As Object, eMail As String
Application.EnableEvents = False: Application.ScreenUpdating = False
Set olApp = CreateObject("Outlook.Application")

selectAcc = d.Cells(1, 2): textCautat = d.Cells(2, 2): luNg = d.Cells(3, 2): ii = o: eMail = d.Cells(6, 2):
i = t.Cells(t.Rows.Count, 2).End(xlUp).Row + 1
Set nameSp = olApp.GetNamespace("MAPI")

For Each oAccount In olApp.Session.Accounts
    For Each folDr In nameSp.Folders
        If folDr = selectAcc Then
        Set inBx = folDr.Folders("Inbox"):
        Set folderTrs = inBx.Folders("prelucr")
            For Each iTem In inBx.Items
                If InStr(1, iTem.Subject, textCautat) > 0 Then
                    If oAccount = selectAcc Then
                    t.Cells(i, 1) = i - 1
                    t.Cells(i, 2) = oAccount: t.Cells(i, 3) = iTem.ReceivedTime: t.Cells(i, 4) = iTem.SenderEmailAddress:
                    t.Cells(i, 5) = iTem.SenderName: t.Cells(i, 6) = iTem.Subject: t.Cells(i, 7) = Mid(iTem.boDy, 1, luNg):
                    Set MsgFwd = iTem.Forward
                    Set Recip = MsgFwd.Recipients.Add(eMail): Recip.Type = 1: MsgFwd.send
                            If d.Cells(5, 2) = "DA" Then iTem.Move folderTrs
                     i = i + 1: ii = ii + 1
                    End If
                End If
            Next
            Exit For
        End If
    Next
Next
    If ii = 0 Then
    MsgBox "Nu s-au gasit emailuri conform cu cheia de cautare!", vbInformation, "Descarcare email"
    Else: MsgBox "S-au gasit " & ii & " emailuri conform cu cheia de cautare.", vbInformation, "Descarcare email"
    End If

Set inBx = Nothing: Set nameSp = Nothing
Application.EnableEvents = True: Application.ScreenUpdating = True
End Sub

Cam acestea sunt instructiuniile legate de Outlook pe care o sa le folosesc, ce credeti o sa fct si in versiunea Exchange?

[csaba1960]

Se pare ca setul de instructiuni la Outlook clasic si Outlook de pe server Exchange este identic, cel putin cele folosite de mine in aplicatia creata.