Question

我想从电子邮件中提取数据并将其保存为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

我试过了：

 ActiveWorkbook.SaveAs fileFormat:=xlCSV

但是这不会将文件保存为CSV。

参考：Social MSDN Forums

Answer 1

在

xlWB.Close SaveChanges:=True

尝试

xlWB.SaveAs fileFormat:=xlCSV

或者

xlWB.SaveAs fileFormat:=6

Outlook宏将数据提取到csv

1 个答案: