Outlook help regarding outlook vba


Joined
Nov 4, 2014
Messages
1
Reaction score
0
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
 
Ad

Advertisements


Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Outlook ask a question regarding Outlook 10

Top