Shared mailbox name: trvx-prog.obs#orange.com
I need:
to access folders Madhvi and P_Wardah with their four sub folders
set a date range for report extraction (with the subject, sender, date sent, folder name we are accessing)
automate to run each week
I am not able to access the second folder and the subfolders
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("trvx-prog.obs#orange.com") '// Owner's Name or email address
Set ShareInbox = olNs.GetSharedDefaultFolder(olRecip, olFolderInbox)
Set SubFolder = ShareInbox.Folders("P_Wardah")
ReDim varOutput(1 To SubFolder.Items.Count, 1 To 4)
For Each Item In SubFolder.Items
If TypeName(Item) = "MailItem" Then
lngcount = lngcount + 1
varOutput(lngcount, 1) = Item.ReceivedTime 'stats on when received
varOutput(lngcount, 2) = Item.Subject 'to split out prefix
varOutput(lngcount, 3) = Item.Sender
varOutput(lngcount, 4) = 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
Received details of only folder P_Wardah
Need to access the folder of Madhvi
Need to access the sub folders of P_Wardah and Madhvi which are (Treated, No Perimeter, Follow Up, Pending)
Need to classify them for a date range of each week
This is not a full answer - Just an aid to help you move forward
You also need a loop to iterate through all the sub folders of SubFolder
Eg
For Each xFldr In SubFolder.Folders
' Recursive Call to process xFldr
Next
So your folder processing routine needs to be in a Sub of it's own and then call itself (recursive call)
Related
We have a project at work and basically it should do the following:
Loop through all Outlook items (main email account and its sub folders)
Loop through all Outlook items (user created Data Files (PST files) and its sub folders)
The two loops above should exclude the Yammer Root, Sync Issues, Contacts, and Calendar folders
Find emails with email bodies that contain a certain text (e.g. XXX-YY-2020777), this is for me the most important code
Print these in the worksheet:
main folder - sub folder
sender
email subject
date received
So I found a post useful here, credits to Keith Whatling:
Sub GetEmail()
Dim OutApp As Outlook.Application
Dim Namespace As Outlook.Namespace
Dim Mfolder As Outlook.MAPIFolder
Dim myMail As Outlook.Items
Dim Folder As Outlook.MAPIFolder
Dim SubFolder As Outlook.MAPIFolder
Dim UserFolder As Outlook.MAPIFolder
Set OutApp = New Outlook.Application
Set Namespace = OutApp.GetNamespace("MAPI")
On Error Resume Next
For Each Folder In Namespace.Folders
For Each SubFolder In Folder.Folders
For Each UserFolder In SubFolder.Folders
Debug.Print Folder.Name, "|", SubFolder.Name, "|", UserFolder.Name
Next UserFolder
Next SubFolder
Next Folder
On Error GoTo 0
End Sub
I can combine these two posts:
https://www.encodedna.com/excel/how-to-parse-outlook-emails-and-show-in-excel-worksheet-using-vba.htm
and
Excel vba: Looping through all subfolders in Outlook email to find an email with certain subject
But I need some guidance so I can start this.
I started with
Sub GetEmailTesting()
Dim outlook_app As Outlook.Application
Dim namespace As Outlook.namespace
Set outlook_app = New Outlook.Application
Set namespace = outlook_app.GetNamespace("MAPI")
Dim main_folder As Outlook.MAPIFolder
Dim sub_folder1 As Outlook.MAPIFolder
Dim sub_folder2 As Outlook.MAPIFolder
Dim sub_folder3 As Outlook.MAPIFolder
On Error Resume Next
For Each main_folder In namespace.Folders
' code goes here
For Each sub_folder1 In main_folder.Folders
' code goes here
For Each sub_folder2 In sub_folder1.Folders
' code goes here
For Each sub_folder3 In sub_folder2.Folders
Dim rowNumber As Integer
rowNumber = 2
For Each obj_item In sub_folder3.Items
If obj_item.Class = olMail Then
Dim obj_mail As Outlook.MailItem
Set obj_mail = obj_item
Cells(rowNumber, 1) = obj_mail.SenderEmailAddress
Cells(rowNumber, 2) = obj_mail.To
Cells(rowNumber, 3) = obj_mail.Subject
Cells(rowNumber, 4) = obj_mail.ReceivedTime
End If
rowNumber = rowNumber + 1
Next
Next sub_folder3
Next sub_folder2
Next sub_folder1
Next main_folder
On Error GoTo 0
End Sub
Do I have to insert this in every FOR EACH loop (main folder, subfolder1, subfolder2, subfolder3, and so on and so forth... ?
For Each obj_item In sub_folder3.Items
If obj_item.Class = olMail Then
Dim obj_mail As Outlook.MailItem
Set obj_mail = obj_item
Cells(rowNumber, 1) = obj_mail.SenderEmailAddress
Cells(rowNumber, 2) = obj_mail.To
Cells(rowNumber, 3) = obj_mail.Subject
Cells(rowNumber, 4) = obj_mail.ReceivedTime
End If
rowNumber = rowNumber + 1
Next
I'm looking for a way to save a PDF file from an Outlook Mail to a the Temp folder of the user to work with it.
I did this some time back in C#, but it seems like VBA cant handle the Drag and Drop with outlook Files.
So I have a UserForm in my Excel file. In this Form is a ListView. I can Drag and Drop files From the explorer write the path of the file into a sheet.
So I want to do the same with an PDF File from an attachment from Outlook. But I cant find a way to save the PDF to a folder.
Is there a way to do this with the Drag and Drop event from the ListView?
Drag and drop decrease automation quality. But i have used a macro to retrieve emails with attachments before. I put it for you hope to be usefull
Sub GetAttachments()
Dim oMailItem As Outlook.MailItem
Dim oApp As Outlook.Application
Dim oMAPIFolder As Outlook.MAPIFolder
Dim oFolder As Outlook.Folder
Dim oNS As Outlook.Namespace
Dim iCnt As Integer, RowCnt As Integer
Dim DataSheet As Worksheet
Set oApp = New Outlook.Application
Set oNS = oApp.GetNamespace("MAPI")
Set oMailItem = oApp.CreateItem(0)
Set DataSheet = ActiveSheet
RowCnt = 2
For Each oFolder In oNS.GetDefaultFolder(olFolderInbox).Folders
Set oMAPIFolder = oNS.GetDefaultFolder(olFolderInbox).Folders(oFolder.Name)
For iCnt = 1 To oMAPIFolder.Items.Count
'..... In this section you can put another if to check emails within special date condition.
If TypeOf oMAPIFolder.Items(iCnt) Is MailItem Then
'......... this message has attchment. you can check if it is pdf or not.
Set oMailItem = oMAPIFolder.Items(iCnt)
If oMailItem.Attachments.Count > 0 Then
With DataSheet
.Cells(RowCnt, 2) = oMailItem.Subject
.Cells(RowCnt, 3) = oMailItem.Sender.Address
.Cells(RowCnt, 4) = oMailItem.ReceivedTime
.Cells(RowCnt, 1) = oMailItem.Attachments.Item(1).Filename
RowCnt = RowCnt + 1
End With
End If
End If
Next iCnt
Next
Set oApp = Nothing
Set oNS = Nothing
Set oMailItem = Nothing
Set oMAPIFolder = Nothing
Set oFolder = Nothing
End Sub
I am trying to pull the sender's email address from every email in an inbox folder
I am not having any problems until I reach my For command for each email in the folder.
If I use the code as it is now I run into an error because olSender is not Dim As Variant, but if I change it to Dim As Variant I cannot Dim it as an Outlook.MailItem to retrieve the senderEmailAddress.
I'm assuming a nested For loop is the solution. Outlook 2013 is the version.
Sub ExportToExcel()
'EXCEL
'Opening Excel workbook
Dim oXLApp As Object, oXLwb As Object, oXLws As Object
Dim lRow As Long
On Error Resume Next
Set oXLApp = GetObject(, "Excel.Application")
'~~> If not found then create new instance
If Err.Number <> 0 Then
Set oXLApp = CreateObject("Excel.Application")
End If
Err.Clear
On Error GoTo 0
oXLApp.Visible = True
Set oXLwb = oXLApp.Workbooks.Open("C:\Users\******\Documents\******.xlsm")
Set oXLws = oXLwb.Sheets("Sheet1")
oXLws.Range("A" & 1).Select
'OUTLOOK
'Opening Outlook folder
Dim olNS As Outlook.NameSpace
Dim objOwner As Outlook.Recipient
Set olNS = Application.GetNamespace("MAPI")
Set objOwner = olNS.CreateRecipient("*********#email.com")
objOwner.Resolve
If objOwner.Resolved Then
Set BouncedEmailsFolder = olNS.GetSharedDefaultFolder(objOwner, olFolderInbox).Folders("Bounced Emails")
End If
Dim olItms As Outlook.Items
Dim olMail As Variant
Dim i As Long
Dim olSender As Outlook.MailItem
Set olItms = BouncedEmailsFolder.Items
olItms.Sort ("Subject")
i = 1
For Each olSender In olItms
oXLws.Select
oXLws.Cells(i, 1).Select
oXLws.Cells(i, 1).Value = olSender.SenderEmailAddress
i = i + 1
Next olSender
Set BouncedEmailsFolder = Nothing
Set olNS = Nothing
End Sub
Your code works for me when set to my default inbox.
olNS.GetDefaultFolder(olFolderInbox)
I wonder if you're not coming across non-mail items in your bounced emails? You may want to try the code below, which will retrieve mail items only (instead of also trying to extract the sender for meeting requests, task assignments, etc):
For Each olSender In olItms
If TypeOf olSender Is MailItem Then
oXLws.Select
oXLws.Cells(i, 1).Select
oXLws.Cells(i, 1).Value = olSender.SenderEmailAddress
i = i + 1
End If
Next olSender
I am using the following vba code which checks for any emails with a specific subject heading.
The problem is it checks my default outlook inbox folder when I need it to check the inbox of my other email account NewSuppliers#Hewden.co.uk
Can someone please show me how I would do this? Thanks in advance
Sub Macro1() Set olApp = CreateObject("Outlook.Application")
Dim olNs As Outlook.Namespace
Dim Fldr As Outlook.MAPIFolder
Dim myItem As Outlook.MailItem
Dim myAttachment As Outlook.Attachment
Dim I As Long
Dim olMail As Variant
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderInbox)
Set myTasks = Fldr.Items
Set olMail = myTasks.Find("[Subject] = ""New Supplier Request: Ticket""")
If Not (olMail Is Nothing) Then
For Each myItem In myTasks
If myItem.Attachments.Count <> 0 Then
For Each myAttachment In myItem.Attachments
If InStr(myAttachment.DisplayName, ".txt") Then
I = I + 1
myAttachment.SaveAsFile "\\uksh000-file06\Purchasing\NS\Unactioned\" & myAttachment
End If
Next
End If
Next
For Each myItem In myTasks
myItem.Delete
Next
Call Macro2
Else
MsgBox "There Are No New Supplier Requests."
End If
End Sub
outlook folder structure:
account1#hewden.co.uk
Inbox
Drafts
Sent
NewSuppliers#hewden.co.uk
Inbox
Drafts
Sent
You need to use the following, assuming that the folder you want is at the same level in the folder hierarchy
Set Items = Session.GetDefaultFolder(olFolderCalendar).Parent.Folders("YouFolderName").Items
See here for more details ... http://www.slipstick.com/developer/working-vba-nondefault-outlook-folders/
Have you tried the following function from the above link ...
Function GetFolderPath(ByVal FolderPath As String) As Outlook.Folder
Dim oFolder As Outlook.Folder
Dim FoldersArray As Variant
Dim i As Integer
On Error GoTo GetFolderPath_Error
If Left(FolderPath, 2) = "\\" Then
FolderPath = Right(FolderPath, Len(FolderPath) - 2)
End If
'Convert folderpath to array
FoldersArray = Split(FolderPath, "\")
Set oFolder = Application.Session.Folders.item(FoldersArray(0))
If Not oFolder Is Nothing Then
For i = 1 To UBound(FoldersArray, 1)
Dim SubFolders As Outlook.Folders
Set SubFolders = oFolder.Folders
Set oFolder = SubFolders.item(FoldersArray(i))
If oFolder Is Nothing Then
Set GetFolderPath = Nothing
End If
Next
End If
'Return the oFolder
Set GetFolderPath = oFolder
Exit Function
GetFolderPath_Error:
Set GetFolderPath = Nothing
Exit Function
End Function
You may need to use the technique here first to find out the actual folder name ... https://msdn.microsoft.com/en-us/library/office/ff184607.aspx
In the image below, the Drafts, Clients, Outbox folders are all on the same level (they share the same parent folder james#...com), but the ChildFolder folder is not (it's parent is Drafts).
You should be able to just specify the name of your 2nd mailbox as a Folder.
Set Fldr = olNs.Folders("My 2nd mailbox").Folders("Sub Folder")
If you want the main inbox of the 2nd account, then you specify this as the sub folder of the account.
Set Fldr = olNs.Folders("My 2nd Inbox").Folders("Inbox")
Note that it's the name of the mailbox you use, not the e-mail address. Let me know how you get on.
We use Outlook 2010 and receive emails with Excel attachments. We manually save the attachment in a sub-folder that we create within a divisional folder on a network drive.
What I'm curious about is if it's possible to
Use code to check incoming emails to see if they have an attachment,
Then check the attachment to see if it's an .XLSX,
If so, open the attachment, check the value of a particular cell,
then store the account name and account number as a string and a variable
then use those to create the sub-folders in the appropriate Windows directory.
** I forgot to post what I had done so far. I believe Brett answered my ??, but maybe someone else would be able to use snippets of it.
Private Sub cmdConnectToOutlook_Click()
Dim appOutlook As Outlook.Application
Dim ns As Outlook.Namespace
Dim inbox As Outlook.MAPIFolder
Dim item As Object
Dim atmt As Outlook.Attachment
Dim filename As String
Dim i As Integer
Set appOutlook = GetObject(, "Outlook.Application")
Set ns = appOutlook.GetNamespace("MAPI")
Set inbox = ns.GetDefaultFolder(olFolderInbox)
i = 0
If inbox.Items.Count = 0 Then
MsgBox "There are no messages in the Inbox.", vbInformation, _
"Nothing Found"
Exit Sub
End If
For Each item In inbox.Items
For Each atmt In item.Attachments
If Right(atmt.filename, 4) = "xlsx" Then
filename = "\\temp\" & atmt.filename
atmt.SaveAsFile filename
i = i + 1
End If
Next atmt
Next item
MsgBox "Attachments have been saved.", vbInformation, "Finished"
Set atmt = Nothing
Set item = Nothing
Set ns = Nothing
End Sub
Having said it is lengthy here is one way to do it. My code from VBA Code to save an attachment (excel file) from an Outlook email that was inside another email as an attachment may also be of interest
You will need to update your file path, and the cell range from the file that you are opening
In my testing I sent a message to myself with a pdf file and an excel workbook with "bob" in the A1 in the first sheet
The code below found the excel file, saved it, opened it, create a directory c:\temp\bob then killed the saved file
Private Sub Application_NewMailEx _
(ByVal EntryIDCollection As String)
'Uses the new mail techniquer from http://www.outlookcode.com/article.aspx?id=62
Dim arr() As String
Dim lngCnt As Long
Dim olAtt As Attachment
Dim strFolder As String
Dim strFileName As String
Dim strNewFolder
Dim olns As Outlook.NameSpace
Dim olItem As MailItem
Dim objExcel As Object
Dim objWB As Object
'Open Excel in the background
Set objExcel = CreateObject("excel.application")
'Set working folder
strFolder = "c:\temp"
On Error Resume Next
Set olns = Application.Session
arr = Split(EntryIDCollection, ",")
On Error GoTo 0
For lngCnt = 0 To UBound(arr)
Set olItem = olns.GetItemFromID(arr(lngCnt))
'Check new item is a mail message
If olItem.Class = olMail Then
'Force code to count attachments
DoEvents
For Each olAtt In olItem.Attachments
'Check attachments have at least 5 characters before matching a ".xlsx" string
If Len(olAtt.FileName) >= 5 Then
If Right$(olAtt.FileName, 5) = ".xlsx" Then
strFileName = strFolder & "\" & olAtt.FileName
'Save xl attachemnt to working folder
olAtt.SaveAsFile strFileName
On Error Resume Next
'Open excel workbook and make a sub directory in the working folder with the value from A1 of the first sheet
Set objWB = objExcel.Workbooks.Open(strFileName)
MkDir strFolder & "\" & objWB.sheets(1).Range("A1")
'Close the xl file
objWB.Close False
'Delete the saved attachment
Kill strFileName
On Error Goto 0
End If
End If
Next
End If
Next
'tidy up
Set olns = Nothing
Set olItem = Nothing
objExcel.Quit
Set objExcel = Nothing
End Sub