I have an Excel file which will be used as a tool collate tables from mails. One mail will have only one table and one record in it. I need to collate the records in all such tables (from different mails) into One Excel table. I have the following code to do it. This code when run, copies the entire text in body of mail to Excel (So the code works only if the mail has Table with no other text in the body of mail). But I need to copy only the Table present in the mail to Excel. Please help me modify the code to do this. Please note that I do not want to write any code in outlook. Also the copied table is pasted as text. I want them to get pasted in table format. The part of the code which will need modification is shown below.
Public Sub ExportToExcel1()
Application.ScreenUpdating = False
'Variable declaration
Dim i As Integer
Dim ns As Namespace
Dim Inbox As Outlook.MAPIFolder
Dim item As Object
Dim doClip As MSForms.DataObject
Dim d As String
'Set values for variables
i = 2
d = ActiveSheet.Range("subject").Value
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set doClip = New MSForms.DataObject
'Loop to check mails and pull data
For Each item In Inbox.Items
If TypeName(item) = "MailItem" And item.Subject = d Then
doClip.SetText item.Body
doClip.PutInClipboard
ActiveSheet.Cells(1, 1).PasteSpecial "Text"
EndSub
There are two mistakes in your code:
You access item.Body which is the text body when you need the Html body.
You paste the entire body into the worksheet when you only want the table.
You need some extra variables:
Dim Html As String
Dim LcHtml As String
Dim PosEnd As Long
Dim PosStart As Long
Replace the If statement with:
If TypeName(item) = "MailItem" And item.Subject = d Then
Html = item.HTMLBody
LcHtml = LCase(Html)
PosStart = InStr(1, LcHtml, "<table")
If PosStart > 0 Then
PosEnd = InStr(PosStart, LcHtml, "</table>")
If PosEnd > 0 Then
Debug.Print "[" & Mid(Html, PosStart, PosEnd + 8 - PosStart) & "]"
doClip.SetText Mid(Html, PosStart, PosEnd + 8 - PosStart)
doClip.PutInClipboard
ActiveSheet.Cells(1, 1).PasteSpecial "Text"
End If
End If
End If
Related
I am trying to write a VBA code that once a range of cells has been populated will search for a cell value in a section of either the body or the subject of my outlook account. After that it will retrieve the relevant attachment and download it to a certain file.
I am a complete beginner to VBA but, I have got up until retrieving the email subject and body. Unfortunately I have reached a bit of a snag where I can get the subject and the body on 2 columns. But I'm not sure how to code in the search button according to the cell value in a range of cells and then save the relevant attachment.
Would appreciate any help or a finger in the right direction.
Option Explicit
Sub GetInboxItems()
Dim ol As Outlook.Application
Dim ns As Outlook.Namespace
Dim fol As Outlook.Folder
Dim i As Object
Dim mi As Outlook.MailItem
Dim n As Long
Set ol = New Outlook.Application
Set ns = ol.GetNameSpace("MAPI")
Set fol = ns.GetDefaultFolder(olFolderInbox)
Range("A2", Range("A2").End(xlDown).End(xlToRight)).Clear
n = 1
For Each i In fol.Items
If i.Class = olMail Then
Set mi = i
n = n + 1
Cells(n, 1).Value = mi.SenderName
Cells(n, 1).Value = mi.Subject
End If
Next i
End Sub
I can retrieve all the emails but I only want those which have the values of the cells I am looking for
and then download the attachment.
I have an Excel VBA macro (Macro A) to export the members' information (Name and Address) from Outlook contacts folder to Excel.
I am trying to retrieve the members of a distribution list, and push them into my Outlook contacts folder on a daily basis. In that case, I can use macro A to export the latest DL members found in my contacts folder.
My ultimate objective is to get the latest name and email address of the members found in a distribution list in Excel format.
I searched online for solutions that can directly export the members of Outlook distribution list to Excel, but didn't achieve my intended effect.
Sub PrintDistListDetails()
Dim olApplication As Object
Dim olNamespace As Object
Dim olContactFolder As Object
Dim olDistListItem As Object
Dim destWorksheet As Worksheet
Dim distListName As String
Dim memberCount As Long
Dim memberIndex As Long
Dim rowIndex As Long
Const olFolderContacts As Long = 10
distListName = "dl.xxxxxx" 'change the name accordingly
Set olApplication = CreateObject("Outlook.Application")
Set olNamespace = olApplication.GetNamespace("MAPI")
Set olContactFolder = olNamespace.GetDefaultFolder(olFolderContacts)
Set olDistListItem = olContactFolder.Items(distListName)
Set destWorksheet = Worksheets.Add
destWorksheet.Range("A1:B1").Value = Array("Name", "Address") 'column headers
memberCount = olDistListItem.memberCount
rowIndex = 2 'start the list at Row 2
'For memberIndex = 1 To memberCount
For memberIndex = 1 To 1
With olDistListItem.GetMember(memberIndex)
destWorksheet.Cells(rowIndex, "a").Value = .Name
destWorksheet.Cells(rowIndex, "b").Value = .Address
End With
rowIndex = rowIndex + 1
Next memberIndex
destWorksheet.Columns.AutoFit
Set olApplication = Nothing
Set olNamespace = Nothing
Set olContactFolder = Nothing
Set olDistListItem = Nothing
Set destWorksheet = Nothing
End Sub
It is only printing out the name of a distribution list, and its "parent email". For example, the output will be "dl.xxxxxx" in A2 cell, and "dl.xxxxxx#outlook.com" in B2 cell, instead of retrieving all the members in the distribution list.
How do I get the latest name and address of the members in a distribution list, and print in Excel using any of the two methods described above?
Your loop only runs once:
For memberIndex = 1 To 1
change it back to
For memberIndex = 1 To memberCount
I have exported all subject of the emails from the main folder to excel spreadsheet in the first module of my project.
For the second module, or code. I would like to move the emails i extracted from the main folder to a sub-folder based on searching the email subject. I detailed the subfolder name, on a separate column of the spreadsheet.
Column 3 - The subject email
Column 8 - The subfolder name
Each email subject in the main folder is unique, So i used the "Find Method" then move the email to the subfolder. Since the list is dynamic every time i make an extract, i decided to use arrays, so that it can iterate when the list of email changes.
Example, the code has to place email in the main folder with subject "A" to folder "1".
Email subject Folder name
(Column 3) (Column 8)
A 1
B 1
C 2
D 2
E 1
Sub MovingEmails_Invoices()
'Declare your Variables
Dim i As Object
Dim items As Outlook.items
Dim subfolder As Outlook.Folder 'this will be the folder you want to move the Mail to
'Set Outlook Inbox Reference
Set OP = New Outlook.Application
Set NS = OP.GetNamespace("MAPI")
'To loop through subfolder and its folders
Set rootfol = NS.Folders("SYNTHES-JNJCZ-GBS.DE.AT.CH#ITS.JNJ.com")
Set Folder = rootfol.Folders("Austria")
'The list for invoice numbers and folders is dynamic
'Each subject being searched is different
Dim Listmails() As Variant
Dim Rowcount As Variant
Dim Mailsubject As Variant
Dim FolderName As Variant
Dim MS As Variant
'Establish the array based on the mailbox extract
Sheets("files").Activate
Listmails = Range("A2").CurrentRegion
'Ititerate through the array which is dynamic (One-dimensional)
For Rowcount = LBound(Listmails) To UBound(Listmails)
'3rd row for email subject
Mailsubject = Application.WorksheetFunction.Index(Listmails, Rowcount, 3)
MS = "[subject] = '" & Mailsubject & "'"
'Find the email based on the array for email subject
Set i = items
Set i = Folder.items.Find(MS)
If i.Class = olMail Then
'8th row for folder name
FolderName = Application.WorksheetFunction.Index(Listmails, Rowcount, 8)
Set subfolder = rootfol.Folders(FolderName)
'If email is found then mark it as read
item.UnRead = False
'Move it to the subfolder based on the array for folder name
i.Move subfolder
End If
Next Rowcount
End Sub
I had an error to conduct the below code, but i am not sure why
If i.Class = olMail Then
I am adding an improved code for the iteration part alone. i have error for
Set items = items.Restrict(MS)
'Ititerate through the array which is dynamic (One-dimensional)
For Rowcount = LBound(Listmails) To UBound(Listmails)
'3rd row for email subject 'used DASL Filter
Mailsubject = Application.WorksheetFunction.Index(Listmails, Rowcount, 3)
MS = "urn:schemas:mailheader:subject LIKE \'%" & Mailsubject & "%\'"
'Find the email based on the array for email subject
Set myitems = Folder.items
Set myrestrictitem = myitems.Restrict(MS)
For Each i In myrestrictitem
If TypeOf i Is Mailitem Then
'8th row for folder name
FolderName = Application.WorksheetFunction.Index(Listmails, Rowcount, 8)
Set subfolder = rootfol.Folders(FolderName)
'If email found then mark it as read
i.UnRead = False
'Move it to the subfolder based on the array for folder name
i.Move subfolder
Else
End If
Next
Next Rowcount
End Sub
I'm just looking at part of your code, but there's at least two big mistakes I spotted:
Why are you setting i twice? Also what is items?
Set i = items
Set i = Folder.items.Find(MS)
1: Do you perhaps want to check the TypeOf i?
If i.Class = olMail Then
2: What is item?
item.UnRead = False
Remove the line
Set i = items
Replace the line
If i.Class = olMail then
with
If TypeOf i Is MailItem Then
And replace item with i in the line item.UnRead = False
I'd suggest checking the subject line as a substring, for example:
dim filter as string = "urn:schemas:mailheader:subject LIKE \'%"+ wordInSubject +"%\'"
Also, you must use the FindNext in addition to the Find one or just the Restrict method:
Sub MovingEmails_Invoices()
'Declare your Variables
Dim i As Object
Dim items As Outlook.items
Dim subfolder As Outlook.Folder 'this will be the folder you want to move the Mail to
'Set Outlook Inbox Reference
Set OP = New Outlook.Application
Set NS = OP.GetNamespace("MAPI")
'To loop through subfolder and its folders
Set rootfol = NS.Folders("SYNTHES-JNJCZ-GBS.DE.AT.CH#ITS.JNJ.com")
Set Folder = rootfol.Folders("Austria")
'The list for invoice numbers and folders is dynamic
'Each subject being searched is different
Dim Listmails() As Variant
Dim Rowcount As Variant
Dim Mailsubject As Variant
Dim FolderName As Variant
Dim MS As Variant
'Establish the array based on the mailbox extract
Sheets("files").Activate
Listmails = Range("A2").CurrentRegion
'Ititerate through the array which is dynamic (One-dimensional)
For Rowcount = LBound(Listmails) To UBound(Listmails)
'3rd row for email subject
Mailsubject = Application.WorksheetFunction.Index(Listmails, Rowcount, 3)
MS = "urn:schemas:mailheader:subject LIKE \'%"& Mailsubject &"%\'"
'Find the email based on the array for email subject
Set items = Folder.Items
Set items = items.Restrict(MS)
i = resultItems.GetFirst()
While Not IsNothing(i)
If i.Class = olMail Then
'8th row for folder name
FolderName = Application.WorksheetFunction.Index(Listmails, Rowcount, 8)
Set subfolder = rootfol.Folders(FolderName)
'If email is found then mark it as read
i.UnRead = False
'Move it to the subfolder based on the array for folder name
i.Move subfolder
i = resultItems.GetNext()
End While
End If
Next Rowcount
End Sub
You can find the sample code and description in the following articles:
How To: Use Find and FindNext methods to retrieve Outlook mail items from a folder (C#, VB.NET)
How To: Use Restrict method to retrieve Outlook mail items from a folder
I've been trying to create a sub that would take some information from an Excel selection and create a new task on Outlook. The body of the task should feature the comment from the first cell (which it already does) but before all that I want to paste the range as it looks in Excel, then the comment, and then again, the range.
Here's my code:
Sub CreateReminder()
Dim olApp As Object
Dim olRem As Object
Dim myRange As Range
Dim contact As String
Dim company As String
Dim city As String
Dim state As String
Dim cmt As comment
Dim comment As String
Dim strdate As Date
Dim remdate As Date
Set olApp = CreateObject("Outlook.Application")
Set olRem = olApp.CreateItem(3)
Set myRange = Selection
If ActiveCell.comment Is Nothing Then
Exit Sub
Else
Set cmt = ActiveCell.comment
End If
company = myRange.Columns(1).Text
contact = myRange.Columns(2).Text
If InStr(contact, "/") <> 0 Then
contact = Left(contact, InStr(contact, "/") - 1)
End If
city = myRange.Columns(7).Text
state = myRange.Columns(8).Text
myRange.Copy
comment = cmt.Text
strdate = Date
remdate = Format(Now)
rangeaddress = myRange.Address
wrksheetname = ActiveSheet.Name
With olRem
.Subject = "Call " & contact & " - " & company & " - " & city & ", " & state
.display
SendKeys "{TAB 9}"
SendKeys "^{v}"
.body = Chr(10) & comment & Chr(10)
'.startdate = strdate
'.remindertime = remdate
'.reminderset = True
'.showcategoriesdialog
End With
Set olApp = Nothing
Set olRem = Nothing
End Sub
As you can see, I am able to paste using a SendKeys method, but it is sort of a hack, and not... sophisticated. I'm sure there's another way of doing it, any ideas?
I found code for pasting as HTML to an email, but as I understand, the Mail item allows for HTML, but not the Task item.
Outlook uses Word as an email editor. You can use the Word object model for making manipulatins on the message body. The WordEditor property of the Inspector class returns an instance of the Document class (from the Word object model) which represents the body. You can read more about that way and all possible ways in the Chapter 17: Working with Item Bodies.
That way you can use the Copy method of the Range class to copy the range to the Clipboard. Then you can use the Paste method from the Word object model to paste data into the document which represents the message body.
How do I copy an email to the clipboard and then paste it into excel with the tables intact?
I am using Outlook 2007 and I want to do the equivalent of
"Click on email > Select All > Copy > Switch to Excel > Select Cell > Paste".
I have the Excel Object Model pretty well figured out, but have no experience in Outlook other than the following code.
Dim mapi As NameSpace
Dim msg As Outlook.MailItem
Set mapi = Outlook.Application.GetNamespace("MAPI")
Set msg = mapi.Folders.Item(1).Folders.Item("Posteingang").Folders.Item(1).Folders.Item(7).Items.Item(526)
I must admit I use this in Outlook 2003, but please see if it works in 2007 as well:
you can use the MSForms.DataObject to exchange data with the clipboard. In Outlook VBA, create a reference to "Microsoft Forms 2.0 Object Library", and try this code (you can of course attach the Sub() to a button, etc.):
Sub Test()
Dim M As MailItem, Buf As MSForms.DataObject
Set M = ActiveExplorer().Selection.Item(1)
Set Buf = New MSForms.DataObject
Buf.SetText M.HTMLBody
Buf.PutInClipboard
End Sub
After that, switch to Excel and press Ctrl-V - there we go!
If you also want to find the currently running Excel Application and automate even this, let me know.
There's always a valid HTMLBody, even when the mail was sent in Plain Text or RTF, and Excel will display all text attributes conveyed within HTMLBody incl. columns, colors, fonts, hyperlinks, indents etc. However, embedded images are not copied.
This code demonstrates the essentials, but doesn't check if really a MailItem is selected. This would require more coding, if you want to make it work for calendar entries, contacts, etc. as well.
It's enough if you have selected the mail in the list view, you don't even need to open it.
I finally picked it up again and completely automated it. Here are the basics of what I did to automate it.
Dim appExcel As Excel.Application
Dim Buf As MSForms.DataObject
Dim Shape As Excel.Shape
Dim mitm As MailItem
Dim itm As Object
Dim rws As Excel.Worksheet
'code to open excel
Set appExcel = VBA.GetObject(, "Excel.Application")
'...
'code to loop through emails here
Set mitm = itm
body = Replace(mitm.HTMLBody, "http://example.com/images/logo.jpg", "")
Call Buf.SetText(body)
Call Buf.PutInClipboard
Call rws.Cells(i, 1).PasteSpecial
For Each Shape In rws.Shapes
Shape.Delete 'this deletes the empty shapes
Next Shape
'next itm
I removed the logo urls to save time, and when you're dealing with 300 emails, that translates into at least ten minutes saved.
I got the code I needed from a TechRepublic article, and then changed it to suit my needs. Many thanks to the accepted answerer of this question for the clipboard code.
Ok so I will have to make certain assumptions because there is information missing from your question.
Firstly you didn't say what mailformat the message is... HTML would be the easiest, the process will be different for RTF and not possible in plaintext
Since you are refering to tables I will assume they are HTML tables and the mail format is HTML.
Also it is not clear from your question if you want the table content pasted seperately (1 excel cell per table cell) and the rest of the emails bodytext pasted into 1 cell or several?
finally you haven't really said if you want the VBA running from Outlook or Excel (not that important but it affects which intrinsic objects are available.
Anyway code sample:
Outlook code to access the htmlbody prop
Dim mapi As Namespace
Set mapi = Application.Session
Dim msg As MailItem
Set msg = mapi.Folders.Item(1).Folders.Item("Posteingang").Folders.Item(1).Folders.Item(7).Items.Item(526)
Dim strHTML as String
strHTML = msg.HTMLBody
' There is no object model collection for html tables within the htmlbody (which is a string of html) you will need to parse the html and collect the tables before inserting into Excel.
After a while again, I found another way. MailItem.Body is plain text, and has a tab character between table cells. So I used that. Here is the gist of what I did:
Sub Import()
Dim itms As Outlook.Items
Dim itm As Object
Dim i As Long, j As Long
Dim body As String
Dim mitm As Outlook.MailItem
For Each itm In itms
Set mitm = itm
ParseReports (mitm.body) 'uses the global var k
Next itm
End Sub
Sub ParseReports(text As String)
Dim table(1 To 1000, 1 To 11) As String 'I'm not expecting to see a thousand rows!
Dim drow(1 To 11) As String
For Each Row In VBA.Split(text, vbCrLf)
j = 1
For Each Col In VBA.Split(Row, vbTab)
table(i, j) = Col
j = j + 1
Next Col
i = i + 1
Next Row
For i = 1 To l
For j = 1 To 11
drow(j) = table(i, j)
Next j
hws.Range(hws.Cells(k, 1), hws.Cells(k, 11)) = drow
k = k + 1
Next i
End Sub
Average: 77 emails processed per second. I do some minor processing and extracting.