Some more VBA Code

[danny8890]

Hi Again,

Finding this forum really useful and some great people on here, learnt alot over the last few days.

Looking for some help again, Below is some code that extracts emails from Outlook and puts them into cells in Excel.

Hoping someone can tidy up the code to make it run faster and also so i don't have to highlight all the emails in the folder first.

Thanks in advance

Option ExplicitSub CopyToExcel()
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim rCount As Long
Dim bXStarted As Boolean
Dim strPath As String


Dim currentExplorer As Explorer
Dim Selection As Selection
Dim olItem As Outlook.MailItem
Dim obj As Object
Dim strColA, strColB, strColC, strColD, strColE, strColF As String
               
' Get Excel set up


'the path of the workbook
strPath = "[COLOR=#ff0000]Insert File Path Name[/COLOR]"
     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
    strColA = olItem.Subject
    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("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


Next


  With xlWB.Sheets(1)
    .Range("A:F").WrapText = False
    
End With


     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
     
     
' Show summary message
        MsgBox "Finished" _
    


    
 End Sub

 

[ranman256]

the path of the excel file...

strPath = "c:\folder\myFile.xls"

 

[danny8890]

the path of the excel file...

strPath = "c:\folder\myFile.xls"

Hi, i removed this before posting the code has the file path contains some confidential information, I am looking to see if someone can re-write the code to make it more efficient than it currently is

 

[danny8890]

Is anyone able to assist?, would really appreciate if someone would be able to tidy this up for me.

Thanks