Gnanaprakash
New Member
Hello sir,
I have one problem i want to import body of outlook message to excel automatically when receive new mail , i can do when message select manually and click macro but i want it when new mail receives automatically selected it and run macro please help on this sir your help is appreciated.
Main problem is
i need vba code for Select new mail or unread mail automatically any how i have pasted my code here please help me.
I have one problem i want to import body of outlook message to excel automatically when receive new mail , i can do when message select manually and click macro but i want it when new mail receives automatically selected it and run macro please help on this sir your help is appreciated.
Main problem is
i need vba code for Select new mail or unread mail automatically any how i have pasted my code here please help me.
Code:
[Code]
Option Explicit
Sub myRuleMacro1()
'Sub RunAScriptRuleRoutine(MyMail As MailItem)
On Error GoTo eh:
' I want to be able to catch up by reading all my unread messages
Dim ns As Outlook.NameSpace
Dim folder As MAPIFolder
Dim item As Object
Dim msg As MailItem
' Open the inbox folder
Set ns = Session.Application.GetNamespace("MAPI")
Set folder = ns.GetDefaultFolder(olFolderInbox).Folders("JustDial")
' Loop through items in the inbox folder
For Each item In folder.Items
DoEvents
If (item.Class = olMail) And (item.UnRead) Then
' This message has not been read. Display it modally
Set msg = item
msg.Select True
' uncomment the next line to have it only find one unread
' message at a time
'Exit For
Dim xlApp As excel.Application
Dim xlWB As excel.Workbook
Dim xlSheet As excel.Worksheet
Dim olItem As Outlook.MailItem
Dim vText As Variant
Dim sText As String
Dim vItem As Variant
Dim oRng As Range
Dim i As Long
Dim rCount As Long
Dim bXStarted As Boolean
'Dim objItem As Object
Const strPath As String = "C:\Users\ADMIN\Desktop\JustdailEmailtoExcel.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")
'Set objItem = Application.ActiveInspector.CurrentItem
'Process each selected record
For Each olItem In Application.ActiveExplorer.Selection
sText = olItem.Body
vText = Split(sText, Chr(13))
'Find the next empty line of the worksheet'
rCount = xlSheet.Range("A" & xlSheet.Rows.Count).End(xlUp).Row
rCount = rCount + 1
'Check each line of text in the message body
For i = UBound(vText) To 0 Step -1
If InStr(1, vText(i), "Caller Name:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("B" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Caller Requirement:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("C" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Caller Phone:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("D" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Call Date & Time:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("A" & rCount) = Trim(vItem(1) & ":" & vItem(2) & ":" & vItem(3))
End If
If InStr(1, vText(i), "Branch Info:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("E" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "City:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("F" & rCount) = Trim(vItem(1))
End If
Next i
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 If
Next
' If you uncommented the line to read individual messages,
' comment the next line so you don't get a message box
' every single message!
MsgBox "All messages in Inbox are read", vbInformation, "All Read"
Exit Sub
eh:
MsgBox Err.Description, vbCritical, Err.Number
End Sub