VBA Outlook - Exportando Campos para o Excel

VBA Outlook - Exportando Campos para o Excel

Vou poupar seu tempo e vamos direto ao código. Explore à vontade!

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 currentExplorer As Explorer

 Dim Selection As Selection

 Dim olItem As Outlook.MailItem

 Dim obj As Object

 Dim strColB, strColC, strColD, strColE, strColF As String

               

' Get Excel set up

enviro = CStr(Environ("USERPROFILE"))

'the path of the workbook

 strPath = enviro & "\Documents\test.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

     'Open the workbook to input the data

     Set xlWB = xlApp.Workbooks.Open(strPath)

     Set xlSheet = xlWB.Sheets("Sheet1")

    ' Process the message record

    

    On Error Resume Next

'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 currentExplorer = Application.ActiveExplorer

Set Selection = currentExplorer.Selection

  For Each obj In Selection

    Set olItem = obj

    

 'collect the fields

    strColC = olItem.SenderEmailAddress

    strColB = olItem.SenderName

    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(strColC)

 If InStr(1, strColC, "/") > 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

             strColC = olEU.PrimarySmtpAddress

         End If

       Case OlAddressEntryUserType.olOutlookContactAddressEntry

         Set olEU = recip.AddressEntry.GetExchangeUser

         If Not (olEU Is Nothing) Then

            strColC = olEU.PrimarySmtpAddress

         End If

       Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry

         Set oEDL = recip.AddressEntry.GetExchangeDistributionList

         If Not (oEDL Is Nothing) Then

            strColC = olEU.PrimarySmtpAddress

         End If

     End Select

End If

' End Exchange section

'write them in the excel sheet

  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

 Next

     xlWB.Close 1

     If bXStarted Then

         xlApp.Quit

     End If

    

     Set olItem = Nothing

     Set obj = Nothing

     Set currentExplorer = Nothing

     Set xlApp = Nothing

     Set xlWB = Nothing

     Set xlSheet = Nothing

 End Sub

Envie seus comentários e sugestões e compartilhe este artigo!

brazilsalesforceeffectiveness@gmail.com