Excel VBA - E-mailek lekérdezése macróval

Excel VBA - E-mailek lekérdezése macróval
2020-07-13T13:09:54+02:00
2020-07-13T13:09:57+02:00
2022-10-15T21:26:22+02:00
Dobai Dávid
Sziasztok!

A segítségetekre lenne szükségem a következőben:

Adott egy macro, aminek az lenne a feladata, hogy egy a felhasználó által kiválasztott mappát az outlookból lekérdezzen, és az összes benne található E-Mail kilistázza.

A macro jelenlegi állapotában hibátlanul lefut, azonban amennyiben az office 365 által automatikusan küldött, kézbesíthetetlenségi maillel találkozik, akkor az email szövege helyett mindenféle karaktert dob ki. (Szöveg dekódolási hiba?)

Lentebb látjátok a kódot, tudtok javaslatot adni, merre keressem a problémát?

A macrót pont a automatikus e-mailek csoportos kezelése miatt hoztam létre.

Sub List_Email_Info()

Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim i As Long ' Row tracker
Dim arrHeader As MailItem
Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namespace
 
Dim Folder As MAPIFolder
Dim olItems As Items
Dim olMailItem As Variant
 
 
 
arrHeader = Array("Date Created", "Subject", "Sender's Name", "Unread", "Body")
 
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set xlWB = xlApp.Workbooks.Add
 
Set OutlookApp = New Outlook.Application
Set OutlookNamespace = GetNamespace("MAPI")
Set olItems = OutlookNamespace.PickFolder.Items
 
i = 1
 
On Error Resume Next
 
xlWB.Worksheets(1).Range("A1").Resize(1, UBound(arrHeader) + 1).Value = arrHeader
 
For Each olMailItem In olItems
    
    xlWB.Worksheets(1).Cells(i + 1, "A").Value = olItems(i).CreationTime
    xlWB.Worksheets(1).Cells(i + 1, "B").Value = olItems(i).Subject
    xlWB.Worksheets(1).Cells(i + 1, "C").Value = olItems(i).SenderName
    xlWB.Worksheets(1).Cells(i + 1, "D").Value = olItems(i).UnRead
    xlWB.Worksheets(1).Cells(i + 1, "E").Value = olItems(i).Body
    
    
    i = i + 1
    
Next olMailItem
 
xlWB.Worksheets(1).Cells.EntireColumn.AutoFit
 
 
 
Set xlWB = Nothing
Set xlApp = Nothing
 
Set olItems = Nothing
Set olInboxFolder = Nothing
Set olNS = Nothing
 
End Sub

Segítségeteket előre is köszönöm!

Dávid.
Mutasd a teljes hozzászólást!

Tetszett amit olvastál? Szeretnél a jövőben is értesülni a hasonló érdekességekről?
abcd