My code as below to extract all inbox, folder and subfolder. Is working fine for main mailbox. but when I input to extract from shared mailbox is only extracting Inbox. Any wrong with my code below? I able to extract Inbox, folder and subfolder if I remove this part "Set olShareName = Ns.CreateRecipient("Shared Email Address")"
Public xlSht As Excel.Worksheet
Sub DocumentFolders(objParent As Folder, lRow As Long)
Dim objItm As Object
Dim objFolder As Folder
On Error Resume Next
With xlSht
For Each objItm In objParent.Items
.Cells(lRow, 1) = objParent
.Cells(lRow, 2) = objItm.Subject
.Cells(lRow, 3) = objItm.ReceivedTime
lRow = lRow + 1
Next
End With
On Error GoTo 0
If objParent.folders.Count > 0 Then
For Each objFolder In objParent.folders
Call DocumentFolders(objFolder, lRow)
Next
End If
End Sub
Sub ExportInformation()
Dim xlApp As Excel.Application
Dim xlWb As Excel.Workbook
Dim Ns As Outlook.Namespace
Dim olShareName As Outlook.Recipient
Dim OutlookFolder As Outlook.Folder
Set Ns = Outlook.Application.GetNamespace("MAPI")
Set olShareName = Ns.CreateRecipient("Shared Email Address")
olShareName.Resolve
Set OutlookFolder = Ns.GetSharedDefaultFolder(olShareName, olFolderInbox) '.folders("FolderName")
Set xlApp = New Excel.Application
Set xlWb = xlApp.Workbooks.Add
Set xlSht = xlWb.Sheets(1)
With xlSht
.Cells(1, 1) = "Folder"
.Cells(1, 2) = "Subject"
.Cells(1, 3) = "Received Time"
End With
Call DocumentFolders(Session.GetSharedDefaultFolder(olShareName, olFolderInbox), 2)
xlApp.Visible = True
Set xlSht = Nothing
Set xlWb = Nothing
Set xlApp = Nothing
End Sub
Related
I have code that extracts the body of email which has the subject line "Volume data".
Let's say I have 10 emails in my inbox folder which has the subject line "Volume data".
I want to loop through all the emails, find which email has subject line "Volume data" and then extract the email body from those 10 emails.
My code is stopping at the first instance where it finds the mentioned subject.
Option Explicit
Sub impOutlookTable()
Dim wkb As Workbook
Set wkb = ThisWorkbook
Sheets("Sheet1").Cells.ClearContents
' point to the desired email
Const strMail As String = "emailaddress"
Dim oApp As Outlook.Application
Dim oMapi As Outlook.MAPIFolder
Dim oMail As Outlook.MailItem
Dim x As Long, y As Long
Dim destCell As Range
Dim i As Long
Dim oItem As Object
With ActiveSheet
Set destCell = .Cells(Rows.Count, "A").End(xlUp)
End With
On Error Resume Next
Set oApp = GetObject(, "OUTLOOK.APPLICATION")
If (oApp Is Nothing) Then Set oApp = CreateObject("OUTLOOK.APPLICATION")
On Error GoTo 0
Set oMapi = oApp.GetNamespace("MAPI").Folders(strMail).Folders("inbox")
Set oMail = oMapi.Items(oMapi.Items.Count)
For Each oItem In oMapi.Items
If oItem.Subject = "Volume data" Then
Exit For
End If
Next oItem
If Not oItem Is Nothing Then
' get html table from email object
Dim HTMLdoc As MSHTML.HTMLDocument
Dim tables As MSHTML.IHTMLElementCollection
Dim table As MSHTML.HTMLTable
Set HTMLdoc = New MSHTML.HTMLDocument
With HTMLdoc
.Body.innerHTML = oItem.HTMLBody
Set tables = .getElementsByTagName("table")
End With
'import in Excel
For Each table In tables
For x = 0 To table.Rows.Length - 1
For y = 0 To table.Rows(x).Cells.Length - 1
destCell.Offset(x, y).Value = table.Rows(x).Cells(y).innerText
Next y
Next x
Set destCell = destCell.Offset(x)
Next
End If
Set oApp = Nothing
Set oMapi = Nothing
Set oMail = Nothing
Set HTMLdoc = Nothing
Set tables = Nothing
wkb.SaveAs "C:\Users\Desktop\New_email.xlsm"
End Sub
Put all of the "Action" code inside the If statement inside your loop instead of after it, and then remove the Exit For.
You will also need a counter or something so that you aren't just saving overtop of the same file for each iteration.
UNTESTED
Option Explicit
Sub impOutlookTable()
Dim iCounter As Integer
iCounter = 1
Dim wkb As Workbook
Set wkb = ThisWorkbook
Sheets("Sheet1").Cells.ClearContents
' point to the desired email
Const strMail As String = "emailaddress"
Dim oApp As Outlook.Application
Dim oMapi As Outlook.MAPIFolder
Dim oMail As Outlook.MailItem
Dim x As Long, y As Long
Dim destCell As Range
Dim i As Long
Dim oItem As Object
With ActiveSheet
Set destCell = .Cells(Rows.Count, "A").End(xlUp)
End With
On Error Resume Next
Set oApp = GetObject(, "OUTLOOK.APPLICATION")
If (oApp Is Nothing) Then Set oApp = CreateObject("OUTLOOK.APPLICATION")
On Error GoTo 0
Set oMapi = oApp.GetNamespace("MAPI").Folders(strMail).Folders("inbox")
Set oMail = oMapi.Items(oMapi.Items.Count)
For Each oItem In oMapi.Items
If oItem.Subject = "Volume data" Then
' get html table from email object
Dim HTMLdoc As MSHTML.HTMLDocument
Dim tables As MSHTML.IHTMLElementCollection
Dim table As MSHTML.HTMLTable
Set HTMLdoc = New MSHTML.HTMLDocument
With HTMLdoc
.Body.innerHTML = oItem.HTMLBody
Set tables = .getElementsByTagName("table")
End With
'import in Excel
For Each table In tables
For x = 0 To table.Rows.Length - 1
For y = 0 To table.Rows(x).Cells.Length - 1
destCell.Offset(x, y).Value = table.Rows(x).Cells(y).innerText
Next y
Next x
Set destCell = destCell.Offset(x)
Next
Set oApp = Nothing
Set oMapi = Nothing
Set oMail = Nothing
Set HTMLdoc = Nothing
Set tables = Nothing
wkb.SaveAs "C:\Users\Desktop\New_email_" & iCounter & ".xlsm"
iCounter = iCounter + 1
End If
Next oItem
End Sub
I used this code from https://www.slipstick.com/developer/vba-copy-outlook-email-excel-workbook/ and modified it to extract a string from email body.
Instead of using it in Outlook, I run it from my target Excel workbook after including the MS Outlook 16.0 Object Library.
It worked the first time I fired it, but later that day I received
run-time error 91 - "Object variable or With block variable not set"
on line
Set xlSheet = xlWB.Sheets("IMPORT")
I deduced this error occurs when code is launched from the target workbook. It works when fired from Outlook or different workbook.
Option Explicit
Private Const xlUp As Long = -4162
Sub Extract_string_from_email_body()
Dim objOL As Outlook.Application
Dim objItems As Outlook.Items
Dim objFolder As Outlook.MAPIFolder
Dim olItem As Outlook.MailItem
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim vText, vText2, vText3, vText4, vText5 As Variant
Dim sText As String
Dim rCount As Long
Dim bXStarted As Boolean
Dim enviro As String
Dim strPath As String
Dim Reg1 As Object
Dim M1 As Object
Dim M As Object
'original code to run from Outlook and output string to existing workbook
'enviro = CStr(Environ("USERPROFILE"))
'strPath = enviro & "\Documents\test.xlsx"
'my target workbook I've launched my code from
strPath = "X:\02 Workbooks\Workbook.xlsm"
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Set xlApp = CreateObject("Excel.Application")
bXStarted = True
End If
On Error GoTo 0
Set xlWB = xlApp.Workbooks.Open(strPath)
Set xlSheet = xlWB.Sheets("IMPORT") 'error occurs here
rCount = xlSheet.Range("Q" & xlSheet.Rows.Count).End(xlUp).Row
rCount = rCount + 1
Set objOL = Outlook.Application
Set objFolder = objOL.Session.GetDefaultFolder(olFolderInbox).Parent.Folders("Data").Folders("Register")
Set objItems = objFolder.Items
For Each olItem In objItems
On Error Resume Next
With olItem
sText = olItem.Body
Set Reg1 = CreateObject("VBScript.RegExp")
With Reg1
.Pattern = "((OPO\/\d{2}\/[CLRPWBDFGIMSKT]\/\S{10}\/[SO|DL|MM]{2}\/\d{3}))"
End With
If Reg1.test(sText) Then
Set M1 = Reg1.Execute(sText)
For Each M In M1
vText = Trim(M.SubMatches(1))
Next
xlSheet.Range("Q" & rCount) = vText
rCount = rCount + 1
End If
End With
Next
xlWB.Close 1
If bXStarted Then
xlApp.Quit
End If
Set M = Nothing
Set M1 = Nothing
Set Reg1 = Nothing
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
Set objItems = Nothing
Set objFolder = Nothing
Set objOL = Nothing
End Sub
First of all, if you run the code in Excel there is no need to get an Excel Application instance or create a new one in the code:
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Set xlApp = CreateObject("Excel.Application")
bXStarted = True
End If
On Error GoTo 0
Use the Applicaiton property availble for VBA macros out of the box.
Second, you need to initialize the Outlook Application properly:
Set objOL = Outlook.Application
But it should be:
Set objOL = New Outlook.Application
You can read more about that in the Automating Outlook from a Visual Basic Application article.
I currently have a code set up to add an appointment to Outlook if a cell in Excel contains the word "No". What I would like to be able to do is delete an existing appointment if the same cell is changed to "N/A". I've tried to adapt some code I found elsewhere for this but can't get it to work, currently it's displaying "Compile error: next without for"
Sub DeleteCalendarItems()
Dim r As Long, i As Long, wb As Workbook
Dim ws As Worksheet
Dim objOutlook As Outlook.Application
Dim objNamespace As Outlook.Namespace
Dim objFolder As Outlook.MAPIFolder
Dim objAppointment As Outlook.AppointmentItem
Dim strSubject As String
Set objOutlook = Outlook.Application
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objFolder = objNamespace.GetDefaultFolder(olFolderCalendar)
Set oItems = objFolder.Items
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Section 74")
r = ws.Cells(Rows.Count, 1).End(xlUp).Row 'Rows.Count should also have a reference to a wb & ws
For i = 2 To r
If ws.Cells(i, 9) = "N/A" Then
ws.Cells(i, 13) = "Yes"
Set objAppointment = oItems.Item(i)
With objAppointment
If .Subject = strSubject Then
objAppointment.Delete
End If
End With
End If
Next i
End Sub
A With, If and For statement (and more) should always be closed
Sub DeleteCalendarItems()
Dim wb As Workbook
Dim ws As Worksheet
Dim objOutlook As Outlook.Application
Dim objNamespace As Outlook.Namespace
Dim objFolder As Outlook.MAPIFolder
Dim objAppointment As Outlook.AppointmentItem
Dim strSubject As String
Set objOutlook = Outlook.Application
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objFolder = objNamespace.GetDefaultFolder(olFolderCalendar)
Set oItems = objFolder.Items
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Section 74")
r = ES.Cells(Rows.Count, 1).End(xlUp).Row 'Rows.Count should also have a reference to a wb & ws
For i = 2 To r
If ES.Cells(i, 9).Value = "N/A" Then
Set objAppointment = oItems.Item(i)
With objAppointment
If .Subject = strSubject Then
objAppointment.Delete
End If
End With
End If
Next i
End Sub
I've managed to work it out (somehow) - I needed to add a nested For loop
Sub DeleteNASec74()
Dim i As Long, j As Long
Dim wb As Workbook
Dim ws As Worksheet
Dim objOutlook As Outlook.Application
Dim objNamespace As Outlook.Namespace
Dim objFolder As Outlook.MAPIFolder
Dim objAppointment As Outlook.AppointmentItem
Set objOutlook = Outlook.Application
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objFolder = objNamespace.GetDefaultFolder(olFolderCalendar)
Set oItems = objFolder.Items
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Section 74")
r = ws.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To r
For j = oItems.Count To 1 Step -1
If ws.Cells(i, 9).Value = "N/A" Then
ws.Cells(i, 13) = "Yes"
Set objAppointment = oItems.Item(j)
With objAppointment
If .Subject = "Send reminder email - " + ws.Cells(i, 2).Value Then
objAppointment.Delete
End If
End With
End If
Next j
Next i
End Sub
I'm trying to extract first table of each mail of a specific folder to Excel. If there is more than one table in the mail we can exclude it and move to next mail item. Below is the code I have at the moment. Could you please help?
Public Sub Import_Tables_From_Outlook_Emails()
Dim oApp As Outlook.Application, oMapi As Outlook.MAPIFolder
Dim oMail As Outlook.MailItem, HTMLdoc As MSHTML.HTMLDocument
Dim tables As MSHTML.IHTMLElementCollection, table As MSHTML.HTMLTable
Dim objExcelApp As Excel.Application, x As Long, y As Long, destCell As Range
Dim objExcelWorkbook As Excel.Workbook, objExcelWorksheet As Excel.Worksheet
Set objExcelApp = CreateObject("Excel.Application") 'Create a new excel workbook
Set objExcelWorkbook = objExcelApp.Workbooks.Add
objExcelApp.Visible = True
Set destCell = ActiveSheet.Cells(Rows.Count, "A").End(xlUp)
On Error Resume Next
Set oApp = GetObject(, "OUTLOOK.APPLICATION")
If oApp Is Nothing Then Set oApp = CreateObject("OUTLOOK.APPLICATION")
On Error GoTo 0
Set oMapi = oApp.GetNamespace("MAPI").PickFolder
If Not oMapi Is Nothing Then
For Each oMail In oMapi.items
'Get HTML tables from email object
Set HTMLdoc = New MSHTML.HTMLDocument
With HTMLdoc
.Body.innerHTML = oMail.HTMLBody
Set tables = .getElementsByTagName("table")
End With
For Each table In tables
For x = 0 To table.Rows.Length - 1
For y = 0 To table.Rows(x).Cells.Length - 1
destCell.Offset(x, y).Value = _
table.Rows(x).Cells(y).innerText
Next y
Next x
Sheets.Add After:=ActiveSheet
Range("A1").Activate
Set destCell = ActiveSheet.Range("A1")
Next
Next
End If
Set oApp = Nothing
Set oMapi = Nothing
Set oMail = Nothing
Set HTMLdoc = Nothing
Set tables = Nothing
MsgBox "Finished"
End Sub
The following macro prompts the user to select a folder from Outlook, loops though each item in the folder, and copies the first table from each item to a separate worksheet in a newly created workbook.
Edit
The code has been edited to 1) restrict the mail items based on ReceivedTime, 2) sort the restricted items by ReceivedTime, and in descending order, 3) loop through the items from earliest to latest date.
Option Explicit
Public Sub Import_Tables_From_Outlook_Emails()
Dim oMapiFolder As Folder
Dim oMail As Object
Dim oMailItems As Object
Dim oRestrictItems As Object
Dim oHTMLDoc As Object
Dim oHTMLTable As Object
Dim xlApp As Object
Dim xlWkb As Object
Dim r As Long
Dim c As Long
Dim i As Long
Set oMapiFolder = Application.GetNamespace("MAPI").PickFolder
If oMapiFolder Is Nothing Then
Exit Sub
End If
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If xlApp Is Nothing Then
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
End If
On Error GoTo 0
Set xlWkb = xlApp.workbooks.Add(-4167) 'xlWBATWorksheet
Set oHTMLDoc = CreateObject("htmlfile")
Set oMailItems = oMapiFolder.Items
Set oRestrictItems = oMailItems.Restrict("[ReceivedTime] >= '" & Format("1/1/17 12:00am", "ddddd h:nn AMPM") & "'")
oRestrictItems.Sort "[ReceivedTime]", olDescending
For i = 1 To oRestrictItems.Count
Set oMail = oRestrictItems(i)
With oHTMLDoc
.Body.innerHTML = oMail.HTMLBody
Set oHTMLTable = .getElementsByTagName("table")(0)
End With
If Not oHTMLTable Is Nothing Then
xlWkb.Worksheets.Add after:=xlWkb.activesheet
For r = 0 To oHTMLTable.Rows.Length - 1
For c = 0 To oHTMLTable.Rows(r).Cells.Length - 1
xlWkb.activesheet.Range("A1").Offset(r, c).Value = _
oHTMLTable.Rows(r).Cells(c).innerText
Next c
Next r
Set oHTMLTable = Nothing
End If
Next i
xlApp.DisplayAlerts = False
xlWkb.Worksheets(1).Delete
xlApp.DisplayAlerts = True
Application.ActiveExplorer.Activate
Set oMapiFolder = Nothing
Set oMail = Nothing
Set oHTMLDoc = Nothing
Set oHTMLTable = Nothing
Set xlApp = Nothing
Set xlWkb = Nothing
MsgBox "Finished"
End Sub
I'm creating code wherein Outlook will extract all emails to an existing Excel file.
The code works and extracts all emails from a selected folder. However, when I try to use the same code on a separate folder, let's say Sent Items, it doesn't extract the data and opens a Read only version of the Excel file.
I plan to leave Outlook and Excel Open.
How can I work with any Outlook folder and still update the Excel file?
Private Sub Application_NewMailv7()
Dim objNS As NameSpace
Dim objFolder As MAPIFolder
Dim currentExplorer As Explorer
Dim Selection As Selection
Dim obj As Object
Dim objOL As Outlook.Application
Dim objItems As Outlook.Items
Dim myItem As MailItem
Dim myXLApp As Excel.Application
Dim myXLWB As Excel.Workbook
Dim StrBody As String
Dim TotalRows As Long, i As Long
Set objOL = Outlook.Application
Set objFolder = objOL.ActiveExplorer.CurrentFolder
Set objItems = objFolder.Items
Set myXLApp = New Excel.Application
myXLApp.Visible = True
Set myXLWB = myXLApp.Workbooks.Open("C:\Users\username\Desktop\Folder Name\SR Historyv2.xlsx")
Set excWks = myXLWB.Worksheets("Sheet1")
TotalRows = Sheets(1).Range("A65536").End(xlUp).Row
i = TotalRows + 1
For Each obj In objItems
If obj.Class = olMail Then
'Add a row for each field in the message you want to export
excWks.Cells(i, 1) = Format(obj.ReceivedTime, "mm/dd/yyyy")
excWks.Cells(i, 2) = obj.SenderEmailAddress
excWks.Cells(i, 3) = obj.Subject
i = i + 1
'myXLWB.Save
End If
Next
Set obj = Nothing
Set objItems = Nothing
Set objFolder = Nothing
Set objOL = Nothing
End Sub
Try the following and if you would like to run Outlook Rule, let me know I will update the answer
Option Explicit
Sub Excel()
Dim xlApp As Object 'Excel App
Dim xlWB As Object 'WorkBook
Dim xlSheet As Object
Dim rngCount As Long
Dim xlStarted As Boolean
Dim xlPath As String
Dim olExplorer As Explorer
Dim olSelection As Selection
Dim olItem As Outlook.MailItem
Dim olMsg As Object
Dim xlColA, xlColB, xlColC, xlColD As String
'// Path of the Workbook - update only -> "\Folder Name\Folder Name\Book1.xlsx"
xlPath = Environ("USERPROFILE") & _
"\Documents\Temp\Book1.xlsx"
'// Set up Excel Application
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")
xlStarted = True
End If
On Error GoTo 0
'// Open the workbook to input the data
Set xlWB = xlApp.Workbooks.Open(xlPath)
Set xlSheet = xlWB.Sheets("Sheet1") ' or use (1) or (Sheet Name)
'// Record msg
On Error Resume Next
'// Find the next empty line of the worksheet
rngCount = xlSheet.Range("A" & xlSheet.Rows.Count).End(-4162).Row
'// Get the values from Outlook
Set olExplorer = Application.ActiveExplorer
'// Select Outlook msg
Set olSelection = olExplorer.Selection
For Each olMsg In olSelection
Set olItem = olMsg
'// Info to collect
xlColA = olItem.ReceivedTime
xlColB = olItem.SenderName
xlColC = olItem.SenderEmailAddress
xlColD = olItem.To
'// Write it to Excel sheet
xlSheet.Range("A" & rngCount) = xlColA
xlSheet.Range("B" & rngCount) = xlColB
xlSheet.Range("C" & rngCount) = xlColC
xlSheet.Range("D" & rngCount) = xlColD
'// Go to Next row
rngCount = rngCount + 1
Next
'// Save & Close Excel.Application
xlWB.Close 1
If xlStarted Then
xlApp.Quit
End If
'// Clean up
Set olItem = Nothing
Set olMsg = Nothing
Set olExplorer = Nothing
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
End Sub
Do you close the SR Historyv2 workbook after you run the script or do you want to keep it open the entire time? If you keep it open and run the script again it will open the workbook a second time and that will be read only. For the second question i would suggest you look into the ItemAdd event in Outlook. This will only work if Outlook is open. https://msdn.microsoft.com/en-us/library/office/aa171270(v=office.11).aspx
I got this code working properly
Set myXLApp = GetObject(, "Excel.Application")
'specify the History File
With myXLApp
.Workbooks("SR Historyv2.xlsx").Activate
End With
It keeps the file to open and lets the other macro access it without being read-only.