• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Transfer Inbox mails data to Excel.

S

sri.guru

New Member
Hello Chandoo,


I had gone through ur Webiste, it's awesome, i have a quick quesion: I want to transfer My Inbox mails data i.e body to Excel and same should happen automatically i.e time need to be set. is that possible in VBA, i have done VBA and same is pasted down but

I am unable to set time and if want only particular person mail need to be transfered to excel, how to do that

VBA Code:

[pre]
Code: 
Sub CopyToExcel()
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim olItem As Outlook.MailItem
Dim r As Long
Dim bXStarted As Boolean
Const strPath As String = "C:Documents and Settingssri.guruDesktopTest.xlsx" 'the path of the workbook

If Application.ActiveExplorer.Selection.Count = 0 Then
MsgBox "No Items selected!", vbCritical, "Error"
Exit Sub
End If
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Application.StatusBar = "Please wait while Excel source is opened ... "
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(strPath)
Set xlSheet = xlWB.Sheets("Sheet1")

'Process each selected record

For Each olItem In Application.ActiveExplorer.Selection

'Find the next empty line of the worksheet
r = xlSheet.Range("A" & xlSheet.Rows.Count).End(xlUp).Row
r = r + 1

xlSheet.Cells(r, "A") = olItem.Subject
xlSheet.Cells(r, "B") = olItem.sendername
xlSheet.Cells(r, "C") = olItem.To
xlSheet.Cells(r, "D") = olItem.ReceivedTime
xlSheet.Cells(r, "E") = olItem.Attachments.Count
xlSheet.Cells(r, "F") = olItem.Size
xlSheet.Cells(r, "G") = olItem.Body
xlSheet.Cells(r, "h") = olItem.senderemailaddress

xlWB.Save

End Sub

Next olItem
xlWB.Close SaveChanges:=True
If bXStarted Then
xlApp.Quit
End If

Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
Set olItem = Nothing
End Sub
[/pre]
 
Hi, sri.guru!


First of all welcome to Chandoo's website Excel forums. Thank you for your joining us and glad to have you here.


As a starting point I'd recommend you to read the green sticky topics at this forums main page. There you'll find general guidelines about how this site and community operates (introducing yourself, posting files, netiquette rules, and so on).


Among them you're prompted to perform searches within this site before posting, because maybe your question had been answered yet.


Feel free to play with different keywords so as to be led thru a wide variety of articles and posts, and if you don't find anything that solves your problem or guides you towards a solution, you'll always be welcome back here. Tell us what you've done, consider uploading a sample file as recommended, and somebody surely will read your post and help you.


And about questions in general...


If you haven't performed yet the search herein, try going to the topmost right zone of this page (Custom Search), type the keywords used in Tags field when creating the topic or other proper words and press Search button. You'd retrieve many links from this website, like the following one(s) -if any posted below-, maybe you find useful information and even the solution. If not please advise so as people who read it could get back to you as soon as possible.


And about this question in particular...


I don't know if I understood you correctly

a) You wrote a subroutine that retrieves all the mails from your Outlook account into Excel. I'm not going to check, I'll just assume it works fine.

b) You want to filter retrieved mail by sender.

c) You want to stamp a date footprint with the actual date & time value of retrieval

If that's right try this in any module:

-----

Option Explicit

Sub X()
Const kdTime = #12:05:00 AM#
Application.OnTime Now() + kdTime, "CopyToExcel", , True
End Sub

Sub CopyToExcel()
' fix start
Const kdTime = #12:05:00 AM#
' fix end
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim olItem As Outlook.MailItem
Dim r As Long
Dim bXStarted As Boolean
' fix start
Dim sSearchFor As String
' fix end
Const strPath As String = "C:Documents and Settingssri.guruDesktopTest.xlsx" 'the path of the workbook

' fix start
Application.EnableEvents = False
sSearchFor = InputBox("Enter sender name or email address (leave blank for all)", "Filter by sender")
sSearchFor = "*" & Trim(sSearchFor)
If Len(sSearchFor) > 1 Then sSearchFor = sSearchFor & "*"
' fix end
If Application.ActiveExplorer.Selection.Count = 0 Then
MsgBox "No Items selected!", vbCritical, "Error"
Exit Sub
End If
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Application.StatusBar = "Please wait while Excel source is opened ... "
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(strPath)
Set xlSheet = xlWB.Sheets("Sheet1")

'Process each selected record

For Each olItem In Application.ActiveExplorer.Selection
r />' fix start
If olItem.sendername Like sSearchFor Or olItem.senderemailaddress Like sSearchFor Then
' fix end

'Find the next empty line of the worksheet
r = xlSheet.Range("A" & xlSheet.Rows.Count).End(xlUp).Row
r = r + 1

xlSheet.Cells(r, "A") = olItem.Subject
xlSheet.Cells(r, "B") = olItem.sendername
xlSheet.Cells(r, "C") = olItem.To
xlSheet.Cells(r, "D") = olItem.ReceivedTime
xlSheet.Cells(r, "E") = olItem.Attachments.Count
xlSheet.Cells(r, "F") = olItem.Size
xlSheet.Cells(r, "G") = olItem.Body
xlSheet.Cells(r, "h") = olItem.senderemailaddress
' fix start
xlSheet.Cells(r, "i") = Now()

End If
' fix end

xlWB.Save

Next olItem
' fix start
Application.OnTime Now() + kdTime, "CopyToExcel", , True
' fix end
xlWB.Close SaveChanges:=True
If bXStarted Then
xlApp.Quit
End If

Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
Set olItem = Nothing
End Sub

-----


And this in the ThisWorbook object section:

-----

[pre]
Code: 
Option Explicit

Private Sub Workbook_Open()
X
End Sub
[/pre]
-----


Mofications with this format:

' fix start

....

' fix end


Regards!


EDITED


PS: Code fixed and updated as of below link.
 
Thanks SirJB7,


c) You want to stamp a date footprint with the actual date & time value of retrieval

Answer to above question:Your understanding was incorrect with respect to above question, my question was the Mails details should be automatically updated to excel i.e time need to be setup for the Auto-execution.
 
Hi, sri.guru!


For solving c) just delete the line of the Now() function.


Now regarding "should be automatically updated" issue, you could use the OnTime method of the Application object to do something like:

-----

Sub X()

...

Const kdTime = #00:05:00#

...

Application.OnTime Now() + kdTime, "CopyToExcel", , True

...

End Sub

-----


This will run the specified macro in 5' from now.


You should add the same instruction as your last line on CopyToExcel procedure.


Regards!
 
Hi SirJB7,


Const kdTime = #00:05:00#(changing the time to "Const kdTime = #12:05:00 PM#")is this correct? and removed Inputbox and straight away given Email-id straightaway


Can u please check below code is perfect now because i have done necessary changes as u suggested.


Option Explicit


Sub CopyToExcel()

Dim xlApp As Excel.Application

Dim xlWB As Excel.Workbook

Dim xlSheet As Excel.Worksheet

Dim olItem As Outlook.MailItem

Dim r As Long

Dim bXStarted As Boolean

' fix start

Dim sSearchFor As String

' fix end

Const strPath As String = "C:Documents and Settingssri.guruDesktopTest.xlsx" 'the path of the workbook


' fix start

sSearchFor = "Guru, Sri (Financial&Risk)"

sSearchFor = "*" & Trim(sSearchFor)

If Len(sSearchFor) > 1 Then sSearchFor = sSearchFor & "*"

' fix end

If Application.ActiveExplorer.Selection.Count = 0 Then

MsgBox "No Items selected!", vbCritical, "Error"

Exit Sub

End If

On Error Resume Next

Set xlApp = GetObject(, "Excel.Application")

If Err <> 0 Then

Application.StatusBar = "Please wait while Excel source is opened ... "

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(strPath)

Set xlSheet = xlWB.Sheets("Sheet1")


'Process each selected record


For Each olItem In Application.ActiveExplorer.Selection


' fix start

If olItem.SenderName Like sSearchFor Or olItem.SenderEmailAddress Like sSearchFor Then

' fix end


'Find the next empty line of the worksheet

r = xlSheet.Range("A" & xlSheet.Rows.Count).End(xlUp).Row

r = r + 1


xlSheet.Cells(r, "A") = olItem.Subject

xlSheet.Cells(r, "B") = olItem.SenderName

xlSheet.Cells(r, "C") = olItem.To

xlSheet.Cells(r, "D") = olItem.ReceivedTime

xlSheet.Cells(r, "E") = olItem.Attachments.Count

xlSheet.Cells(r, "F") = olItem.Size

xlSheet.Cells(r, "G") = olItem.Body

xlSheet.Cells(r, "h") = olItem.SenderEmailAddress


End If

' fix end


xlWB.Save


Next olItem

xlWB.Close SaveChanges:=True

If bXStarted Then

xlApp.Quit

End If


Set xlApp = Nothing

Set xlWB = Nothing

Set xlSheet = Nothing

Set olItem = Nothing

End Sub


Sub X()


Const kdTime = #12:05:00 PM#


Application.OnTime Now() + kdTime, "CopyToExcel", , True


End Sub
 
Hi, sri.guru!


Yes, the change for the constant variable is correct, you enter it as I stated and VB changes it to AM/PM.


But when you run sub X it'll only trigger the first time the execution of the CopyToExcel sub. You're missing the same Application.OnTime line as the last line of CopyToExcel procedure so as to schedule again the next check triggering 5' later.


You may also want to include in the ThisWorkbook object section code, the call of procedure X from within the workbook open event code, so it'll run when you open the file without having to do anything else.


Regards!
 
Hi, sri.guru!


The fixed code it's updated upwards in my first post. And this is the link to the sample file:

https://dl.dropboxusercontent.com/u/60558749/Transfer%20Inbox%20mails%20data%20to%20Excel.%20%28for%20sri.guru%20at%20chandoo.org%29.xlsm


Regards!
 
You must log in or register to reply here.
Back
Top