Link to home
Start Free TrialLog in
Avatar of bsharath
bsharathFlag for India

asked on

Outlook emails that are sent. Need to get data from subject and to whome i emailed.

Hi,

Outlook emails that are sent. Need to get data from subject and to whome i emailed.
I have emails send to 1000's of users. With the below line in the body of the emails.
"This Application is not allowed in the development environment"

i want a macro that i select a folder and run. When run has to check for this body line and get the To user i emailed and the date and the subject data to an excel.
It should be only new emails and not reply or forwarded emails.

regards
sharath
Avatar of Chris Bottomley
Chris Bottomley
Flag of United Kingdom of Great Britain and Northern Ireland image

Whilst I can imagine a way to detect a new mailitem as compared to a reply/forward the method would be fiddly to implement though robust in it's method..

A second best method could simply check for the RE: or FWD: prefix in the subject line ... if that's what you see (and leave intact).

If this latter method would be acceptable can you confirm exactly which prefixes you have for forward/reply?

Chris
Avatar of bsharath

ASKER

Yes thats fine Chris
RE:\FW: are the subject starts
How about:

Note filename appears twice.

Chris
Sub Q_26483653()
Dim mai As Object
Dim xlApp As Object
Dim wb As Object
Dim rw As Long
Const xlup As Integer = -4162

    Set xlApp = CreateObject("excel.application")
    On Error Resume Next
    Set wb = xlApp.workbooks.Open("C:\deleteme\Q_26483653.xlsx")
    On Error GoTo 0
    If wb Is Nothing Then
        Set wb = xlApp.workbooks.Add
        wb.sheets(1).Range("A1") = "Mail Sent Date"
        wb.sheets(1).Range("B1") = "Mail Sent To"
        wb.sheets(1).Range("C1") = "MAil Subject"
        wb.saveas "C:\deleteme\Q_26483653.xlsx"
    End If
    For Each mai In Application.Session.PickFolder.items
        If mai.Class = olMail Then
            If InStr(mai.Subject, "FW:") <> 1 And InStr(mai.Subject, "RE:") <> 1 Then
                If InStr(LCase(mai.body), LCase("This Application is not allowed in the development environment")) > 0 Then
                    rw = wb.sheets(1).Range("A" & wb.sheets(1).Rows.count).End(xlup).Row + 1
                    wb.sheets(1).Range("A" & rw) = mai.senton
                    wb.sheets(1).Range("B" & rw) = mai.Recipients(1)
                    wb.sheets(1).Range("C" & rw) = mai.Subject
                End If
            End If
        End If
    Next
    wb.Close True
    xlApp.Quit


End Sub

Open in new window

Works fine Chris
but i get to people who are in CC as well.
I want emails sent to and people in TO only
The following should only pick names from the to field ... if that is the requirement

Chris
Sub Q_26483653()
Dim mai As Object
Dim xlApp As Object
Dim wb As Object
Dim rw As Long
Dim recip As Recipient
Const xlup As Integer = -4162

    Set xlApp = CreateObject("excel.application")
    On Error Resume Next
    Set wb = xlApp.workbooks.Open("C:\deleteme\Q_26483653.xlsx")
    On Error GoTo 0
    If wb Is Nothing Then
        Set wb = xlApp.workbooks.Add
        wb.sheets(1).Range("A1") = "Mail Sent Date"
        wb.sheets(1).Range("B1") = "Mail Sent To"
        wb.sheets(1).Range("C1") = "MAil Subject"
        wb.saveas "C:\deleteme\Q_26483653.xlsx"
    End If
    For Each mai In Application.Session.PickFolder.items
        If mai.To <> "" Then
            If mai.Class = olMail Then
                If InStr(mai.Subject, "FW:") <> 1 And InStr(mai.Subject, "RE:") <> 1 Then
                    If InStr(LCase(mai.body), LCase("This Application is not allowed in the development environment")) > 0 Then
                        rw = wb.sheets(1).Range("A" & wb.sheets(1).Rows.count).End(xlup).Row + 1
                        wb.sheets(1).Range("A" & rw) = mai.senton
                        For Each recip In mai.Recipients
                            If recip.Type = olTo Then
                                wb.sheets(1).Range("B" & rw) = recip
                                Exit For
                            End If
                        Next
                        wb.sheets(1).Range("C" & rw) = mai.Subject
                    End If
                End If
            End If
        End If
    Next
    wb.Close True
    xlApp.Quit


End Sub

Open in new window

I get object does not support.
When debug goes here
        If mai.To <> "" Then
ASKER CERTIFIED SOLUTION
Avatar of Chris Bottomley
Chris Bottomley
Flag of United Kingdom of Great Britain and Northern Ireland image

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
Thanks a lot Chris works perfect
:-)