Question

我有一个宏，它将Outlook INBOX 中的所有数据与时间和日期一起导出到Excel，但我需要设置为以相同方式复制的特定文件夹。

如何设置特定子文件夹？

Option Explicit
Sub CopyToExcel()
    Dim xlApp As Object
    Dim xlWB As Object
    Dim xlSheet As Object
    Dim rCount As Long
    Dim bXStarted As Boolean
    Dim enviro As String
    Dim strPath As String
    Dim objOL As Outlook.Application
    Dim objFolder As Outlook.MAPIFolder
    Dim objItems As Outlook.Items
    Dim obj As Object
    Dim olItem 'As Outlook.MailItem
    Dim strColA, strColB, strColC, strColD, strColE, strColF As String

    ' Get Excel set up
    enviro = CStr(Environ("USERPROFILE"))

    'the path of the workbook
    strPath = enviro & "\Documents\Book1.xlsx"

    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

    On Error Resume Next
    ' Open the workbook to input the data
    ' Create workbook if doesn't exist
    Set xlWB = xlApp.Workbooks.Open(strPath)
    If Err <> 0 Then
        Set xlWB = xlApp.Workbooks.Add
        xlWB.SaveAs FileName:=strPath
    End If
    On Error GoTo 0

    Set xlSheet = xlWB.Sheets("Sheet1")

    On Error Resume Next
    ' add the headers if not present
    If xlSheet.Range("A1") = "" Then
        xlSheet.Range("A1") = "Sender Name"
        xlSheet.Range("B1") = "Sender Email"
        xlSheet.Range("C1") = "Subject"
        xlSheet.Range("D1") = "Body"
        xlSheet.Range("E1") = "Sent To"
        xlSheet.Range("F1") = "Date"
    End If

    'Find the next empty line of the worksheet
    rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).Row

    ' needed for Exchange 2016. Remove if causing blank lines.
    rCount = rCount + 1

    ' get the values from outlook
    Set objOL = Outlook.Application
    Set objFolder = objOL.ActiveExplorer.CurrentFolder
    Set objItems = objFolder.Items

    For Each obj In objItems
        Set olItem = obj

        'collect the fields
        strColA = olItem.SenderName
        strColB = olItem.SenderEmailAddress
        strColC = olItem.Subject
        strColD = olItem.Body
        strColE = olItem.To
        strColF = olItem.ReceivedTime


        ' Get the Exchange address
        ' if not using Exchange, this block can be removed
        Dim olEU As Outlook.ExchangeUser
        Dim oEDL As Outlook.ExchangeDistributionList
        Dim recip As Outlook.Recipient

        Set recip = Application.Session.CreateRecipient(strColB)

        If InStr(1, strColB, "/") > 0 Then
            ' if exchange, get smtp address
            Select Case recip.AddressEntry.AddressEntryUserType
                Case OlAddressEntryUserType.olExchangeUserAddressEntry
                Set olEU = recip.AddressEntry.GetExchangeUser

                If Not (olEU Is Nothing) Then
                    strColB = olEU.PrimarySmtpAddress
                End If

                Case OlAddressEntryUserType.olOutlookContactAddressEntry
                    Set olEU = recip.AddressEntry.GetExchangeUser

                    If Not (olEU Is Nothing) Then
                        strColB = olEU.PrimarySmtpAddress
                    End If

                Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
                    Set oEDL = recip.AddressEntry.GetExchangeDistributionList

                    If Not (oEDL Is Nothing) Then
                        strColB = olEU.PrimarySmtpAddress
                    End If
            End Select
        End If
        ' End Exchange section

        'write them in the excel sheet
        xlSheet.Range("A" & rCount) = strColA
        xlSheet.Range("B" & rCount) = strColB
        xlSheet.Range("c" & rCount) = strColC
        xlSheet.Range("d" & rCount) = strColD
        xlSheet.Range("e" & rCount) = strColE
        xlSheet.Range("f" & rCount) = strColF

        'Next row
        rCount = rCount + 1
        xlWB.Save
    Next

    ' don't wrap lines
    xlSheet.Rows.WrapText = False

    xlWB.Save
    xlWB.Close 1
    If bXStarted Then
        xlApp.Quit
    End If

    Set olItem = Nothing
    Set obj = Nothing
    Set xlApp = Nothing
    Set xlWB = Nothing
    Set xlSheet = Nothing
End Sub

Answer 1

您在代码中使用 ActiveExplorer.CurrentFolder ，CurrentFolder Property表示资源管理器中显示的当前文件夹，代码应在任何{{3}上运行 - 只需导航您想要运行代码的任何文件夹。

如果您想更改，则需要修改以下代码行来设置指定的文件夹，

' get the values from outlook
Set objOL = Outlook.Application
Set objFolder = objOL.ActiveExplorer.CurrentFolder

这样的事情

' get the values from outlook
Set objOL = Outlook.Application
Dim olNs As Outlook.NameSpace
Set olNs = objOL.GetNamespace("MAPI")
Set objFolder = olNs.GetDefaultFolder(olFolderInbox).Folders("SubFolder Name Here")

_{请参阅Active Explorer使用NameSpace对象的文件夹属性或其他Folder对象返回NameSpace或文件夹下的文件夹集。您可以通过从顶级文件夹（例如收件箱）开始，并使用Folder.Folders属性的组合来导航嵌套文件夹，该属性返回层次结构中Folder对象下面的文件夹集，}

示例：的

GetDefaultFolder(olFolderInbox).Folders("SubFolderName") _
                              .Folders("SubFolderName")

_{和Folders.Item方法，它返回文件夹集合中的文件夹。}

如何将特定文件夹中的所有邮件从Outlook导出到Excel

1 个答案: