?
Solved

Outlook code to extract mails data to an excel. Need an addition.

Posted on 2009-02-24
24
Medium Priority
?
315 Views
Last Modified: 2012-05-06
Hi,

Outlook code to extract mails data to an excel. Need an addition.
This script creates sheets and names it day/month & year.
Can i get the date also. So while running the script where there are mails that are more than 1 week get an error.
And Skip and non mail item .
Regards
Sharath
Option Explicit
 
Sub Sophos_mails_To_Excel()
    Dim olkMessage As Outlook.MailItem, _
        arrLines As Variant, _
        varLine As Variant, _
        arrLine As Variant, _
        strUser As String, _
        strScan As String, _
        strMachine As String, _
        strFiles As String, _
        excApp As Object, _
        excBook As Object, _
        excSheet As Object
    Set excApp = CreateObject("Excel.application")
    Set excBook = excApp.Workbooks.Open("D:\AV.xls")
 
 
    For Each olkMessage In Application.ActiveExplorer.Selection
        strUser = ""
        strScan = ""
        strMachine = ""
        strFiles = ""
        arrLines = Split(olkMessage.Body, vbCrLf)
        For Each varLine In arrLines
            If varLine <> "" Then
                arrLine = Split(varLine, ":")
                Select Case LCase(arrLine(0))
                Case "user"
                    strUser = AllTrim(arrLine(1))
                Case "scan"
                    strScan = AllTrim(arrLine(1))
                Case "machine"
                    strMachine = AllTrim(arrLine(1))
                Case Else
                    If Left(LCase(Trim(varLine)), 4) = "file" Then
                        strFiles = strFiles & Trim(varLine) & vbLf
                    End If
                End Select
            End If
        Next
        If Right(strFiles, 1) = vbLf Then
            strFiles = Left(strFiles, Len(strFiles) - 1)
        End If
 
        Set excSheet = Nothing
 
        On Error Resume Next
        Set excSheet = excBook.Sheets(Format(olkMessage.ReceivedTime, "ddd mmm yyyy"))
        On Error GoTo 0
        If excSheet Is Nothing Then
            Set excSheet = excBook.Sheets.Add
            excSheet.Name = Format(olkMessage.ReceivedTime, "ddd mmm yyyy")
        End If
 
 
 
        With excSheet
            .Range("A1:D1") = Array("User", "Scan", "Machine Name", "Error")
            .Rows(2).Insert
            .Cells(2, 1) = strUser
            .Cells(2, 2) = strScan
            .Cells(2, 3) = strMachine
            .Cells(2, 4) = strFiles
        End With
        olkMessage.UnRead = False
        olkMessage.Save
    Next
    excBook.Save
 
    Set excSheet = Nothing
    Set excBook = Nothing
    excApp.Quit
    Set excApp = Nothing
    Set olkMessage = Nothing
    MsgBox "Done"
End Sub

Open in new window

0
Comment
Question by:bsharath
  • 14
  • 6
  • 4
24 Comments
 
LVL 9

Expert Comment

by:dmang
ID: 23749471
Hi bsharath..

I have added some to your code above to test the mail type and if the mail is within the last week.
dmang
Option Explicit
 
Sub Sophos_mails_To_Excel()
    Dim olkmessage As Outlook.MailItem, _
        arrLines As Variant, _
        varLine As Variant, _
        arrLine As Variant, _
        strUser As String, _
        strScan As String, _
        strMachine As String, _
        strFiles As String, _
        excApp As Object, _
        excBook As Object, _
        excSheet As Object
    Dim iDiff As Integer
    Set excApp = CreateObject("Excel.application")
    Set excBook = excApp.Workbooks.Open("D:\AV.xls")
 
   
    For Each olkmessage In Application.ActiveExplorer.Selection
         If olkmessage.Class = olMail Then                      'check on type of item
           iDiff = DateDiff("d", olkmessage.ReceivedTime, Now)  'is mail older than 7 days
           If iDiff < 7 Then                                    'no...process
               strUser = ""
               strScan = ""
               strMachine = ""
               strFiles = ""
               arrLines = Split(olkmessage.Body, vbCrLf)
               For Each varLine In arrLines
                   If varLine <> "" Then
                       arrLine = Split(varLine, ":")
                       Select Case LCase(arrLine(0))
                       Case "user"
                           strUser = AllTrim(arrLine(1))
                       Case "scan"
                           strScan = AllTrim(arrLine(1))
                       Case "machine"
                           strMachine = AllTrim(arrLine(1))
                       Case Else
                           If Left(LCase(Trim(varLine)), 4) = "file" Then
                               strFiles = strFiles & Trim(varLine) & vbLf
                           End If
                       End Select
                   End If
                 End If
               Next
               If Right(strFiles, 1) = vbLf Then
                   strFiles = Left(strFiles, Len(strFiles) - 1)
               End If
       
               Set excSheet = Nothing
             
               On Error Resume Next
               Set excSheet = excBook.Sheets(Format(olkmessage.ReceivedTime, "ddd mmm yyyy"))
               On Error GoTo 0
               If excSheet Is Nothing Then
                   Set excSheet = excBook.Sheets.Add
                   excSheet.Name = Format(olkmessage.ReceivedTime, "ddd mmm yyyy")
               End If
               With excSheet
                   .Range("A1:D1") = Array("User", "Scan", "Machine Name", "Error")
                   .Rows(2).Insert
                   .Cells(2, 1) = strUser
                   .Cells(2, 2) = strScan
                   .Cells(2, 3) = strMachine
                   .Cells(2, 4) = strFiles
               End With
               olkmessage.UnRead = False
               olkmessage.Save
            End If
        End If
    Next
    excBook.Save
 
    Set excSheet = Nothing
    Set excBook = Nothing
    excApp.Quit
    Set excApp = Nothing
    Set olkmessage = Nothing
    MsgBox "Done"
0
 
LVL 11

Author Comment

by:bsharath
ID: 23752413
I get this

---------------------------
Microsoft Visual Basic
---------------------------
Compile error:

End If without block If
---------------------------
OK   Help  
---------------------------
0
 
LVL 11

Author Comment

by:bsharath
ID: 23752414
I get this

---------------------------
Microsoft Visual Basic
---------------------------
Compile error:

End If without block If
---------------------------
OK   Help  
---------------------------
0
Nothing ever in the clear!

This technical paper will help you implement VMware’s VM encryption as well as implement Veeam encryption which together will achieve the nothing ever in the clear goal. If a bad guy steals VMs, backups or traffic they get nothing.

 
LVL 9

Assisted Solution

by:dmang
dmang earned 800 total points
ID: 23755032
Oops..
Option Explicit
 
Sub Sophos_mails_To_Excel()
    Dim olkmessage As Outlook.MailItem, _
        arrLines As Variant, _
        varLine As Variant, _
        arrLine As Variant, _
        strUser As String, _
        strScan As String, _
        strMachine As String, _
        strFiles As String, _
        excApp As Object, _
        excBook As Object, _
        excSheet As Object
    Dim iDiff As Integer
    Set excApp = CreateObject("Excel.application")
    Set excBook = excApp.Workbooks.Open("D:\AV.xls")
 
   
    For Each olkmessage In Application.ActiveExplorer.Selection
         If olkmessage.Class = olMail Then                      'check on type of item
           iDiff = DateDiff("d", olkmessage.ReceivedTime, Now)  'is mail older than 7 days
           If iDiff < 7 Then                                    'no...process
               strUser = ""
               strScan = ""
               strMachine = ""
               strFiles = ""
               arrLines = Split(olkmessage.Body, vbCrLf)
               For Each varLine In arrLines
                   If varLine <> "" Then
                       arrLine = Split(varLine, ":")
                       Select Case LCase(arrLine(0))
                       Case "user"
                           strUser = AllTrim(arrLine(1))
                       Case "scan"
                           strScan = AllTrim(arrLine(1))
                       Case "machine"
                           strMachine = AllTrim(arrLine(1))
                       Case Else
                           If Left(LCase(Trim(varLine)), 4) = "file" Then
                               strFiles = strFiles & Trim(varLine) & vbLf
                           End If
                       End Select
                   End If
               Next
               If Right(strFiles, 1) = vbLf Then
                   strFiles = Left(strFiles, Len(strFiles) - 1)
               End If
       
               Set excSheet = Nothing
             
               On Error Resume Next
               Set excSheet = excBook.Sheets(Format(olkmessage.ReceivedTime, "ddd mmm yyyy"))
               On Error GoTo 0
               If excSheet Is Nothing Then
                   Set excSheet = excBook.Sheets.Add
                   excSheet.Name = Format(olkmessage.ReceivedTime, "ddd mmm yyyy")
               End If
               With excSheet
                   .Range("A1:D1") = Array("User", "Scan", "Machine Name", "Error")
                   .Rows(2).Insert
                   .Cells(2, 1) = strUser
                   .Cells(2, 2) = strScan
                   .Cells(2, 3) = strMachine
                   .Cells(2, 4) = strFiles
               End With
               olkmessage.UnRead = False
               olkmessage.Save
            End If
        End If
    Next
    excBook.Save
 
    Set excSheet = Nothing
    Set excBook = Nothing
    excApp.Quit
    Set excApp = Nothing
    Set olkmessage = Nothing
    MsgBox "Done"
0
 
LVL 11

Author Comment

by:bsharath
ID: 23755269
The script ran without any errors but no results
0
 
LVL 11

Author Comment

by:bsharath
ID: 23755270
The script ran without any errors but no results
0
 
LVL 9

Expert Comment

by:dmang
ID: 23756681
Are you selecting mail items?
0
 
LVL 11

Author Comment

by:bsharath
ID: 23757978
Yes i selected the folder and all mails within the folder only then i ran the script
0
 
LVL 9

Expert Comment

by:dmang
ID: 23759144
If the mails are older than 7 days, they will be ignored
0
 
LVL 11

Author Comment

by:bsharath
ID: 23761919
I have the mails of today and 2 days ago
0
 
LVL 11

Author Comment

by:bsharath
ID: 23761920
I have the mails of today and 2 days ago
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 23764666
SHarath

I would say that Dmang has it all but covered.  I can only see one potential tweak which is as below.

Does it help at all.

Chris
Sub Sophos_mails_To_Excel()
    Dim olkmessage As Object, _
        arrLines As Variant, _
        varLine As Variant, _
        arrLine As Variant, _
        strUser As String, _
        strScan As String, _
        strMachine As String, _
        strFiles As String, _
        excApp As Object, _
        excBook As Object, _
        excSheet As Object
    Dim iDiff As Integer
    Set excApp = CreateObject("Excel.application")
    Set excBook = excApp.Workbooks.Open("D:\AV.xls")
 
    
    For Each olkmessage In Application.ActiveExplorer.Selection
         If olkmessage.Class = olMail Then                      'check on type of item
           iDiff = DateDiff("d", olkmessage.ReceivedTime, Now)  'is mail older than 7 days
           If iDiff < 7 Then                                    'no...process
               strUser = ""
               strScan = ""
               strMachine = ""
               strFiles = ""
               arrLines = Split(olkmessage.Body, vbCrLf)
               For Each varLine In arrLines
                   If varLine <> "" Then
                       arrLine = Split(varLine, ":")
                       Select Case LCase(arrLine(0))
                       Case "user"
                           strUser = AllTrim(arrLine(1))
                       Case "scan"
                           strScan = AllTrim(arrLine(1))
                       Case "machine"
                           strMachine = AllTrim(arrLine(1))
                       Case Else
                           If Left(LCase(Trim(varLine)), 4) = "file" Then
                               strFiles = strFiles & Trim(varLine) & vbLf
                           End If
                       End Select
                   End If
               Next
               If Right(strFiles, 1) = vbLf Then
                   strFiles = Left(strFiles, Len(strFiles) - 1)
               End If
        
               Set excSheet = Nothing
              
               On Error Resume Next
               Set excSheet = excBook.Sheets(Format(olkmessage.ReceivedTime, "ddd mmm yyyy"))
               On Error GoTo 0
               If excSheet Is Nothing Then
                   Set excSheet = excBook.Sheets.Add
                   excSheet.Name = Format(olkmessage.ReceivedTime, "ddd mmm yyyy")
               End If
               With excSheet
                   .Range("A1:D1") = Array("User", "Scan", "Machine Name", "Error")
                   .Rows(2).Insert
                   .Cells(2, 1) = strUser
                   .Cells(2, 2) = strScan
                   .Cells(2, 3) = strMachine
                   .Cells(2, 4) = strFiles
               End With
               olkmessage.UnRead = False
               olkmessage.Save
            End If
        End If
    Next
    excBook.Save
 
    Set excSheet = Nothing
    Set excBook = Nothing
    excApp.Quit
    Set excApp = Nothing
    Set olkmessage = Nothing
    MsgBox "Done"
 
End Sub

Open in new window

0
 
LVL 11

Author Comment

by:bsharath
ID: 23764706
Chris i get the Done box but not data change in the Av.xls
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 23764889
I've run it as a test to confirm, as far as I can see it writes to a workbook page as expected.  Can you supply a sample email body text and the workbook?

Chris
0
 
LVL 11

Author Comment

by:bsharath
ID: 23764896
Ok

Here is the body of the mail

User: NT AUTHORITY\SYSTEM
Scan: Daily
Machine: IC

File "F:\Development\GlApp\toolbar.exe\FILE:0007" belongs to adware/PUA 'SearchIt' (of type Adware).

Adware/PUA 'SearchIt' is not removable.

This is the subject
SAV message from: IC
0
 
LVL 11

Author Comment

by:bsharath
ID: 23764907
Chris this code still works fine...
But not more than 1 weeks sheets are created
Option Explicit
 
Sub Sophos_mails_To_Excel()
    Dim olkmessage As Outlook.MailItem, _
        arrLines As Variant, _
        varLine As Variant, _
        arrLine As Variant, _
        strUser As String, _
        strScan As String, _
        strMachine As String, _
        strFiles As String, _
        excApp As Object, _
        excBook As Object, _
        excSheet As Object
    Set excApp = CreateObject("Excel.application")
    Set excBook = excApp.Workbooks.Open("D:\AV11.xlsx")
 
 
    For Each olkmessage In Application.ActiveExplorer.Selection
        strUser = ""
        strScan = ""
        strMachine = ""
        strFiles = ""
        arrLines = Split(olkmessage.Body, vbCrLf)
        For Each varLine In arrLines
            If varLine <> "" Then
                arrLine = Split(varLine, ":")
                Select Case LCase(arrLine(0))
                Case "user"
                    strUser = AllTrim(arrLine(1))
                Case "scan"
                    strScan = AllTrim(arrLine(1))
                Case "machine"
                    strMachine = AllTrim(arrLine(1))
                Case Else
                    If Left(LCase(Trim(varLine)), 4) = "file" Then
                        strFiles = strFiles & Trim(varLine) & vbLf
                    End If
                End Select
            End If
        Next
        If Right(strFiles, 1) = vbLf Then
            strFiles = Left(strFiles, Len(strFiles) - 1)
        End If
 
        Set excSheet = Nothing
 
        On Error Resume Next
        Set excSheet = excBook.Sheets(Format(olkmessage.ReceivedTime, "ddd mmm yyyy"))
        On Error GoTo 0
        If excSheet Is Nothing Then
            Set excSheet = excBook.Sheets.Add
            excSheet.Name = Format(olkmessage.ReceivedTime, "ddd mmm yyyy")
        End If
 
 
 
        With excSheet
            .Range("A1:D1") = Array("User", "Scan", "Machine Name", "Error")
            .Rows(2).Insert
            .Cells(2, 1) = strUser
            .Cells(2, 2) = strScan
            .Cells(2, 3) = strMachine
            .Cells(2, 4) = strFiles
        End With
        olkmessage.UnRead = False
        olkmessage.Save
    Next
    excBook.Save
 
    Set excSheet = Nothing
    Set excBook = Nothing
    excApp.Quit
    Set excApp = Nothing
    Set olkmessage = Nothing
    MsgBox "Done"
End Sub

Open in new window

0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 23765110
OKay

Back to basics, the original script works, but processes all emails.  You want it to look at mails in the last week only and to ignore invalid items in the folder?

Chris
0
 
LVL 11

Author Comment

by:bsharath
ID: 23765125
I want to ignore invalid items but not look for just 1 week. i want to get all the mails in the folder...
If the folder has 1000 mails and from the whole month. Want all mails each day for the whole month got into the workbook.
Oops i guess the script was looking just for a week?
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 23765147
It does, that wasn't my understanding of the original request BUT Dmang understood that and you didn't correct it so ...!

The week restrictioon is easy to undo, but do you get the last weeks data?  I have just walked through both subs and as I said earlier Dmang had it correct for what they implemented it works as the original with their understanding of the change.

If the last week is uploaded okay, (try renaming a sheet to something else and selecting some recent mails and see if works ok still.  If it does then we can try to get back to what you want.

Chris
0
 
LVL 11

Author Comment

by:bsharath
ID: 23765158
At present does this script take last weeks mails. Can you give me a date is possible. I tried with Last mon and Tue it did not get any data
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 23765353
The code analyses the received time ... but what the heck.  The following hopefully removes the date check completely so see how it does.

Chris
Sub Sophos_mails_To_Excel()
    Dim olkmessage As Outlook.mailitem, _
        arrLines As Variant, _
        varLine As Variant, _
        arrLine As Variant, _
        strUser As String, _
        strScan As String, _
        strMachine As String, _
        strFiles As String, _
        excApp As Object, _
        excBook As Object, _
        excSheet As Object
    Set excApp = CreateObject("Excel.application")
    Set excBook = excApp.Workbooks.Open("D:\AV11.xlsx")
 
 
    For Each olkmessage In Application.ActiveExplorer.Selection
        If olkmessage.Class = olMail Then
           strUser = ""
           strScan = ""
           strMachine = ""
           strFiles = ""
           arrLines = Split(olkmessage.body, vbCrLf)
           For Each varLine In arrLines
               If varLine <> "" Then
                   arrLine = Split(varLine, ":")
                   Select Case LCase(arrLine(0))
                   Case "user"
                       strUser = AllTrim(arrLine(1))
                   Case "scan"
                       strScan = AllTrim(arrLine(1))
                   Case "machine"
                       strMachine = AllTrim(arrLine(1))
                   Case Else
                       If Left(LCase(Trim(varLine)), 4) = "file" Then
                           strFiles = strFiles & Trim(varLine) & vbLf
                       End If
                   End Select
               End If
           Next
           If Right(strFiles, 1) = vbLf Then
               strFiles = Left(strFiles, Len(strFiles) - 1)
           End If
    
           Set excSheet = Nothing
    
           On Error Resume Next
           Set excSheet = excBook.Sheets(Format(olkmessage.ReceivedTime, "ddd mmm yyyy"))
           On Error GoTo 0
           If excSheet Is Nothing Then
               Set excSheet = excBook.Sheets.Add
               excSheet.Name = Format(olkmessage.ReceivedTime, "ddd mmm yyyy")
           End If
    
    
    
           With excSheet
               .Range("A1:D1") = Array("User", "Scan", "Machine Name", "Error")
               .Rows(2).Insert
               .Cells(2, 1) = strUser
               .Cells(2, 2) = strScan
               .Cells(2, 3) = strMachine
               .Cells(2, 4) = strFiles
           End With
           olkmessage.UnRead = False
           olkmessage.Save
        End If
    Next
    excBook.Save
 
    Set excSheet = Nothing
    Set excBook = Nothing
    excApp.Quit
    Set excApp = Nothing
    Set olkmessage = Nothing
    MsgBox "Done"
End Sub

Open in new window

0
 
LVL 11

Author Comment

by:bsharath
ID: 23765491
Chris it works but the sheet names are the same
I get the names as this
Sun Dec 2008
Sat Dec 2008
I will need with the date
0
 
LVL 59

Accepted Solution

by:
Chris Bottomley earned 1200 total points
ID: 23765547
Modified to 28 Feb 2009 format

Chris
Sub Sophos_mails_To_Excel()
    Dim olkmessage As Outlook.mailitem, _
        arrLines As Variant, _
        varLine As Variant, _
        arrLine As Variant, _
        strUser As String, _
        strScan As String, _
        strMachine As String, _
        strFiles As String, _
        excApp As Object, _
        excBook As Object, _
        excSheet As Object
    Set excApp = CreateObject("Excel.application")
    Set excBook = excApp.Workbooks.Open("D:\AV11.xlsx")
 
 
    For Each olkmessage In Application.ActiveExplorer.Selection
        If olkmessage.Class = olMail Then
           strUser = ""
           strScan = ""
           strMachine = ""
           strFiles = ""
           arrLines = Split(olkmessage.body, vbCrLf)
           For Each varLine In arrLines
               If varLine <> "" Then
                   arrLine = Split(varLine, ":")
                   Select Case LCase(arrLine(0))
                   Case "user"
                       strUser = AllTrim(arrLine(1))
                   Case "scan"
                       strScan = AllTrim(arrLine(1))
                   Case "machine"
                       strMachine = AllTrim(arrLine(1))
                   Case Else
                       If Left(LCase(Trim(varLine)), 4) = "file" Then
                           strFiles = strFiles & Trim(varLine) & vbLf
                       End If
                   End Select
               End If
           Next
           If Right(strFiles, 1) = vbLf Then
               strFiles = Left(strFiles, Len(strFiles) - 1)
           End If
    
           Set excSheet = Nothing
    
           On Error Resume Next
           Set excSheet = excBook.Sheets(Format(olkmessage.ReceivedTime, "dd mmm yyyy"))
           On Error GoTo 0
           If excSheet Is Nothing Then
               Set excSheet = excBook.Sheets.Add
               excSheet.Name = Format(olkmessage.ReceivedTime, "dd mmm yyyy")
           End If
    
    
    
           With excSheet
               .Range("A1:D1") = Array("User", "Scan", "Machine Name", "Error")
               .Rows(2).Insert
               .Cells(2, 1) = strUser
               .Cells(2, 2) = strScan
               .Cells(2, 3) = strMachine
               .Cells(2, 4) = strFiles
           End With
           olkmessage.UnRead = False
           olkmessage.Save
        End If
    Next
    excBook.Save
 
    Set excSheet = Nothing
    Set excBook = Nothing
    excApp.Quit
    Set excApp = Nothing
    Set olkmessage = Nothing
    MsgBox "Done"
End Sub

Open in new window

0
 
LVL 11

Author Comment

by:bsharath
ID: 23767584
Thanks a lot Chris & dmang
Asking a related post please have a look
0

Featured Post

Free Tool: Port Scanner

Check which ports are open to the outside world. Helps make sure that your firewall rules are working as intended.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Microsoft Office Picture Manager was included in Office 2003, 2007, and 2010, but not in Office 2013. Users had hopes that it would be in Office 2016/Office 365, but it is not. Fortunately, the same zero-cost technique that works to install it with …
With its various features, Office 365 can not only help you with your day-to-day business tasks, it can also do wonders for your marketing campaign.
Access reports are powerful and flexible. Learn how to create a query and then a grouped report using the wizard. Modify the report design after the wizard is done to make it look better. There will be another video to explain how to put the final p…
This video shows how to remove a single email address from the Outlook 2010 Auto Suggestion memory. NOTE: For Outlook 2016 and 2013 perform the exact same steps. Open a new email: Click the New email button in Outlook. Start typing the address: …
Suggested Courses

839 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question