Question

我正在尝试创建一些宏来帮助跟踪我的工作的多个共享邮箱。我对此缺乏经验，所以我所有的一切都是通过搜索这个网站和谷歌。我已经创建了一个将电子邮件复制到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 ns As Outlook.NameSpace
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

Set ns = Application.GetNamespace("MAPI")

' Get Excel set up
enviro = CStr(Environ("USERPROFILE"))
'the path of the workbook
strPath = "H:\Test\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 = ns.Folder("shadow.customer.claims.legal.requests@blank.com\Inbox")
    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

循环访问NameSpace.Accounts集合，直到找到其他邮箱的Account对象。然后使用Account.DeliveryStore获取Store对象，并使用Store.GetDefaultFolder获取收件箱，然后使用Folder.Folders（＆＃34; FolderName＆＃34;）获取所需的文件夹。

宏将电子邮件从共享邮箱子文件夹复制到Excel

1 个答案: