Question

我正在使用此代码将Outlook数据（电子邮件）导出到CSV文件：

Sub ExportMessagesToExcel()
Dim olkMsg As Object, _
    excApp As Object, _
    excWkb As Object, _
    excWks As Object, _
    intRow As Integer, _
    intVersion As Integer, _
    strFilename As String
'strFilename = InputBox("Enter a filename (including path) to save the exported messages to.", "Export Messages to Excel")
strFilename = "C:...\...\Emails.csv"
If strFilename <> "" Then
    intVersion = GetOutlookVersion()
    Set excApp = CreateObject("Excel.Application")
    Set excWkb = excApp.Workbooks.Add()
    Set excWks = excWkb.ActiveSheet
    'Write Excel Column Headers
    With excWks
        .Cells(1, 1) = "Subject"
        .Cells(1, 2) = "Received"
        .Cells(1, 3) = "Sender"
    End With
    intRow = 2
    'Write messages to spreadsheet
    For Each olkMsg In Application.ActiveExplorer.CurrentFolder.Items
        'Only export messages, not receipts or appointment requests, etc.
        If olkMsg.Class = olMail Then
            'Add a row for each field in the message you want to export
            excWks.Cells(intRow, 1) = olkMsg.Subject
            excWks.Cells(intRow, 2) = olkMsg.ReceivedTime
            excWks.Cells(intRow, 3) = olkMsg.SenderName
            intRow = intRow + 1
        End If
    Next
    Set olkMsg = Nothing
    excWkb.SaveAs strFilename
    excWkb.Close
End If
Set excWks = Nothing
Set excWkb = Nothing
Set excApp = Nothing
MsgBox "Process complete.  A total of " & intRow - 2 & " messages were exported.", vbInformation + vbOKOnly, "Export messages to Excel"
End Sub

Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
On Error Resume Next
Select Case intOutlookVersion
    Case Is < 14
        If Item.SenderEmailType = "EX" Then
            GetSMTPAddress = SMTP2007(Item)
        Else
            GetSMTPAddress = Item.SenderEmailAddress
        End If
    Case Else
        Set olkSnd = Item.Sender
        If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
            Set olkEnt = olkSnd.GetExchangeUser
            GetSMTPAddress = olkEnt.PrimarySmtpAddress
        Else
            GetSMTPAddress = Item.SenderEmailAddress
        End If
End Select
    On Error GoTo 0
    Set olkPrp = Nothing
    Set olkSnd = Nothing
    Set olkEnt = Nothing
End Function

Function GetOutlookVersion() As Integer
    Dim arrVer As Variant
    arrVer = Split(Outlook.Version, ".")
    GetOutlookVersion = arrVer(0)
End Function

Function SMTP2007(olkMsg As Outlook.MailItem) As String
    Dim olkPA As Outlook.PropertyAccessor
    On Error Resume Next
    Set olkPA = olkMsg.PropertyAccessor
    SMTP2007 = olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x5D01001E")
    On Error GoTo 0
    Set olkPA = Nothing
End Function

但是当我打开下载的文件时，Excel表示文件格式和扩展名不匹配。

什么可能导致这个问题？

Answer 1

更改以下两行：

excWkb.SaveAs strFilename
excWkb.Close

为：

excWkb.SaveAs Filename:=strFilename, FileFormat:=xlCSV, CreateBackup:=False
excWkb.Close SaveChanges:=False

VBA宏 - 导出CSV文件格式和扩展名不匹配

1 个答案: