How to check each draft item from all the shared inbox

[ThrottleWorks]

Hi,

Brief about macro. This macro needs to check each draft e-mail from Outlook for certain rules. The code I have written works well for conditions set.

However my problem is, the user has multiple inbox in his outlook. One is his personal inbox, others are shared inbox. Numbers of shared inbox for a user can vary. It can be 3,4,5 or 7. This number is not fixed.

How do I check draft item from each Inbox. The code I have written works only for personal Inbox. Given below.

Can anyone please help me in this.
Have a nice weekend.

Public Sub Chandoo()
    Dim strT As String
    Dim strC As String
    Dim strBC As String
    Dim strSubjec As String
    Dim strBOD As String
  
    Set MacroBook = ThisWorkbook
  
    universalFunction = False
  
    Call StartMacro
  
    AttachmentFlag = False
  
    Call setOutlookObjects

    Call onScreen
End Sub
Public Sub StartMacro()
    Application.EnableCancelKey = False
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
End Sub
Function setOutlookObjects() 'Required
    Set myOutlook = Outlook.Application
    Set myNamespace = myOutlook.GetNamespace("MAPI")
    Set myFolders = myNamespace.Folders
    Set myDraftsFolder = myNamespace.GetDefaultFolder(olFolderDrafts)
    Set myItems = myDraftsFolder.Items
    Set myItem = myItems.Find("[Categories] = ''")
  
    validationStatus = vbNullString
    validationStatus = "Chandoo"
End Function
Function onScreen()
  
    Dim osCounter As Integer
    Dim oApp As New Outlook.Application
    Dim oins As Outlook.Inspector
    Dim osStatussheetOBJ As Object
  
    Call sheetAdd
  
    Set osStatussheetOB = Nothing
    Set osStatussheetOB = ThisWorkbook.Worksheets("MySheet")
  
    osStatussheetOB.UsedRange.Offset(1, 0).ClearContents
    oncounter = 0
    universalInc = 0
  
    For Each oins In oApp.Inspectors
        UniversalStringStatus = vbNullString
        universalInc = universalInc + 1
      
        '----------------------------------------
        Dim outlookApp
        Dim olNs As Outlook.Namespace
        Dim Fldr As Outlook.MAPIFolder
        Dim olMail As Variant
        Dim myTasks
        Dim sir() As String
      
        Set outlookApp = CreateObject("Outlook.Application")
        Set olNs = outlookApp.GetNamespace("MAPI")
        Set Fldr = olNs.GetDefaultFolder(olFolderInbox)
        Set myTasks = Fldr.Items
      
        'my code, not given here
    Next
End Function
Function sheetAdd() 'Required
    ThisWorkbook.Activate
    Worksheets("MySheet").Select
    ActiveSheet.Unprotect Password:="Chandoo"
    ActiveSheet.Cells.Clear
  
    Set Status_Sht = ActiveSheet
End Function

 

[Hui]

Have a read of the first answer at:
https://stackoverflow.com/questions/9076634/get-reference-to-additional-inbox
and the link referened

 

[ThrottleWorks]

Hi @Hui sir. Thanks a lot for the help.
Will check and revert.
Apologies for late reply.
Have a nice day ahead.

 

[ThrottleWorks]

Hi sir,

I guess, the code at Stackoverflow will work if we know name of another 'Inbox'.
In my case, I will be to able know name of another 'Inbox'.

There may be n number of Inbox. Also, macro will be used by different users.
And each user can have different number and names and inbox.

How do I get name of each inbox from the outlook and pass it in the code.
Something like loop.

Could you please help if you get time.

 

[Hui]

You should be able to use a modified version of this

https://stackoverflow.com/questions...through-every-folder-and-subfolder-in-outlook

 

[ThrottleWorks]

Thanks a lot @Hui sir. I am checking this and will revert with details.
Have a nice day ahead.