Vba Outlook宏将数据提取到csv

我想从电子邮件中提取数据并将其保存在CSV中。到目前为止，我所做的是将其转换为excel，是否有任何代码可以添加，以便在运行完第一个宏后将其保存到CSV

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

但这不会将文件另存为CSV

参考资料：

之前

xlWB.Close SaveChanges:=True

试一试

或

---

嗨，肖恩，谢谢你的回复。xlWB.SaveAs fileFormat:=6有效，xlWB.SaveAs fileFormat:=xlCSV无效。我还必须在SaveAs“C:\example\name.csv”之后添加目录

xlWB.Close SaveChanges:=True

xlWB.SaveAs fileFormat:=xlCSV

xlWB.SaveAs fileFormat:=6