하위 폴더를 포함한 폴더의 모든 Outlook 전자 메일을 반복 할 수 있습니까?

Question

나는 다수 전자 우편과 서브 폴더를 포함하는 폴더가있다. 그 하위 폴더에는 전자 메일이 더 있습니다.

하위 폴더에있는 메일을 포함하여 특정 폴더의 모든 이메일을 반복하는 VBA를 작성하고 싶습니다. 아이디어는 각 전자 우편에서 SenderEmailAddress와 SenderName를 추출하고 그것으로 무언가를하기위한 것이다.

나는이 두 필드만으로 CSV로 폴더를 내보내려고했지만이 방법은 작동하지만 하위 폴더에있는 전자 메일 내보내기는 지원하지 않습니다. 따라서 VBA를 작성할 필요가 있습니다.

나는 다시 발명 바퀴를, 사람이 폴더 이름 부여, 해당 폴더 및 이후의 하위 폴더에있는 모든 이메일에 대한 MailItem 개체를 가져 오는 방법을 보여줍니다있는 사이트에 대한 코드 조각 또는 링크가 않습니다 가기 전에 ?

Answer 1

이런 식으로 뭔가 ...

Private Sub processFolder(ByVal oParent As Outlook.MAPIFolder) 

     Dim oFolder As Outlook.MAPIFolder 
     Dim oMail As Outlook.MailItem 

     For Each oMail In oParent.Items 

     'Get your data here ... 

     Next 

     If (oParent.Folders.Count > 0) Then 
      For Each oFolder In oParent.Folders 
       processFolder oFolder 
      Next 
     End If 
End Sub 

Answer 2

이 당신이에 관심이있는 좋은 코드를 많이 가지고 있습니다. 매크로로 전망/VBA에서 실행 이동합니다.

Const MACRO_NAME = "OST2XLS" 

Dim excApp As Object, _ 
    excWkb As Object, _ 
    excWks As Object, _ 
    intVersion As Integer, _ 
    intMessages As Integer, _ 
    lngRow As Long 

Sub ExportMessagesToExcel() 
    Dim strFilename As String, olkSto As Outlook.Store 
    strFilename = InputBox("Enter a filename (including path) to save the exported messages to.", MACRO_NAME) 
    If strFilename <> "" Then 
     intMessages = 0 
     intVersion = GetOutlookVersion() 
     Set excApp = CreateObject("Excel.Application") 
     Set excWkb = excApp.Workbooks.Add 
     For Each olkSto In Session.Stores 
      Set excWks = excWkb.Worksheets.Add() 
      excWks.Name = "Output1" 
      'Write Excel Column Headers 
      With excWks 
       .Cells(1, 1) = "Folder" 
       .Cells(1, 2) = "Sender" 
       .Cells(1, 3) = "Received" 
       .Cells(1, 4) = "Sent To" 
       .Cells(1, 5) = "Subject" 
      End With 
      lngRow = 2 
      ProcessFolder olkSto.GetRootFolder() 
     Next 
     excWkb.SaveAs strFilename 
    End If 
    Set excWks = Nothing 
    Set excWkb = Nothing 
    excApp.Quit 
    Set excApp = Nothing 
    MsgBox "Process complete. A total of " & intMessages & " messages were exported.", vbInformation + vbOKOnly, "Export messages to Excel" 
End Sub 

Sub ProcessFolder(olkFld As Outlook.MAPIFolder) 
    Dim olkMsg As Object, olkSub As Outlook.MAPIFolder 
    'Write messages to spreadsheet 
    For Each olkMsg In olkFld.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(lngRow, 1) = olkFld.Name 
      excWks.Cells(lngRow, 2) = GetSMTPAddress(olkMsg, intVersion) 
      excWks.Cells(lngRow, 3) = olkMsg.ReceivedTime 
      excWks.Cells(lngRow, 4) = olkMsg.ReceivedByName 
      excWks.Cells(lngRow, 5) = olkMsg.Subject 
      lngRow = lngRow + 1 
      intMessages = intMessages + 1 
     End If 
    Next 
    Set olkMsg = Nothing 
    For Each olkSub In olkFld.Folders 
     ProcessFolder olkSub 
    Next 
    Set olkSub = Nothing 
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