Quantcast
Channel: Project Customization and Programming forum
Viewing all articles
Browse latest Browse all 5347

Export Email Properties to Excel

$
0
0

Hi

This is the first time I have used VBA in MS Outlook and have found some code that does most of what I need to do.  However I am struggling to find a line of code that tells me if an email has been replied to and the date and time the reply was sent.  csan anyone help please.  The code I am using is copied below for information:

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 strColA, strColB, strColC, strColD, strColE, strColF, strColG, strColH, strColI, StrColJ As String
 Dim LDate As Date

' Get Excel set up
enviro = CStr(Environ("USERPROFILE"))
'the path of the workbook
 strPath = enviro & "\Outlook to Excel\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("RawData")
    ' Process the message record

    On Error Resume Next
'Find the next empty line of the worksheet
rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(-14162).Row


' get the values from outlook
Set currentExplorer = Application.ActiveExplorer
Set Selection = currentExplorer.Selection
  For Each obj In Selection

    Set olItem = obj

'collect the fields
    strColA = olItem.SenderName
    strColB = olItem.CreationTime
    strColC = olItem.To
    strColD = olItem.Recipients
    strColE = olItem.ReceivedByName
    strColF = olItem.SentOn
    strColG = olItem.ReceivedTime
    strColH = olItem.UnRead
    strColI = olItem.LastModificationTime
    StrColJ = olItem.UserProperties

'Add column Headers to the Excel Extract
  xlSheet.Range("A" & 1) = "Sender Name"
  xlSheet.Range("B" & 1) = "Creation Time"
  xlSheet.Range("C" & 1) = "Sent To"
  xlSheet.Range("D" & 1) = "Recipients"
  xlSheet.Range("E" & 1) = "Received By Name"
  xlSheet.Range("F" & 1) = "Sent On"
  xlSheet.Range("G" & 1) = "Received Time"
  xlSheet.Range("H" & 1) = "UnRead"
  xlSheet.Range("I" & 1) = "Last Modification Time"
  xlSheet.Range("J" & 1) = "User Properties"

'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
  xlSheet.Range("G" & rCount) = strColG
  xlSheet.Range("H" & rCount) = strColH
  xlSheet.Range("I" & rCount) = strColI
  xlSheet.Range("J" & rCount) = StrColJ

'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

Many thanks in anticipation.

Kind regards

Tony


TKHussar


Viewing all articles
Browse latest Browse all 5347

Trending Articles



<script src="https://jsc.adskeeper.com/r/s/rssing.com.1596347.js" async> </script>