#1
|
|||
|
|||
VBA to look into shared mailbox
Hi There,
I am using the below outlook vba code to look into Shared mailbox emails and copy data from email body to excel . The code works fine if I am using personal mailbox but it gives Runtime error "The attempted operation failed. An object could not be found" if I use the shared mailbox in the highlighted line. Can anyone please let me know what changes need to be made to make it work for shared mailbox . Code:
Public Sub Extract() On Error Resume Next Set myOlApp = Outlook.Application Set mynamespace = myOlApp.GetNamespace("mapi") Dim strRowData As String Dim strDelimiter As String Dim myDestFolder As Outlook.Folder Dim olRecip As Outlook.Recipient Dim ShareInbox As Outlook.MAPIFolder Dim SubFolder As Object Dim j As Integer Dim m As String Dim InputF As String Dim OutputP As String Dim ProdMail As String Dim oXLApp As Object, oXLwb As Object, oXLws As Object Dim lRow As Long On Error Resume Next Set oXLApp = GetObject(, "Excel.Application") '~~> If not found then create new instance If Err.Number <> 0 Then Set oXLApp = CreateObject("Excel.Application") End If Err.Clear On Error GoTo 0 '~~> Open the relevant file Set oXLwb = oXLApp.Workbooks.Open("C:\ETest.xlsx") 'Extract Mailbox and subfolder details from a sheet named as "Folder Details" Set oXLws = oXLwb.Sheets("Folder Details") ProdMail = oXLws.Range("B1") InputFolder = oXLws.Range("B2") OutputFolder = oXLws.Range("B3") strRowData = "" ' Code to extract emails from specific subfolder within shared folder and copy the data across excel spreadsheet. Set olRecip = mynamespace.CreateRecipient(ProdMail) Set ShareInbox = mynamespace.GetSharedDefaultFolder(olRecip, olFolderInbox) ' Look into Inbox emails Set SubFolder = ShareInbox.Folders(InputFolder) 'Change this line to specify folder Set myDestFolder = ShareInbox.Folders(OutputFolder) If ShareInbox.Folders(InputFolder) = 0 Then MsgBox "New Apps folder doesn't exist" Exit Sub End If If ShareInbox.Folders(OutputFolder) = 0 Then MsgBox "Completed Apps folder doesn't exist" Exit Sub End If Set oXLws = oXLwb.Sheets("Output") oXLwb.worksheets("Output").Cells.Clear lRow = 2 oXLws.Range("A1").Value = "Name" oXLws.Range("B1").Value = "ID" oXLws.Range("C1").Value = "Address" oXLws.Range("D1").Value = "Phone Number" If SubFolder.Items.Count = 0 Then MsgBox "There are no emails in the " & InputFolder & " folder", , "No Emails" Exit Sub End If For I = 1 To SubFolder.Items.Count messageArray = "" strRowData = "" Set myitem = SubFolder.Items(1) msgtext = Trim(myitem.Body) 'search for specific text delimtedMessage = Replace(Trim(msgtext), "A1", "###") delimtedMessage = Replace(Trim(delimtedMessage), "B1", "###") delimtedMessage = Replace(Trim(delimtedMessage), "C1", "###") delimtedMessage = Replace(delimtedMessage, "D1", "###") messageArray = Split(delimtedMessage, "###") With oXLws .Range("A" & lRow).Value = messageArray(1) .Range("B" & lRow).Value = messageArray(2) .Range("C" & lRow).Value = messageArray(3) .Range("D" & lRow).Value = messageArray(4) End With lRow = lRow + 1 myitem.Move myDestFolder Next I oXLwb.Save oXLwb.Close (True) MsgBox "The Macro ran successfully." End Sub |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
VBA to look into shared mailbox | derek_123 | Outlook | 0 | 11-16-2023 03:33 PM |
MS Outlook shared mailbox | Eyalt365 | Outlook | 0 | 12-29-2020 11:27 AM |
Cannot see inbox in shared mailbox | Sarengo | Outlook | 0 | 06-27-2013 09:59 AM |
Moving emails in shared mailbox to personal mailbox | hlock | Outlook | 0 | 12-12-2012 02:32 PM |
Using Shared Mailbox | hari.ganeshan | Outlook | 0 | 04-26-2010 01:36 AM |