View Single Post
 
Old 08-12-2023, 02:44 AM
gmayor's Avatar
gmayor gmayor is offline Windows 10 Office 2019
Expert
 
Join Date: Aug 2014
Posts: 4,137
gmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud of
Default

Maybe something like
Code:
Sub CopyInboxMsgDataToExcel()
Dim xlApp As Object
Dim xlWb As Object
Dim xlSheet As Object
Dim olItems As Outlook.Items
Dim olItem As Outlook.MailItem
Dim sFrom As String
Dim sDate As String
Dim sSubject As String
Dim rCount As Long
Dim bXStarted As Boolean
Dim FSO As Object
Dim lCount As Long

Const strPath As String = "C:\Path\Inbox.xlsx"        'the path of the workbook

    If Application.ActiveExplorer.Selection.Count = 0 Then
        MsgBox "No Items selected!", vbCritical, "Error"
        Exit Sub
    End If
    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

    Set FSO = CreateObject("Scripting.FileSystemObject")
    If Not FSO.FileExists(strPath) Then
        Set xlWb = xlApp.Workbooks.Add
        Set xlSheet = xlWb.Sheets("Sheet1")
        With xlSheet
            .Range("A1").Value = "From"
            .Range("B1").Value = "Date"
            .Range("C1").Value = "CSubject"
        End With
        xlWb.SaveAs strPath
    Else
        'Open the workbook to input the data
        Set xlWb = xlApp.Workbooks.Open(strPath)
        Set xlSheet = xlWb.Sheets("Sheet1")
    End If
    xlApp.Visible = True
    Set olItems = Session.GetDefaultFolder(olFolderInbox).Items
    For lCount = olItems.Count To 1 Step -1
        Set olItem = olItems(lCount)
        If TypeName(olItem) <> "Nothing" Then
            On Error GoTo Skip
            sFrom = olItem.Sender
            sDate = CStr(olItem.SentOn)
            sSubject = olItem.Subject
            'Find the next empty line of the worksheet
            rCount = xlSheet.Range("A" & xlSheet.Rows.Count).End(-4162).Row
            rCount = rCount + 1
            xlSheet.Range("A" & rCount) = sFrom
            xlSheet.Range("B" & rCount) = sDate
            xlSheet.Range("C" & rCount) = sSubject
            xlWb.Save
            DoEvents
        End If
Skip:
        On Error Resume Next
    Next lCount
    xlWb.Close SaveChanges:=True
    If bXStarted Then
        xlApp.Quit
    End If
    Set xlApp = Nothing
    Set xlWb = Nothing
    Set xlSheet = Nothing
    Set olItem = Nothing
    Set olItems = Nothing
lbl_Exit:
    Exit Sub
End Sub
__________________
Graham Mayor - MS MVP (Word) (2002-2019)
Visit my web site for more programming tips and ready made processes www.gmayor.com
Reply With Quote