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