Outlook Macro extract data to csv

Question

I want to extract data from email and save it in CSV. So far what I do is convert it to excel, is there any code I can add so it can save it to CSV after finished running the first macro.

Option Explicit

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 = "D:\My Documents\Vehicles.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")

    '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), "A Card/Order") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("D" & rCount) = Trim(vItem(1))
            End If

            If InStr(1, vText(i), "Required ShipDate:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("E" & rCount) = Trim(vItem(1))
            End If

            If InStr(1, vText(i), "Card Quantity:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("N" & rCount) = Trim(vItem(1))
            End If
        Next i
        xlSheet.Rows(1).Delete
        xlSheet.Range("A1").Value = "0"
        xlSheet.Range("B1").Value = "862"
        xlSheet.Range("C1").Value = "00-100-6360"

        xlSheet.Range("F1").Value = "0"
        xlSheet.Range("G1").Value = "0"
        xlSheet.Range("H1").Value = "0"
        xlSheet.Range("I1").Value = "0"
        xlSheet.Range("J1").Value = "0"
        xlSheet.Range("K1").Value = "0"
        xlSheet.Range("L1").Value = "0"
        xlSheet.Range("M1").Value = "0"
        xlSheet.Range("O1").Value = "0"
        xlSheet.Range("P1").Value = "0"
        xlSheet.Range("Q1").Value = "0"
        xlSheet.Range("R1").Value = "0"
        xlSheet.Range("S1").Value = "0"
        xlSheet.Range("T1").Value = "0"
        xlSheet.Range("U1").Value = "0"
        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 tried:

 ActiveWorkbook.SaveAs fileFormat:=xlCSV 

But that does not save the file as CSV .

Reference: Social MSDN Forums

Answer 1

Before

xlWB.Close SaveChanges:=True

Try

xlWB.SaveAs fileFormat:=xlCSV

Or

xlWB.SaveAs fileFormat:=6