VBA选择从中下载电子邮件的帐户[重复]

Question

从事一些小项目，从 Outlook 2013 下载数据，但我被困在一个地方，我可以更改 Outlook 帐户，然后下载他们的收件箱/已发送邮件/等。

有问题的地方是确定文件夹和电子邮件的那些****在哪里（语法有误）-我需要帮助。

Sub export_mail_from_outlook()

Dim objItm As Object
Dim objFolder As Folder
Dim xlApp As Excel.Application
Dim xlWb As Excel.Workbook
Dim objParent As Folder
Dim lRow As Long
Dim epasts As String, mape As String

    epasts = ThisWorkbook.Sheets("Main desk").Cells(5, 2)
    mape = ThisWorkbook.Sheets("Main desk").Cells(6, 2)

'Izveidojam jaunu failu un sheetu, kur liksim vajadzigo informaciju
    Set xlApp = New Excel.Application
    Set xlWb = xlApp.Workbooks.Add
    Set xlSht = xlWb.Sheets(1)
'nosaucam faila ieklauto sheetu/izklajlapu
    xlSht.Name = "Inbox Mail Data"
'konkretaja sheet/izklajlapa definejam pirmas rindas/kolonnu nosaukumus(bez si var ari iztikt, tikai tad ir jamaian lRow vertiba)
    With xlSht
        .Cells(1, 1) = "Mape"
        .Cells(1, 2) = "Tēma"
        .Cells(1, 3) = "E-pasta saņemšanas datums"
        .Cells(1, 4) = "Teksts"
        .Cells(1, 5) = "Sūtītājs"
        .Cells(1, 6) = "Izmantotais epasts"
    End With

'mapes dzilumu mainit saja vieta, var nemt visu, kas ir tikai Inbox mape,
'var nemt visus, kas ir mapes apaksmape,
'un var nemt mapes un apaksmapes epastus
    ****Set objOutlook = CreateObject("Outlook.Application")
    ****Set objNameSpace = objOutlook.GetNamespace("MAPI")
    ****Set objParent = objNameSpace.GetDefaultFolder(olFolderInbox)


'no kuras rindas saks ladet datus
    lRow = 2

'datuma ierobezojums ierakstiem, visus ierakstus pec konkreta datuma, likt pec vajadzibas(var ari izveidot msgbox un ielasit vertibu, tad sintake bus sekojosa(pielabot)

    StrDate = InputBox("No kura datuma ielasīt e-pastus. Datuma forma: yyyy.mm.dd ?")
    If IsDate(StrDate) Then
    LimDate = DateValue(StrDate)
    Else: MsgBox "Nav pareizs datuma formāts, mēgini vēlreiz"
    Exit Sub
    End If

    'LimDate = VBA.DateValue(DateSerial(2016, 3, 1))

        On Error Resume Next
        With xlSht
            For Each objItm In objParent.Items
            If objItm.ReceivedTime >= LimDate Then
                .Cells(lRow, 1) = objParent
                .Cells(lRow, 2) = objItm.Subject
                .Cells(lRow, 3) = objItm.ReceivedTime
                .Cells(lRow, 4) = objItm.Body
                .Cells(lRow, 4).WrapText = False
                .Cells(lRow, 5) = objItm.Sender
                .Cells(lRow, 6) = epasts

                lRow = lRow + 1
            End If
            Next
        End With
        On Error GoTo 0


'izveidoto failu padarit redzamu
xlApp.Visible = True


Set xlSht = Nothing
Set xlWb = Nothing
Set xlApp = Nothing

MsgBox "No " & LimDate & " visi mapes " & objParent & " epasta ieraksti no epasta " & epasts

End Sub

多个帐户 - 多个收件箱文件夹 - 在代码中指定电子邮件并下载

Answer 1

不要使用Namespace.GetDefaultFolder，而是循环访问Namespace.Stores 集合（Outlook 2010 及更高版本），找到您需要处理的商店，使用Store.GetDefaultFolder。