Outlook help regarding outlook vba

[Asaad Fawzy]

Dear all I have the code below working very good to move the data from outlook to excel
can any of you convert it to working automatically for the messages which located on exact folder in my outlook


Option Explicit
Sub Semsem()
On Error GoTo clearerror
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim olItem As Outlook.MailItem
Dim vText As Variant
Dim vPara As Variant
Dim sText As String
Dim vItem As Variant
Dim i As Long
Dim rCount As Long
Dim bXStarted As Boolean
*** Const strPath As String = "C:\eReports\ePurchasing\New Orders.xlsx"
*** If Application.ActiveExplorer.Selection.Count = 0 Then
******* MsgBox "No Items selected!", vbCritical, "ePurchasing"
******* 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
*** Set xlWB = xlApp.Workbooks.Open(strPath)
*** Set xlSheet = xlWB.Sheets("Orders Data")
*** For Each olItem In Application.ActiveExplorer.Selection
******* sText = olItem.Body
******* vText = Split(sText, Chr(13))
******* rCount = xlSheet.UsedRange.Rows.Count
******* rCount = rCount + 1
******* rCount = xlSheet.Range("A" & xlSheet.Rows.Count).End(xlUp).Row
******* rCount = rCount + 1
******* vItem = Split(vText(2) & vText(3), ChrW(1))
On Error Resume Next
******* xlSheet.Range("A" & rCount) = Trim(vText(4))
******* xlSheet.Range("B" & rCount) = Trim(vText(6))
******* xlSheet.Range("C" & rCount) = Trim(vText(8))
******* xlSheet.Range("D" & rCount) = Trim(vText(10))
******* xlSheet.Range("E" & rCount) = Trim(vText(12))
******* xlSheet.Range("F" & rCount) = Trim(vText(14))
******* xlSheet.Range("G" & rCount) = Trim(vText(16))
******* xlSheet.Range("H" & rCount) = Trim(vText(18))
******* xlSheet.Range("I" & rCount) = Trim(vText(20))
******* xlSheet.Range("J" & rCount) = Trim(vText(22))
******* xlSheet.Range("K" & rCount) = Trim(vText(24))
******* xlSheet.Range("L" & rCount) = Trim(vText(26))
******* xlSheet.Range("M" & rCount) = Trim(vText(28))
******* xlSheet.Range("N" & rCount) = Trim(vText(30))
******* xlSheet.Range("O" & rCount) = Trim(vText(32))
******* xlSheet.Range("P" & rCount) = Trim(vText(34))
******* xlSheet.Range("Q" & rCount) = Trim(vText(36))
******* xlSheet.Range("R" & rCount) = Trim(vText(38))
******* xlSheet.Range("S" & rCount) = Trim(vText(40))
*** 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
MsgBox "We finshed transfering items to Store" & vbNewLine & "Please run importing from ePurchasing in order to record them", vbInformation, "ePurchasing"
clearerror:
Exit Sub
End Sub