• 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.

import Body of outlook message to excel

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.



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
 

Attachments

  • JustdailEmailtoExcel.xlsx
    14.8 KB · Views: 3
Back
Top