2017-04-12 40 views
1

我试图创建几个宏来帮助跟踪我的工作的多个共享邮箱。我对这件事毫无经验,所以我所做的一切都是通过搜索这个网站和谷歌。我创建了一个宏将复制电子邮件到Excel,但我无法弄清楚如何指定只从共享邮箱收件箱子文件夹拉。任何建议将不胜感激!将共享邮箱子文件夹中的电子邮件复制到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("[email protected]\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 
+2

相似的一个在这里http://stackoverflow.com/questions/43273441/import-emails-from-specific-folder-in-outlook/43274160#43274160 –

+0

同意Erdem - 我正在做一些类似的Powershell和Microsoft.Office.Interop.Outlook。我只需要在一个文件夹上使用“文件夹”属性并选择具有正确名称的文件夹即可导航到子文件夹。 – phhlho

+0

谢谢我对代码做了一些更改,以选择哪个共享收件箱可以从日期范围中提取,但是我在excel文件中获得零输出任何建议? –

回答

0

循环浏览NameSpace.Accounts集合,直到找到其他邮箱的Account对象。然后使用Account.DeliveryStore获取Store对象,并使用Store.GetDefaultFolder获取收件箱,然后使用Folder.Folders(“FolderName”)获取所需的文件夹。

+0

海报想要知道如何访问另一个邮箱中的文件夹,并且我的答案是使用方法 –

相关问题