I have this code
Option Explicit
Sub ReadMessagesFromFolder()
' Define the folder path containing the .msg files
Dim Folder As String
Folder = "D:ll" ' Change this to the desired folder path
' Reference the Microsoft Outlook Object Library
Dim msg As Outlook.MailItem
Dim nextRow As Long
' Loop through all .msg files in the folder
Dim fso As FileSystemObject
Dim msgFile As File
Set fso = New FileSystemObject
For Each msgFile In fso.GetFolder(Folder).Files
If UCase(Right(msgFile.Name, 4)) = ".MSG" Then
' Open the .msg file and extract the required information
Set msg = GetObject(msgFile.Path)
' Add the extracted information to the worksheet
nextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(nextRow, 1).Value = msg.SenderName
Cells(nextRow, 2).Value = msg.Subject
Cells(nextRow, 3).Value = msg.ReceivedTime
Cells(nextRow, 4).Value = msg.SenderEmailAddress
End If
Next msgFile
End Sub
I face this error
Run-Time error '429':
ActiveX component create object
in this row Set msg = GetObject(msgFile.Path)
I already have Microsoft Outlook 16.0 Object Library, please can you help me to fix this
Hi Bill,
Try to change the msg declaration:
Dim msg as Object instead of MailItem.
Or, use:
Dim MyOutlook As Outlook.Application
Dim msg As Outlook.MailItem
Dim x As Namespace
Dim Path As String
Dim i As Long
Set MyOutlook = New Outlook.Application
Set x = MyOutlook.GetNamespace("MAPI")
Dim Folder As String
Folder = "D:ll" ' Change this to the desired folder path
' Loop through all .msg files in the folder
Dim fso As FileSystemObject
Dim msgFile As File, nextRow As Long
Set fso = New FileSystemObject
For Each msgFile In fso.GetFolder(Folder).Files
If UCase(Right(msgFile.Name, 4)) = ".MSG" Then
' Open the .msg file and extract the required information
Set msg = x.OpenSharedItem(msgFile.Path)
' Add the extracted information to the worksheet
nextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(nextRow, 1).Value = msg.SenderName
Cells(nextRow, 2).Value = msg.Subject
Cells(nextRow, 3).Value = msg.ReceivedTime
Cells(nextRow, 4).Value = msg.SenderEmailAddress
End If
Next msgFile
End Sub