Microsoft Office Forums

Go Back   Microsoft Office Forums > >

Reply
 
Thread Tools Display Modes
  #1  
Old 11-16-2023, 03:33 PM
derek_123 derek_123 is offline VBA to look into shared mailbox Windows 10 VBA to look into shared mailbox Office 2016
Novice
VBA to look into shared mailbox
 
Join Date: Nov 2023
Posts: 2
derek_123 is on a distinguished road
Default 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
Reply With Quote
Reply

Thread Tools
Display Modes


Similar Threads
Thread Thread Starter Forum Replies Last Post
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
shared mailbox rules monkey Outlook 0 03-17-2012 08:57 PM
Using Shared Mailbox hari.ganeshan Outlook 0 04-26-2010 01:36 AM

Other Forums: Access Forums

All times are GMT -7. The time now is 05:35 PM.


Powered by vBulletin® Version 3.8.11
Copyright ©2000 - 2024, vBulletin Solutions Inc.
Search Engine Optimisation provided by DragonByte SEO (Lite) - vBulletin Mods & Addons Copyright © 2024 DragonByte Technologies Ltd.
MSOfficeForums.com is not affiliated with Microsoft