Running a Outlook Macro that 'writes' the data to an excel sheet.

[bracken752]

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.

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:

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

 

[s.ridd]

To get over the "select" issue you're having, you could try replacing

[COLOR=#574123]Application.ActiveExplorer.Selection[/COLOR]

with

Application.Session.GetDefaultFolder(olFolderInbox).Items

. I haven't tested any of your code as you suggest that it works apart from for this issue.

Also, for your second point try calling your procedure from an Application_StartUp() procedure in the ThisOutlookSession module.

Hope this helps

Simon