bracken752
New Member
- Joined
- Aug 15, 2013
- Messages
- 44
Hey all,
I have a partly working macro that will 'write' the email content to an excel sheet however it only seems to work on Select and cant for the life of me correct it.
I am also using mail through exchange server and i want to see if I can have this macro run when outlook is freshly opened (should it ever close) and 'catch up' on any emails it has missed. As I'm stuck on the 'select' issue I haven't even started to think how I'm going to do this lol.
I'm guessing the issue is with the line that says:
however I have no idea what to change it to that will select all the emails within the 'inbox' folder. As If I can get it working I can use rules to move it to another folder once the macro has been run meaning items with the 'inbox' will only be information that needs to be written to file.
Any ideas or directions would be loved.
JB
I have a partly working macro that will 'write' the email content to an excel sheet however it only seems to work on Select and cant for the life of me correct it.
I am also using mail through exchange server and i want to see if I can have this macro run when outlook is freshly opened (should it ever close) and 'catch up' on any emails it has missed. As I'm stuck on the 'select' issue I haven't even started to think how I'm going to do this lol.
Code:
Option Explicit
Public Sub CopyToExcel()
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim olItem As Outlook.MailItem
Dim vText 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 = "FILE LOCATION REMOVED" '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")
'Insert some headers
With xlSheet
.Cells(1, 1) = "Payroll No"
.Cells(1, 2) = "Contact Number"
.Cells(1, 3) = "Line1"
.Cells(1, 4) = "line2"
.Cells(1, 5) = "line3"
.Cells(1, 6) = "line4"
.Cells(1, 7) = "line5"
.Cells(1, 8) = "line6"
.Cells(1, 9) = "line7"
.Cells(1, 10) = "Comments"
.Cells(1, 11) = "Date Submitted"
End With
'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.UsedRange.Rows.Count
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), "Payroll No:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("A" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Telephone:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("B" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Loco No:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("C" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "line") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("D" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "line:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("E" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "line:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("F" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "line:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("G" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "line:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("H" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "line:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("I" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Comments:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("J" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Date Submitted:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("K" & rCount) = Trim(vItem(1))
End If
'all ifs have been changed to line or something else as my manager gets abit nervous if I just copy and paste lol
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 Sub
I'm guessing the issue is with the line that says:
Code:
For Each olItem In Application.ActiveExplorer.Selection
however I have no idea what to change it to that will select all the emails within the 'inbox' folder. As If I can get it working I can use rules to move it to another folder once the macro has been run meaning items with the 'inbox' will only be information that needs to be written to file.
Any ideas or directions would be loved.
JB