I want to automate the summation of a number of cells, in an HTML table on an Outlook email, according to their Red, Amber, Green status.
Scraping the contents is easy with "innerText" but "bgColor" seems to always be blank. I can't find any other attribute where the data might be hiding.
Public Sub TableScrubber()
'This macro interrogates an Outlook email's body to find a table and then show the contents of each cell
Dim outlookHTML As MSHTML.HTMLDocument: Set outlookHTML = New MSHTML.HTMLDocument
Dim elementCollection As MSHTML.IHTMLElementCollection
Dim iItem As Single
Dim iTable As Single
Dim iRow As Long
Dim iColumn As Long
Dim activeSelection As Outlook.Selection
Dim selectedObject As Object
Dim selectedMailItem As mailItem
Dim itemInfo As String
Set activeSelection = Application.ActiveExplorer.Selection
If activeSelection.Count > 0 Then
For iItem = 1 To activeSelection.Count
Set selectedObject = activeSelection.Item(iItem)
If (TypeOf selectedObject Is Outlook.mailItem) Then
Set selectedMailItem = selectedObject
itemInfo = "Message Subject: " & selectedMailItem.Subject
'save Outlook email's html body (tables)
With outlookHTML
.Body.innerHTML = selectedMailItem.HTMLBody
Set elementCollection = .getElementsByTagName("table")
End With
For iTable = 0 To elementCollection.Length - 1
For iRow = 0 To elementCollection(iTable).Rows.Length - 1
For iColumn = 0 To elementCollection(iTable).Rows(iRow).Cells.Length - 1
itemInfo = "The text in this cell is: " & elementCollection(iTable).Rows(iRow).Cells(iColumn).innerText
itemInfo = "The color of this cell is: " & elementCollection(iTable).Rows(iRow).Cells(iColumn).bgColor
Next iColumn
Next iRow
Next iTable
End If
Next iItem
End If
Set outlookHTML = Nothing
Set elementCollection = Nothing
End Sub
The Outlook object model provides three main ways of dealing with message bodies.
The Body property returns or sets a string representing the clear-text body of the Outlook item.
The HTMLBody property of the MailItem class returns or sets a string representing the HTML body of the specified item. Setting the HTMLBody property will always update the Body property immediately. For example:
Sub CreateHTMLMail()
'Creates a new e-mail item and modifies its properties.
Dim objMail As Outlook.MailItem
'Create e-mail item
Set objMail = Application.CreateItem(olMailItem)
With objMail
'Set body format to HTML
.BodyFormat = olFormatHTML
.HTMLBody = "<HTML><BODY>Enter the message text here. </BODY></HTML>"
.Display
End With
End Sub
The Word object model can be used for dealing with message bodies. See Chapter 17: Working with Item Bodies for more information.
So, you can use the Word object model for dealing with tables and changing their styles.
Related
I stole a function from somewhere online that allows me to take HTML from my clipboard and put in an Outlook 2013 email.
This works fine, but I would also like to modify it to grab the first line of text from the email body and use that as the subject line.
That way everything can be included in the HTML. However I have almost no experience with VB and after spending some time online look at API's and documentation I am still not able to figure it out. Here is what I have so far.
Sub PrependClipboardHTML()
Dim email As Outlook.MailItem
Dim cBoard As DataObject
Dim lines() As String
Set email = Application.ActiveInspector.CurrentItem
Set cBoard = New DataObject
cBoard.GetFromClipboard
email.HTMLBody = cBoard.GetText + email.HTMLBody
lines = Split(email.Body, vbNewLine)
' this does not produce anything
email.subject = lines(0)
'remove first line of email
Set cBoard = Nothing
Set email = Nothing
End Sub
To reiterate, I want to remove the first line of the post-formatted email body and use it as the subject line.
This is quick and dirty, grabbing a few mins here and there to construct, but something like this should get you started:
Public Sub PrependClipboardToHTML()
Dim email As Outlook.MailItem
Dim cBoard As DataObject
Dim cText, strLine As String
Dim strArray() As String
Set email = Application.CreateItem(olMailItem)
Set cBoard = New DataObject
cBoard.GetFromClipboard
cText = cBoard.GetText
strArray = Split(cText, vbCrLf)
strLine = CStr(strArray(0))
With email
.To = "someone#domain.com"
.Subject = strLine
.BodyFormat = olFormatHTML ' olFormatPlain == send plain text message
.HTMLBody = cText + email.HTMLBody
.Display
End With
Set email = Nothing
Set cBoard = Nothing
End Sub
I did some more research and read over the API's. In the end I figured it out. My solution is posted below. Thanks for all the help from the other commenters.
Sub PrependClipboardHTML()
Dim email As Outlook.MailItem
Dim cBoard As DataObject
Set email = Application.ActiveInspector.CurrentItem
Set cBoard = New DataObject
cBoard.GetFromClipboard
Dim sText As String
Dim headerStart As Integer
Dim headerEnd As Integer
Dim HTMLPre As String
Dim HTMLPost As String
Dim subject As String
Const headerStartLen = 20
Const headerEndStr = "</h2>"
sText = cBoard.GetText
headerStart = InStr(sText, "<h2 id=")
If headerStart > 0 Then
headerEnd = InStr(headerStart, sText, headerEndStr)
If headerEnd > 0 Then
subject = Mid(sText, _
headerStart + headerStartLen, _
headerEnd - headerStart - headerStartLen)
HTMLPre = Mid(sText, 1, headerStart - 1)
HTMLPost = Mid(sText, headerEnd + Len(headerEndStr))
End If
End If
email.HTMLBody = HTMLPre + HTMLPost + email.HTMLBody
If Len(email.subject) = 0 Then
email.subject = subject
End If
Set cBoard = Nothing
Set email = Nothing
End Sub
I am trying to create an excel web scraper that logs into my companies ticket tracking system and logs certain information on the sheet (Lead assigned, Desired Date for the project, etc.). I was doing fine until I had to pull a field off the website that has a changing ID.
For example, on two pages the same field will have the IDs:
"cq_widget_CqFilteringSelect_32"
"cq_widget_CqFilteringSelect_9"
Can somebody provide guidance to how I should search and paste the "IT Lead" value into excel?
HTML snippet of div
Snippet of actual website
Setup in excel
Below is what I have so far
I get confused in this area:
lead = objCollection(i).Value
Sub CQscrub()
Dim i As Long
Dim objElement As Object
Dim objCollection As Object
Dim objCollection2 As Object
Dim ie As InternetExplorer
Dim html As HTMLDocument
Dim numbers() As String
Dim size As Integer
Dim row As Integer
Dim objLead As Object
Dim objLead2 As Object
Dim lead As String
Dim counter As Integer
size = WorksheetFunction.CountA(Worksheets(1).Columns(1)) - 4
ReDim numbers(size)
For row = 10 To (size + 10)
numbers(row - 10) = Cells(row, 1).Value
'Cells(row, 2) = numbers(row - 10)
Next row
Set ie = New InternetExplorer
ie.Height = 1000
ie.Width = 1000
ie.Visible = True
ie.navigate "http://clearquest/cqweb/"
Application.StatusBar = "Loading http://clearquest/cqweb"
Do While ie.Busy
Application.Wait DateAdd("s", 1, Now)
Loop
Application.StatusBar = "Searching form. Please wait..."
'Had these below as comment
Dim WRnumber1 As String
WRnumber1 = Range("A10").Value
'Range("A6").Value = WRnumber1
Dim iLastRow As Integer
Dim Rng As Range
iLastRow = Cells(Rows.Count, "a").End(xlUp).row 'last row of A
'Set objCollection = ie.document.getElementsByTagName("input") originally here
For counter = 0 To size - 1
Set objCollection = ie.document.getElementsByTagName("input")
i = 0
While i < objCollection.Length
If objCollection(i).Name = "cqFindRecordString" Then
objCollection(i).Value = numbers(counter)
End If
i = i + 1
Wend
'''''''''''''''''' Find Label ''''''''''''''''''''''''''''
Set objCollection = ie.document.getElementsByTagName("label")
i = 0
While i < objCollection.Length
If objCollection(i).innerText = "IT Lead/Assigned To" Then
lead = objCollection(i).Value
'Set objLead = objCollection(i)
End If
i = i + 1
Wend
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Range("B" & (iLastRow - (size - counter - 1))).Value = lead
Set objElement = ie.document.getElementById("cqFindRecordButton")
objElement.Click
Do While ie.Busy
Application.Wait DateAdd("s", 1, Now)
Loop
Application.Wait (Now + TimeValue("0:00:02"))
Next counter
ie.Quit
Set ie = Nothing
Set objElement = Nothing
Set objCollection = Nothing
Application.StatusBar = ""
MsgBox "Done!"
End Sub
Note: Website is internal only
Goal: Select Name under "IT Lead/Assigned To" field and paste to Excel
Thanks
Regarding the supplied code, tl;dr.
But if you are wanting the scratched out portion you supplied in your HTML snippet, the following may work (I can't test something that I don't have access to :D).
There are many different ways to grab an element, and this method you are grabbing the first instance of the class name dijitReset dijitInputField dijitInputContainer. Class names are not always a unique value, but due to the somewhat complexity of this class name, I feel somewhat safe that in your case it is.
You could have used one line to Set yourObj... but for demonstration purposes I decided to break it up. 1-liner method to Set your obj:
Set yourObj = doc.getElementsByClassName("dijitReset dijitInputField dijitInputContainer")(0).getElementsByTagName("input")(1)
Code Snippet:
Sub getElementFromIE()
Dim ie As InternetExplorer
' ... your above code pulls up webpage ...
'''''''''''''''''' Find Label ''''''''''''''''''''''''''''
Dim doc As HTMLDocument, yourObj As Object
Set doc = ie.document
' I assume the class name is unique? If so, just append (0) as I did below
Set yourObj = doc.getElementsByClassName("dijitReset dijitInputField dijitInputContainer")(0)
Set yourObj = yourObj.getElementsByTagName("input")(1)
lead = yourObj.Value
End Sub
The reason for the (1) on Set yourObj = yourObj.getElementsByTagName("input")(1) is because there are 2 input tags after your class dijitReset.... You are wanting the 2nd instance of this tag, which contains your value; and as you are probably already aware, you are using Base 0, meaning the 2nd instance is actually the number 1.
I am using this code in MS Access to to open a saved HTML Outlook Template. The code searches for "SALUTATION" in the body of the email and replaces it with controls data from my form.
It works pretty well but, I lose the email formatting which includes formatted text, multiple links and a few images.
How can my code be changed to keep the original formatting?
Private Sub Command139_Click()
Dim myOlApp As Outlook.Application
Dim MyItem As Outlook.MailItem
Dim value As String
value = Me.Salutation & " " & Me.LastName
Set myOlApp = CreateObject("Outlook.Application")
Set MyItem = myOlApp.CreateItemFromTemplate("C:\Users\Meiaer\AppData\Roaming\Microsoft\Templates\ELMOVM.oft")
MyItem.Display
With MyItem
.To = Me.EMAIL_ADDRESS
MyItem.Body = Replace(MyItem.Body, "SALUTATION", value)
End With
Set MyItem = Nothing
Set myOlApp = Nothing
End Sub
Thank you
You need to edit MyItem.HTMLBody, not MyItem.Body (which is the plaintext representation of the mail body).
See https://technet.microsoft.com/en-us/library/ff868941(v=office.14).aspx
I'm trying to extract US Patent titles using MSXML6.
On the full-text html view of a patent document on the USPTO website, the patent title appears as the first and only "font" element that is a child of "body".
Here is my function that is not working (I get no error; the cell with the formula just stays blank).
Can somebody help me figure out what is wrong?
An example URL that I am feeding into the function is http://patft.uspto.gov/netacgi/nph-Parser?Sect1=PTO1&Sect2=HITOFF&d=PALL&p=1&u=%2Fnetahtml%2FPTO%2Fsrchnum.htm&r=1&f=G&l=50&s1=6293874.PN.&OS=PN/6293874&RS=PN/6293874
Function getUSPatentTitle(url As String)
Static colTitle As New Collection
Dim title As String
Dim pageSource As String
Dim xDoc As MSXML2.DOMDocument
Dim xNode As IXMLDOMNode
On Error Resume Next
title = colTitle(url)
If Err.Number <> 0 Then
Set html_doc = CreateObject("htmlfile")
Set xml_obj = CreateObject("MSXML6.XMLHTTP60")
xml_obj.Open "GET", url, False
xml_obj.send
pageSource = xml_obj.responseText
Set xml_obj = Nothing
Set xDoc = New MSXML2.DOMDocument
If Not xDoc.LoadXML(pageSource) Then
Err.Raise xDoc.parseError.ErrorCode, , xDoc.parseError.reason
End If
Set xNode = xDoc.getElementsByTagName("font").Item(1)
title = xNode.Text
If Not title = "" Then colTitle.Add Item:=title, Key:=url
End If
On Error GoTo 0 ' I understand "GoTo" is dangerous coding but copied from somebody and so far haven't thought of a more natural substitute for a GoTo statement
getUSPatentTitle = title
End Function
Just a few points:
"On Error Goto 0" is not really a traditional Goto statement - it's just how you turn off user error handling in VBA. There were a few errors in your code but the "On Error Resume Next" skipped them so you saw nothing.
The data from the web page is in HTML format not XML.
There were a few "font" elements before the one with the title.
This should work:
Function getUSPatentTitle(url As String)
Static colTitle As New Collection
Dim title As String
Dim pageSource As String
Dim errorNumber As Integer
On Error Resume Next
title = colTitle(url)
errorNumber = Err.Number
On Error GoTo 0
If errorNumber <> 0 Then
Dim xml_obj As XMLHTTP60
Set xml_obj = CreateObject("MSXML2.XMLHTTP")
xml_obj.Open "GET", url, False
xml_obj.send
pageSource = xml_obj.responseText
Set xml_obj = Nothing
Dim html_doc As HTMLDocument
Set html_doc = CreateObject("HTMLFile")
html_doc.body.innerHTML = pageSource
Dim fontElement As IHTMLElement
Set fontElement = html_doc.getElementsByTagName("font").Item(3)
title = fontElement.innerText
If Not title = "" Then colTitle.Add Item:=title, Key:=url
End If
getUSPatentTitle = title
End Function
CSS selector:
You can re-write what you described, which in fact is first font tag within a body tag as a CSS selector of:
body > font
CSS query:
VBA:
As it is the first match/only you want you can use the querySelector method of document to apply the selector and retrieve a single element.
Debug.Print html_doc.querySelector("body > font").innerText
You may need to add a reference to HTML Object Library and use an early bound call of Dim html_doc As HTMLDocument to access the method. The late bound method may expose the querySelector method but if the interface doesn't then use early binding.
This is kind of a repost to reorganize my question but:
I'm trying to match my spreadsheets cell B1 text with all the cells in the 10th column of a table on a webpage. If theres a match, I want to copy that rows cell 4 text. So far I have:
Dim colRows As Object
Dim objDataGrid As Object
Dim xobj1 As Object
Dim xcel As Object
Set objDataGrid = IE.Document.getElementById("DataGridReservations")
Set colRows = objDataGrid.getElementsByTagName("tr")
For Each element In colRows
Set xcel = colRows.getElementsByTagName("td")
If Range("B1").Text = xcel.Item(9).innertext Then
Range("H" & (ActiveCell.Row)) = xcel.Item(3).innertext
Else
Range("H" & (ActiveCell.Row)) = "0"
End If
Exit For
Next
I'm getting an error at the line
set xcel = colRows.getElementsByTagName....
Pulling my hair out. Also, just to be sure, "For Each element in colRows" element will only refer to "getElementsbyTagName("tr")" that I defined in set colRows. it wont also pickup the td tags bracketed in tr right?
We could have more chance for success with this:
Sub sof20255214WebpageCell()
Dim colRows As Object
Dim objDataGrid As Object
Dim xobj1 As Object
Dim element
Dim xcel As Object
Dim IE
Set IE = CreateObject("InternetExplorer.Application")
IE.navigate "http://www.example.com/DataGridPage.php"
While (IE.Busy Or IE.READYSTATE <> 4)
DoEvents
Wend
Set objDataGrid = IE.Document.getElementById("DataGridReservations")
Set colRows = objDataGrid.getElementsByTagName("tr")
For Each element In colRows
Set xcel = element.getElementsByTagName("td")
If Range("B1").Text = xcel.Item(9).innerText Then
Range("H" & (ActiveCell.Row)) = xcel.Item(3).innerText
Else
Range("H" & (ActiveCell.Row)) = "0"
End If
Exit For
Next
IE.Quit
End Sub
Anyway, we cannot use this (BAD):
Set xcel = colRows.getElementsByTagName("td")
As colRows is a collection of rows, but not a single row object. Nevertheless, you can use this (Good):
Set xcel = colRows.Item(0).getElementsByTagName("td")