Copy Flagged Email list from Outlook to Excel with VBA

[etgreer]

I would like to use my flagged email list to build a to-do list in excel. I need an excel macro that can:
1. Go into outlook (not sure how to tell it to reach from excel to outlook)
2. Find the messages in Outlook that are flagged
3. Copy the subject line, and date that I have set to follow-up, into excel.

I appreciate any help!

 

[Worf]

Hello

Sub Flagged()
Dim oout As Object, ns As Namespace, fld As Folder, item As MailItem, r%
Set oout = CreateObject("Outlook.Application")
Set ns = oout.GetNamespace("MAPI")
On Error Resume Next
Set fld = ns.GetDefaultFolder(olFolderInbox)    ' desired folder
If Err.Number <> 0 Then
    Err.Clear
    MsgBox "No such folder."
    Exit Sub
End If
On Error GoTo 0
r = 2
For Each item In fld.Items
    If item.FlagStatus = olFlagMarked Then
        Cells(r, 1) = item.Subject
        Cells(r, 2) = item.ReminderTime
        Cells(r, 3) = item.TaskDueDate
        r = r + 1
    End If
Next
End Sub

 

[etgreer]

Thanks for the response. I'm getting a "User-defined type not defined" error when trying to define NS as Namespace. Do you know what this could be?

 

[Worf]

Set the following reference at the Visual Basic Editor:

Tools>References>Microsoft Outlook xx.x Object Library.

 

[etgreer]

Making progress! Now I'm getting a Run-time error '13': Type mismatch over "Next", at the very end of the code. I also changed it to "Next item" but I get the same error. Thoughts?

Sub Email()
Dim oout As Object, ns As Namespace, fld As Folder, item As MailItem, r%
Set oout = CreateObject("Outlook.Application")
Set ns = oout.GetNamespace("MAPI")
On Error Resume Next
Set fld = ns.GetDefaultFolder(olFolderInbox) ' desired folder
If Err.Number <> 0 Then
Err.Clear
MsgBox "No such folder."
Exit Sub
End If
On Error GoTo 0
r = 2
For Each item In fld.Items
If item.FlagStatus = olFlagMarked Then
Cells(r, 1) = item.Subject
Cells(r, 2) = item.ReminderTime
Cells(r, 3) = item.TaskDueDate
r = r + 1
End If
Next item
End Sub

 

[Worf]

New version:

' Excel module
Sub Email()
Dim oout As Object, ns As Namespace, fld As folder, item As MailItem, r%, fs
fs = 0                                                  ' testing
'fs = olFlagMarked                                      ' use this one
Set oout = CreateObject("Outlook.Application")
Set ns = oout.GetNamespace("MAPI")
On Error Resume Next
Set fld = ns.GetDefaultFolder(olFolderInbox)            ' desired folder
If Err.Number <> 0 Then
    Err.Clear
    MsgBox "No such folder."
    Exit Sub
End If
On Error GoTo 0
r = 2
For Each item In fld.Items
    If TypeName(item) = "MailItem" Then
        If item.FlagStatus = fs Then
            Cells(r, 1) = item.Subject
            Cells(r, 2) = item.ReminderTime
            Cells(r, 3) = item.TaskDueDate
            Cells(r, 4) = item.TaskStartDate
            Cells(r, 5) = item.FlagRequest
            Cells(r, 6) = item.FlagIcon
            r = r + 1
        End If
    End If
Next
End Sub

 

[syamvg]

Hi, Thank you for your supper effort.
Please note this macro giving error while meets calendar or auto response items in inbox. Can you please extend the code by adding exclusion clase for these

 

[Worf]

Hi

Sub Email()
Dim oout As Object, ns As Namespace, fld As Folder, item As Object, r%, fs
fs = 0                                                  ' testing
'fs = olFlagMarked                                      ' use this one
Set oout = CreateObject("Outlook.Application")
Set ns = oout.GetNamespace("MAPI")
On Error Resume Next
Set fld = ns.GetDefaultFolder(olFolderDeletedItems) ' desired folder
If Err.Number <> 0 Then
    Err.Clear
    MsgBox "No such folder."
    Exit Sub
End If
On Error GoTo 0
r = 2
MsgBox fld.Items.Count, , "Total items"
For Each item In fld.Items
    If TypeName(item) = "MailItem" Then
        If item.FlagStatus = fs Then
            Cells(r, 1) = item.Subject
            Cells(r, 2) = item.ReminderTime
            Cells(r, 3) = item.TaskDueDate
            Cells(r, 4) = item.TaskStartDate
            Cells(r, 5) = item.FlagRequest
            Cells(r, 6) = item.FlagIcon
            r = r + 1
        End If
    End If
Next
End Sub

 

[syamvg]

Hi,
Its worked... Appreciated Thank you...??