Need help to amend the Outlookto Excel Macro

[Jagdev]

Hi Expert,

I have created a macro which extract email related information from outlook into Excel sheet. It is working fine. I want some amendments into it. I do not want the macro to extract the entire email everytime I run it. My main target folder is Indox and we are using it for Inbox only. What I want the macro is to pull the data once and next time when I run it, it should pull only those mail data which are not available in the excel instead of extracting the whole outlook email again.

Also, in the current macro I am only able to extract few words from the body, is it possible to pull the entire body information from the outlook.

Please find the macro copy attached with the mail.

Regards,
JD

[gmayor]

See http://www.gmayor.com/extract_data_from_email.htm where you will find a variety of code examples for extracting data from Outlook to Excel. If you are working (as you appear to be) with the contents of a folder (rather than process the messages as they arrive in Outlook) then either move the messages to a 'processed' folder or categorize them as processed and if you ignore messages with that category, you only process the messages once.

[Jagdev]

Hi Graham

Thanks for the link. I checked it and it looks perfect in case if we receive email in fix format that is what I assume. As per body is concerned with my query, We have data in text format. In my current macro it capture only few text. I want it to capture few more text for better understanding of the mail. We receive 100s of mail in a day, to keep recording all the mail is not what I am looking with it, but the link was superb in that context. We run this macro only in cases we need to check some data in the mail.

Also, is it possible to amend the macro to pull mail information of a specific person or with specific name only.

Our main target folder is Inbox

Example - I need to check the mail with a specific subject line "Data is attached". Can we tweak it to throw a pop-up msg asking for subject line. When I add it gimme the data in the sheet with the specific context mentioned in the attached macro

Regards,
JD

[gmayor]

Actually the linked code reads the body of the message and splits it by paragraph, what you do with those paragraphs would be a matter for you. In the linked example each paragraph is split to enable the same wanted data to be extracted, but you could process the paragraphs in other ways e.g. to look for a specific text. Therefore in essence it addresses your question as it allows you to evaluate ALL the message text.
If you add strTestSubject = InputBox("Enter the message subject to process")

before the loop then

If instr(1, .Subject, strTestSubject) > 0 then =
'do stuff
End IfThat should address your tweak.

[Jagdev]

Hi Graham

Thanks for the code. I am leaving for the day, will check the code tomorrow and get back to you. Hope it fulfill the said requirement.

Regards,
JD

[Jagdev]

Hi Graham

I added the below code in the module of my outlook. It throws the Inputbox asking for the subject, but nothing appears on the excel sheet. Please let me know what I am missing here.

What I want from the mail -

From
Email-ID
Sunject Line -
Body -


Sub CopyToExcel(olItem As MailItem)
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim vText As Variant
Dim sText As String
Dim sAddr As String
Dim vAddr As Variant
Dim vItem As Variant
Dim i As Long, j As Long
Dim rCount As Long
Dim bXStarted As Boolean
strTestSubject = InputBox("Enter the message subject to process")
Const strWorkSheetName As String = "Sheet1"
Const strWorkBookName As String = "C:\Users\\New folder (2)\Book2.xlsx" 'the path of the workbook
'Use FileExists function to determine the availability of the workbook
If Not FileExists(strWorkBookName) Then Exit Sub
'Get Excel if it is running, or open it if not
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Set xlApp = CreateObject("Excel.Application")
bXStarted = True
End If
On Error GoTo 0
'Open the workbook to input the data
Set xlWB = xlApp.Workbooks.Open(strWorkBookName)
Set xlSheet = xlWB.Sheets("Sheet1")
'Process the message
With olItem
sText = olItem.Body
vText = Split(sText, Chr(13))
'Find the next empty line of the worksheet
rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).Row + 1
'Check each line of text in the message body
For i = UBound(vText) To 0 Step -1
If InStr(1, vText(i), "Source:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("A" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Customer Name:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("B" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Customer Email:") > 0 Then
vItem = Split(vText(i), Chr(58))
sAddr = ""
For j = 1 To UBound(vItem)
sAddr = sAddr & vItem(j)
Next j
If InStr(1, UCase(sAddr), "HYPERLINK") > 0 Then
vAddr = Split(sAddr, Chr(34))
sAddr = vAddr(UBound(vAddr))
End If
xlSheet.Range("C" & rCount) = sAddr
End If
If InStr(1, .Subject, strTestSubject) > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("D" & rCount) = Trim(vItem(1))
End If
Next i
xlWB.Save
End With
xlWB.Close SaveChanges:=True
If bXStarted Then
xlApp.Quit
End If
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
End Sub
Public Function FileExists(ByVal Filename As String) As Boolean
Dim nAttr As Long
On Error GoTo NoFile
nAttr = GetAttr(Filename)
If (nAttr And vbDirectory) <> vbDirectory Then
FileExists = True
End If
NoFile:
End Function
Sub ExtractData()
Dim oItem As MailItem
If Application.ActiveExplorer.Selection.Count = 0 Then
MsgBox "No Items selected!", vbCritical, "Error"
Exit Sub
End If
For Each oItem In ActiveExplorer.Selection
CopyToExcel oItem
Next oItem
Set oItem = Nothing
End Sub

[gmayor]

Maybe the lines



Const strWorkBookName As String = "C:\Users\\New folder (2)\Book2.xlsx" 'the path of the workbook
'Use FileExists function to determine the availability of the workbook
If Not FileExists(strWorkBookName) Then Exit Sub

provide a clue? The path you have quoted is certainly not valid and that would end the process
It is difficult to imagine what you want from the subject check, but if you only want to process messages with a certain subject then wrap the test around the loop e.g.
Note that the subject test is case sensitive.



If InStr(1, .Subject, strTestSubject) > 0 Then
For i = UBound(vText) To 0 Step -1
If InStr(1, vText(i), "Source:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("A" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Customer Name:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("B" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Customer Email:") > 0 Then
vItem = Split(vText(i), Chr(58))
sAddr = ""
For j = 1 To UBound(vItem)
sAddr = sAddr & vItem(j)
Next j
If InStr(1, UCase(sAddr), "HYPERLINK") > 0 Then
vAddr = Split(sAddr, Chr(34))
sAddr = vAddr(UBound(vAddr))
End If
xlSheet.Range("C" & rCount) = sAddr
xlSheet.Range("D" & rCount) = .Subject
End If
Next i
End If

[Jagdev]

Hi Graham

Thanks for sharing the above information. I am avoiding adding the code in outlook, because we follow system sharing concept at my workplace. If I add the outlook macro, I have to personally add the code in the each system and that to the respective individual/person should be log-in to the system at the time of adding the code.

That is way I was pushing for using excel as a base for the macro. I just found one more code which fix my above error to great extent. What it is doing is that it is asking for a range of dates. From 01/01/2015 to 01/12/2015 and extract all the email information from the outlook accordingly. Is it possible to add one more condition that is subject line and adding the subject in the cell will pull data with that subject only with the set condition.

Thanks and Regards,
JD

[Bob Phillips]

Assuming you put the dates in J2 and K2, and the subject in L2.


Sub Launch_Pad()
Dim olApp As Outlook.Application
Dim olNS As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder
Dim Date1 As Date
Dim Date2 As Date
Dim Subject As String

Date1 = Range("J2").Value
Date2 = Range("K2").Value
Subject = Range("L2").Value

Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olFolder = olNS.PickFolder

Call ProcessFolder(olFolder, Subject, Date1, Date2)

Set olFolder = Nothing
Set olApp = Nothing
Set olNS = Nothing
End Sub

Sub ProcessFolder(olfdStart As Outlook.MAPIFolder, _
Subject As String, _
StartDate As Date, _
EndDate As Date)
Dim olObject As Object
Dim n As Long

n = 2

For Each olObject In olfdStart.Items

If TypeName(olObject) = "MailItem" Then

If Int(olObject.ReceivedTime) >= StartDate And Int(olObject.ReceivedTime) <= EndDate Then

If olObject.Subject Like "*" & Subject & "*" Then

Cells(n, 1).Value = olObject.Subject
If Not olObject.UnRead Then Cells(n, 2).Value = "Message is read" Else Cells(n, 2).Value = "Message is unread"
Cells(n, 3).Value = olObject.ReceivedTime
Cells(n, 4).Value = olObject.LastModificationTime
Cells(n, 5).Value = olObject.Body
Cells(n, 6).Value = olObject.SenderName
Cells(n, 7).Value = olObject.FlagRequest

n = n + 1
End If
End If
End If
Next

Set olObject = Nothing
End Sub

[gmayor]

I am not sure what the relevance of your worksheet is to the code I posted which was Outlook code, however, the process you have started can be run from Excel and I have modified your workbook to enable it to do so.

[Jagdev]

Hi Graham

Thanks for amending the macro and it works fine. I have a small doubt on the attached macro. I added few sample entries into it, please let me know if that is possible with the current set of our condition to extract the information from the outlook mail. Please check column "L" name "Subject" with the word "1st Instalment" under it. Is it possible for the macro to check if the subject of the extracted entries contains any word which is mentioned in the "L2" and only those entries data should reflect as a result in the excel sheet. The sample entries will give you the picture I am looking for.

Again Sorry for the confusion.

Regards,
JD

[Jagdev]

Hi Graham

Please ignore the above attachment. I missed the code you have added and checked it just now. Thanks for the code and that is what I am looking for.

Thanks for all your help

Regards,
JD