Working with ".msg" Items in local folder - vba

I'd like to get some attributes from emails stored in a local folder. I know how to do it for emails in Outlook.folder but I guess the methods are not the same in that case.
I can't find a way to work with the .msg items as if they were emails.
I haven't try anything since I understand the problem comes from object class incompatibility, but I don't know what to use. Also, I couldn't find a guide on ".msg" item, could be useful
Private Sub email_listing()
On Error GoTo ErrHandler
' SET Outlook APPLICATION OBJECT.
Dim objOutlook As Object
Set objOutlook = CreateObject("Outlook.Application")
' CREATE AND SET A NameSpace OBJECT.
Dim objNSpace As Object
' THE GetNameSpace() METHOD WILL REPRESENT A SPECIFIED NAMESPACE.
Set objNSpace = objOutlook.GetNamespace("MAPI")
' CREATE A FOLDER OBJECT.
Dim myFolder, fs As Object
Set fs = CreateObject("Scripting.FileSystemObject")
Set myFolder = fs.GetFolder("C:\Users\boris\Desktop\Mail Test\")
Dim Item As Object
Dim iRows, iCols As Integer
iRows = 2
' LOOP THROUGH EACH ITEM IN THE FOLDER.
For Each Item In myFolder.Files
If Item.Type = "Outlook Item" Then
Dim objMail As Outlook.MailItem
Set objMail = Item 'THE BUG
Cells(iRows, 1) = objMail.SenderEmailAddress
Cells(iRows, 2) = objMail.To
Cells(iRows, 3) = objMail.Subject
Cells(iRows, 4) = objMail.ReceivedTime
Cells(iRows, 5) = objMail.Body
End If
iRows = iRows + 1
Next
Set objMail = Nothing
' RELEASE.
Set objOutlook = Nothing
Set objNSpace = Nothing
Set myFolder = Nothing
ErrHandler:
Debug.Print Err.Description
End Sub
I expect to have the attributes for each mail in my spreadsheet.
So far the code stop at line 27

Use Namespace.OpenSharedItem to open standalone MSG files.

Related

VBA Late Binding for MAC

I need help to make this vba code to work in mac (it's running perfect under windows but I have users that have only mac), the code extracts body data from selected emails in outlook and sends the info to a sheet.
I tried reading all the posts here about late binding and I got how it works, basically not referencing libraries that doesn't exist in mac office versions. I've changed the line that is causing trouble in my code "Dim objMail As Outlook.MailItem" for "Dim objMail As Object" it runs, but the macro goes directly to the msg box line without performing anything (I think ohh is running the code but I've tried debugging it but is not getting any variable or any information when I run it and I didn't get any error msg)
Sub DetailExtraction()
On Error GoTo ErrHandler
Application.ScreenUpdating = False
' SET Outlook APPLICATION OBJECT.
Dim objOutlook As Object
Set objOutlook = CreateObject("Outlook.Application") ' late binding
' CREATE AND SET A NameSpace OBJECT.
Dim objNSpace As Object
' THE GetNameSpace() METHOD WILL REPRESENT A SPECIFIED NAMESPACE.
Set objNSpace = objOutlook.GetNamespace("MAPI")
' CREATE A FOLDER OBJECT.
Dim myFolder As Object
Set myFolder = objNSpace.GetDefaultFolder(olFolderInbox)
Dim Item As Object
Dim iRows, iCols As Integer
iRows = 2
' LOOP THROUGH EACH ITEMS IN THE FOLDER.
'For Each objItem In myFolder.Items
' LOOP THROUGH EACH ITEMS IN THE SELECTION.
For Each objItem In ActiveExplorer.Selection
If objItem.Class = olMail Then
Dim objMail As Outlook.MailItem
Set objMail = objItem
Cells(iRows, 1) = objMail.SenderEmailAddress
Cells(iRows, 2) = objMail.To
Cells(iRows, 3) = objMail.Subject
Cells(iRows, 4) = objMail.ReceivedTime
Cells(iRows, 6) = objMail.Body
Cells(iRows, 6).WrapText = False
'MsgBox Prompt:=objMail.Body
End If
'WRAP UP FILE OFF
' Cells*i.WrapText = False
' SHOW OTHER PROPERTIES, IF YOU WISH.
'Cells(iRows, 6) = objMail.Body
'Cells(iRows, 5) = objMail.CC
'Cells(iRows, 6) = objMail.BCC
'Cells(iRows, 4) = objMail.Recipients(1)
iRows = iRows + 1
Next
Set objMail = Nothing
' RELEASE.
Set objOutlook = Nothing
Set objNSpace = Nothing
Set myFolder = Nothing
ErrHandler:
Debug.Print Err.Description
Application.ScreenUpdating = True
MsgBox "Environments Details Extracted from the Selected Emails (" & iRows - 2 & ")"
End Sub
Thanks in advance!

Folder path to enterprise vault using VBA for email migration

I have a long list of folders and to many rules for outlook to handle using the standard rules manager. I wrote code that would classify and move items to folders but recently I was migrated to an Enterprise Vault. I am trying to find the folder path to update my code. I tried something like
Outlook.Application.GetNamespace("MAPI").Folders("Vault - DOE, JOHN").Folders("My Migrated PSTs").Folders("PR2018")
but honestly I have no idea what the correct path should be. Everything I find online deals with pulling selected items out of the vault and not moving items into it. Below is an excerpt of the existing code. This is on Office 365/Outlook 2016.
Sub Sort_Test(Item)
Dim Msg As Object
Dim Appt As Object
Dim Meet As Object
Dim olApp As Object
Dim objNS As Object
Dim targetFolder As Object
On Error GoTo ErrorHandler
Set Msg = Item
Set PST = Outlook.Application.GetNamespace("MAPI").Folders("PR2018")
checksub = Msg.Subject
checksend = Msg.Sender
checksendname = Msg.SenderName
checksendemail = Msg.SenderEmailAddress
checkbod = Msg.Body
checkto = Msg.To
checkbcc = Msg.BCC
checkcc = Msg.CC
checkcreation = Msg.CreationTime
checksize = Msg.Size
'Classes Folder
If checksub Like "*Files*Lindsey*" Or checksub Like "*Course Login*" _
Or checksend Like "*Award*eBooks*" Then
Set targetFolder = PST.Folders("Education").Folders("Classes")
Msg.Move targetFolder
GoTo ProgramExit
End If
If targetFolder Is Nothing Then
GoTo ProgramExit
' Else
' Msg.Move targetFolder
End If
' Set olApp = Nothing
' Set objNS = Nothing
Set targetFolder = Nothing
Set checksub = Nothing
Set checksend = Nothing
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
Try this code:
Sub MoveToFolder()
Dim olApp As New Outlook.Application
Dim olNameSpace As Outlook.NameSpace
Dim olArcFolder As Outlook.MAPIFolder
Dim olCompFolder As Outlook.MAPIFolder
Dim mailboxNameString As String
Dim myInspectors As Outlook.MailItem
Dim myCopiedInspectors As Outlook.MailItem
Dim myItem As Outlook.MailItem
Dim M As Integer
Dim iCount As Integer
Set olNameSpace = olApp.GetNamespace("MAPI")
Set olArcFolder = olNameSpace.Folders("Emails Stored on Computer").Folders("Archived")
Set olCompFolder = olNameSpace.Folders("Emails Stored on Computer").Folders("Computer")
For M = 1 To olArcFolder.items.Count
Set myItem = olArcFolder.items(M)
myItem.Display
Set myInspectors = Outlook.Application.ActiveInspector.CurrentItem
Set myCopiedInspectors = myInspectors.copy
myCopiedInspectors.Move olCompFolder
myInspectors.Close olDiscard
Next M
Here is a link for you reference:
Do for all open emails and move to a folder

Outlook access shared inbox sub-folder

I have a strange issue on the below code I use for extracting Outlook email information into Excel. Sometimes the code works perfectly but other times I get the Run-Time Error '-2147221233 (8004010f)'. When I do get this error it is the line Set objFolder = objMailbox.Folders("Inbox").Folders("ARCHIVE") that has the issue.
I am running the code on a shared inbox and I have the "ARCHIVE" folder as a sub-folder of the inbox. It is as if the code cannot find the folder even though it is there and it can find it sometimes.
My uneducated guess is that, since a shared inbox can have a delay updating across all users, if there is any action in the folder the code cannot recognize the folder until it refreshes or updates on the server.
Can anybody suggest slightly different code so that it will run every time? Or does anybody have an explanation as to why it only occasionally works as is?
Sub EmailStatsV3()
'Working macro for exporting specific sub-folders of a shared inbox
Dim olMail As Variant
Dim aOutput() As Variant
Dim lCnt As Long
Dim xlApp As Excel.Application
Dim xlSh As Excel.Worksheet
Dim flInbox As Folder
'Gets the mailbox and shared folder inbox
Dim myNamespace As Outlook.NameSpace
Dim myRecipient As Outlook.Recipient
Set myNamespace = Application.GetNamespace("MAPI")
Set myRecipient = myNamespace.CreateRecipient("Operations")
Set objOutlook = CreateObject("Outlook.Application")
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objInbox = objNamespace.GetSharedDefaultFolder(myRecipient, olFolderInbox)
'Uses the Parent of the Inbox to specify the mailbox
strFolderName = objInbox.Parent
'Specifies the folder (inbox or other) to pull the info from
Set objMailbox = objNamespace.Folders(strFolderName)
Set objFolder = objMailbox.Folders("Inbox").Folders("ARCHIVE") 'Change this line to specify folder
Set colItems = objFolder.Items
'Specify which email items to extract
ReDim aOutput(1 To objFolder.Items.Count, 1 To 10)
For Each olMail In objFolder.Items
If TypeName(olMail) = "MailItem" Then
lCnt = lCnt + 1
aOutput(lCnt, 1) = olMail.SenderEmailAddress 'Sender or SenderName also gives similar output
aOutput(lCnt, 2) = olMail.ReceivedTime 'stats on when received
aOutput(lCnt, 3) = olMail.ConversationTopic 'group based on subject w/o regard to prefix
aOutput(lCnt, 4) = olMail.Subject 'to split out prefix
aOutput(lCnt, 5) = olMail.Categories 'to split out category
aOutput(lCnt, 6) = olMail.Sender
aOutput(lCnt, 7) = olMail.SenderName
aOutput(lCnt, 8) = olMail.To
aOutput(lCnt, 9) = olMail.CC
aOutput(lCnt, 10) = objFolder.Name
End If
Next
'Creates a blank workbook in excel then inputs the info from Outlook
Set xlApp = New Excel.Application
Set xlSh = xlApp.Workbooks.Add.Sheets(1)
xlSh.Range("A1").Resize(UBound(aOutput, 1), UBound(aOutput, 2)).Value = aOutput
xlApp.Visible = True
End Sub
I am assuming you are running the code from Outlook, see the cleanup I did.
Option Explicit
Sub EmailStatsV3()
Dim Item As Object
Dim varOutput() As Variant
Dim lngcount As Long
Dim xlApp As Excel.Application
Dim xlSht As Excel.Worksheet
Dim ShareInbox As Outlook.MAPIFolder
Dim olNs As Outlook.NameSpace
Dim olRecip As Outlook.Recipient
Dim SubFolder As Object
Set olNs = Application.GetNamespace("MAPI")
Set olRecip = olNs.CreateRecipient("0m3r#Email.com") '// Owner's Name or email address
Set ShareInbox = olNs.GetSharedDefaultFolder(olRecip, olFolderInbox)
Set SubFolder = ShareInbox.Folders("Temp") 'Change this line to specify folder
ReDim varOutput(1 To SubFolder.Items.Count, 1 To 10)
For Each Item In SubFolder.Items
If TypeName(Item) = "MailItem" Then
lngcount = lngcount + 1
varOutput(lngcount, 1) = Item.SenderEmailAddress 'Sender or SenderName
varOutput(lngcount, 2) = Item.ReceivedTime 'stats on when received
varOutput(lngcount, 3) = Item.ConversationTopic 'Conversation subject
varOutput(lngcount, 4) = Item.Subject 'to split out prefix
varOutput(lngcount, 5) = Item.Categories 'to split out category
varOutput(lngcount, 6) = Item.Sender
varOutput(lngcount, 7) = Item.SenderName
varOutput(lngcount, 8) = Item.To
varOutput(lngcount, 9) = Item.CC
varOutput(lngcount, 10) = SubFolder.Name
End If
Next
'Creates a blank workbook in excel
Set xlApp = New Excel.Application
Set xlSht = xlApp.Workbooks.Add.Sheets(1)
xlSht.Range("A1").Resize(UBound(varOutput, 1), _
UBound(varOutput, 2)).Value = varOutput
xlApp.Visible = True
End Sub

how to pull received time from all emails in outlook mailbox

I have most of this worked out already, but need assistance. I want to store all of the received times of the emails from various outlook folders. All of the folders are inside the same folder so I have an array to go through each of these. I need the times stored into a variable that I can then display in or write.console. There will be hundreds of times to display. The variable is Totalmsg that I want these times stored in, then displayed once complete.
Sub EmailArrivalTimes()
Dim objOutlook As Object, objnSpace As Object, objFolder As MAPIFolder
Dim MailItem
Dim EmailCount() As Integer, arrNames
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")
arrNames = Array ("Andrew", "Ashton", "Becca", "Beth", "Bree", "Brittany", "Cecilia", "Chance", "Christina J.", "Christine", "Dustin", "James", "Jeff", "Jenni", "Jennifer W.", "Josh", "Josie", "Kara", "Lisa", "Megan", "Misti", "Nathan", "Paul", "Sam", "Shane", "Shawna") 'add other names here...
ReDim EmailCount(LBound(arrNames) To UBound(arrNames))
For x = LBound(arrNames) To UBound(arrNames)
On Error Resume Next
Set objFolder = objnSpace.Folders("Mailbox - IT Support Center"). _
Folders("Onshore - " & arrNames(x)).Folders("completed")
On Error GoTo 0
ArrivalTime = 0
Dim Totalmsg
If Not objFolder Is Nothing Then
For Each MailItem In objFolder.Items
Totalmsg = MailItem.ReceivedTime
Next
End If
Set OutMail = Nothing
Set OutApp = Nothing
Set objFolder = Nothing
Set objnSpace = Nothing
Set objOutlook = Nothing
End Sub
Right now you are overwriting the value of TotalMsg at each iteration in this loop:
If Not objFolder Is Nothing Then
For Each MailItem In objFolder.Items
Totalmsg = MailItem.ReceivedTime
Next
End If
You will want to append to it, instead:
If Not objFolder Is Nothing Then
For Each MailItem In objFolder.Items
Totalmsg = TotalMsg & vbCRLF & MailItem.ReceivedTime
Next
End If
Debug.Print TotalMsg
'Note: this will likely exceed what can fit in the console window, _
' but you can instead write the string to a text file/etc.

Accessing another maibox in outlook using vba

I have two mailboxes in my Outlook.
One that is mine and it automatically logs me in when I log in to my pc and another I have that is for mail bounces.
I really need to access the inbox of the mail's account but I just can't seem to do it.
And there is no way I can make the mailbox of the mail account to be my default mailbox
Here is the code I have so far:
Public Sub GetMails()
Dim ns As NameSpace
Dim myRecipient As Outlook.Recipient
Dim aFolder As Outlook.Folders
Set ns = GetNamespace("MAPI")
Set myRecipient = ns.CreateRecipient("mail#mail.pt")
myRecipient.Resolve
If myRecipient.Resolved Then
MsgBox ("Resolved")
Set aFolder = ns.GetSharedDefaultFolder(myRecipient, olFolderInbox)
Else
MsgBox ("Failed")
End If
End Sub
The problem I am getting is at the
Set aFolder = ns.GetSharedDefaultFolder(myRecipient, olFolderInbox)
I get the Resolved msgbox so I know that is working but after that I get an error:
Run-Time Error
which doesn't say much about the error itself.
Can anyone help me out here please?
Thanks
If the folder you wish to access is not an Exchange folder, you will need to find it, if it is an Exchange folder, try logging on to the namespace.
Log on to NameSpace
Set oNS = oApp.GetNamespace("MAPI")
oNS.Logon
Find Folder
As far as I recall, this code is from Sue Mosher.
Public Function GetFolder(strFolderPath As String) As Object 'MAPIFolder
' strFolderPath needs to be something like
' "Public Folders\All Public Folders\Company\Sales" or
' "Personal Folders\Inbox\My Folder" ''
Dim apOL As Object 'Outlook.Application '
Dim objNS As Object 'Outlook.NameSpace '
Dim colFolders As Object 'Outlook.Folders '
Dim objFolder As Object 'Outlook.MAPIFolder '
Dim arrFolders() As String
Dim I As Long
On Error GoTo TrapError
strFolderPath = Replace(strFolderPath, "/", "\")
arrFolders() = Split(strFolderPath, "\")
Set apOL = CreateObject("Outlook.Application")
Set objNS = apOL.GetNamespace("MAPI")
On Error Resume Next
Set objFolder = objNS.Folders.Item(arrFolders(0))
If Not objFolder Is Nothing Then
For I = 1 To UBound(arrFolders)
Set colFolders = objFolder.Folders
Set objFolder = Nothing
Set objFolder = colFolders.Item(arrFolders(I))
If objFolder Is Nothing Then
Exit For
End If
Next
End If
Set GetFolder = objFolder
Set colFolders = Nothing
Set objNS = Nothing
Set apOL = Nothing
End Function