Export From Shared Mailbox

[nico_ut]

Hi all,

Hoping someone can help.

I need to export a bunch of email from a subfolder(called NP) in a shared Mailbox (called SF). My initial research has confirmed there's no way to do it directly from outlook and ive found a cople VBA scripts which I havent been able to get to work for me unfortunately.

I was hoping someone would be able to assist me with a script I could use for this task please.

Any help will be much appreciated.

Thanks,
Nico

 

[rakesh seebaruth]

Sub GetEmails()
'Add Tools->References->"Microsoft Outlook nn.n Object Library"
'nn.n varies as per our Outlook Installation
Const NUM_DAYS As Long = 18
Dim OutlookApp As Outlook.Application
Dim i As Long
Dim Folder As Outlook.MAPIFolder
Dim itm As Object
Dim iRow As Long, oRow As Long, ws As Worksheet, sBody As String
Dim mailboxName As String, inboxName As String, subfolderName As String, diff As Double

mailboxName = "SF"
inboxName = "Inbox"
subfolderName = "NP"

'for example
Set OutlookApp = New Outlook.Application
On Error Resume Next
Set Folder = OutlookApp.Session.Folders(mailboxName) _
.Folders(inboxName).Folders(subfolderName)
On Error GoTo 0

If Folder Is Nothing Then
MsgBox "Source folder Not found!", vbExclamation, _
"Problem With export"
Exit Sub
End If

Set ws = ThisWorkbook.Worksheets(1)
ws.Cells.ClearContents

'add headers
ws.Range("A1").Resize(1, 4).Value = Array("Sender", "Subject", "Date", "Body")
iRow = 2
Folder.Items.Sort "Received"

For Each itm In Folder.Items
If TypeOf itm Is Outlook.MailItem Then
'check it's a mail item (not appointment, etc)
diff = -999
'reset time difference
On Error Resume Next
'ignore error if Receivedtime not available
diff = Date - itm.ReceivedTime
'try to calculate interval
On Error GoTo 0
'stop ignoring errors
If diff <> -999 Then
'could read Receivedtime
If diff <= NUM_DAYS Then
sBody = Left(Trim(itm.Body), 150)
'first 150 chars of Body
sBody = Replace(sBody, vbCrLf, "; ")
'remove newlines
sBody = Replace(sBody, vbLf, "; ")
ws.Cells(iRow, 1).Resize(1, 4).Value = _
Array(itm.SenderName, itm.Subject, itm.ReceivedTime, sBody)
iRow = iRow + 1
End If
Else
Debug.Print 't read ReceivedTime" & vbLf & _
itm.SenderName & ":" & itm.Subject
End If
End If
Next itm

MsgBox "Outlook Mails Extracted To Excel"
End Sub.

[CODE=vba]Sub GetEmails()
    'Add Tools->References->"Microsoft Outlook nn.n Object Library"
    'nn.n varies    as per our Outlook Installation
    Const NUM_DAYS  As Long = 18
    Dim OutlookApp  As Outlook.Application
    Dim i           As Long
    Dim Folder      As Outlook.MAPIFolder
    Dim itm         As Object
    Dim iRow        As Long, oRow As Long, ws As Worksheet, sBody As String
    Dim mailboxName As String, inboxName As String, subfolderName As String, diff As Double
    
    mailboxName = "SF"
    inboxName = "Inbox"
    subfolderName = "NP"
    
    'for example
    Set OutlookApp = New Outlook.Application
    On Error Resume Next
    Set Folder = OutlookApp.Session.Folders(mailboxName) _
        .Folders(inboxName).Folders(subfolderName)
    On Error GoTo 0
    
    If Folder Is Nothing Then
        MsgBox "Source folder Not found!", vbExclamation, _
               "Problem With export"
        Exit Sub
    End If
    
    Set ws = ThisWorkbook.Worksheets(1)
    ws.Cells.ClearContents
    
    'add headers
    ws.Range("A1").Resize(1, 4).Value = Array("Sender", "Subject", "Date", "Body")
    iRow = 2
    Folder.Items.Sort "Received"
    
    For Each itm In Folder.Items
        If TypeOf itm Is Outlook.MailItem Then
            'check it's a mail item (not appointment, etc)
            diff = -999
            'reset time difference
            On Error Resume Next
            'ignore error if Receivedtime not available
            diff = Date - itm.ReceivedTime
            'try to calculate interval
            On Error GoTo 0
            'stop ignoring errors
            If diff <> -999 Then
                'could read Receivedtime
                If diff <= NUM_DAYS Then
                    sBody = Left(Trim(itm.Body), 150)
                    'first 150 chars of Body
                    sBody = Replace(sBody, vbCrLf, "; ")
                    'remove newlines
                    sBody = Replace(sBody, vbLf, "; ")
                    ws.Cells(iRow, 1).Resize(1, 4).Value = _
                                   Array(itm.SenderName, itm.Subject, itm.ReceivedTime, sBody)
                    iRow = iRow + 1
                End If
            Else
                Debug.Print        't read ReceivedTime" & vbLf & _
                            itm.SenderName & ":" & itm.Subject
            End If
        End If
    Next itm
    
    MsgBox "Outlook Mails Extracted To Excel"
End Sub.

[/CODE]