How to work on each item from draft folder of Outlook

[ThrottleWorks]

Hi,

I am trying to edit below mentioned code.
Brief about below code.

This code will check each item which is open.
Open here means, user has manually clicked on e-mail for 'Reply' 'Reply to All' or 'Forward'.

Code will check all such open items from Outlook.
However, I want to edit this code for each item in 'Draft' folder.
Items in draft folder will not be open in Outlook but these will be saved in Draft.

I believe ' For Each oins In oApp.Inspectors' this line in below code takes each open item.
However I am not able to edit below code for each item in Draft folder.

How can change the line from For Each oins In oApp.Inspectors to For each item in Draft folder.

Can anyone please help me in this.
Apologies for not uploading sample workbook. Thanks for your time.

Cross posted at
https://www.mrexcel.com/forum/excel...ch-item-draft-folder-outlook.html#post5029875

Help only if you get time.

Function onScreen()
    Dim osCounter As Integer
    Dim oApp As New Outlook.Application
    Dim oins As Outlook.Inspector
    Dim osStatussheetOBJ As Object

    Set osStatussheetOB = Nothing
    Set osStatussheetOB = ThisWorkbook.Worksheets("My Sheet")

    osStatussheetOB.UsedRange.Offset(1, 0).ClearContents
    oncounter = 0
    universalInc = 0

    For Each oins In oApp.Inspectors
        UniversalStringStatus = vbNullString
        universalInc = universalInc + 1

        '+Getting latest From, To and CC from draft
        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

        Dim SLine As Long
        Dim ELine As Long

        If (InStr(1, oins.CurrentItem.Body, "From: ", vbTextCompare) > 0) Then
            SLine = InStr(1, oins.CurrentItem.Body, "From: ", vbTextCompare)
        End If

        If (InStr(1, oins.CurrentItem.Body, "Subject: ", vbTextCompare) > 0) Then
            ELine = InStr(1, oins.CurrentItem.Body, "Subject: ", vbTextCompare)
        End If

        If SLine = 0 Then GoTo SkipThisEmail

        CheckAddSht.Range("A1").Value = Mid(oins.CurrentItem.Body, SLine, ELine - SLine)
        SLine = 0
        ELine = 0

        CheckAddSht.Select

        oins.CurrentItem.Display
        oins.CurrentItem.Save

        osCounter = osCounter + 1

        'Serial number of draft
        osStatussheetOB.Range("A" & osStatussheetOB.Range("A" & Application.Rows.Count).End(xlUp).Row + 1).Value = _
        osCounter

        'User name
        osStatussheetOB.Range("B" & osStatussheetOB.Range("A" & Application.Rows.Count).End(xlUp).Row).Value = _
        Application.UserName

        'C To
        osStatussheetOB.Range("C" & osStatussheetOB.Range("A" & Application.Rows.Count).End(xlUp).Row).Value = _
        oins.CurrentItem.To

        'D CC
        osStatussheetOB.Range("D" & osStatussheetOB.Range("A" & Application.Rows.Count).End(xlUp).Row).Value = _
        oins.CurrentItem.CC

        'E BCCC
        osStatussheetOB.Range("E" & osStatussheetOB.Range("A" & Application.Rows.Count).End(xlUp).Row).Value = _
        oins.CurrentItem.BCC

        'F Subject
        osStatussheetOB.Range("F" & osStatussheetOB.Range("A" & Application.Rows.Count).End(xlUp).Row).Value = _
        oins.CurrentItem.Subject

        'Format I column for time and date
        osStatussheetOB.Range("I" & osStatussheetOB.Range("A" & Application.Rows.Count).End(xlUp).Row).NumberFormat = _
        "mm/dd/yyyy hh:mm:ss AM/PM"

        'Will populate NOW in I Column
        osStatussheetOB.Range("I" & osStatussheetOB.Range("A" & Application.Rows.Count).End(xlUp).Row).Value = _
        Format(Now, "mm/dd/yyyy hh:mm:ss AM/PM")

        osStatussheetOB.Activate
        osStatussheetOB.Columns.AutoFit
        osStatussheetOB.Rows.AutoFit
        strMessage = vbNullString
SkipThisEmail:
    Next
End Function

 

[ThrottleWorks]

At present I am using below two modules as work around.

These module open and close all the items from drafts.

Sub Display_All_Drafts()

    Dim lDraftItem As Long
    Dim myOutlook As Outlook.Application
    Dim myNameSpace As Outlook.Namespace
    Dim myFolders As Outlook.Folders
    Dim myDraftsFolder As Outlook.MAPIFolder
   
    Set myOutlook = Outlook.Application
    Set myNameSpace = myOutlook.GetNamespace("MAPI")
    Set myFolders = myNameSpace.Folders
   
    Dim MacroSht As Worksheet
    Set MacroSht = Worksheets("Main")
       
    Set myDraftsFolder = myFolders(MacroSht.Range("S30").Value).Folders("Drafts")
   
    For lDraftItem = myDraftsFolder.Items.Count To 1 Step -1
        myDraftsFolder.Items.Item(lDraftItem).Display
    Next lDraftItem
   
    'Clean-up
    Set myDraftsFolder = Nothing
    Set myNameSpace = Nothing
    Set myOutlook = Nothing
End Sub

Sub Close_All_Drafts()
    Dim lDraftItem As Long
    Dim myOutlook As Outlook.Application
    Dim myNameSpace As Outlook.Namespace
    Dim myFolders As Outlook.Folders
    Dim myDraftsFolder As Outlook.MAPIFolder
   
    Set myOutlook = Outlook.Application
    Set myNameSpace = myOutlook.GetNamespace("MAPI")
    Set myFolders = myNameSpace.Folders
   
    Dim MacroSht As Worksheet
    Set MacroSht = Worksheets("Main")
       
    Set myDraftsFolder = myFolders(MacroSht.Range("S30").Value).Folders("Drafts")
   
    For lDraftItem = myDraftsFolder.Items.Count To 1 Step -1
        myDraftsFolder.Items.Item(lDraftItem).Close olSave
    Next lDraftItem
   
    'Clean-up
    Set myDraftsFolder = Nothing
    Set myNameSpace = Nothing
    Set myOutlook = Nothing
End Sub