sdrloveshim
New Member
- Joined
- May 10, 2016
- Messages
- 4
So I had this code working, everything except the 2nd ie tab that's loaded up won't close. So I fiddled around with it some more and I broke it I guess. I don't think I changed anything that would have to do with the line of code that's throwing an error but I may just be missing it. Full code is lower down if you need it. Here is what I believe is relevant code:
The code below is the full length of my current code:
Code:
Dim ie As Object
Dim RowCount As Integer
Dim i As Integer
Dim shellWins As ShellWindows
Dim htmlColl2 As MSHTML.IHTMLElementCollection
Dim htmlInput2 As MSHTML.HTMLInputElement
'The code edited out navigates to pilot.com, enters a tracking number, clicks the submit button, brings up a new page with minimal tracking information and clicks a link to load up a new tab with detailed tracking information.
ie.Quit
'it seems I have to close out of the first tab to be able to focus excel on the new one
Set shellWins = New ShellWindows
If shellWins.Count > 0 Then
Set ie2 = shellWins.Item(1)
'this finds the new tab
End If
Do Until Not ie2.Busy And ie2.readyState = 4: DoEvents: Loop
'every so often this will throw an error as well but I don't remember what the error was.
Set htmlColl2 = ie2.document.getElementsByTagName("td")
'The above line causes Runtime error 438 - object doesn't support this property or method.
For Each htmlInput2 In htmlColl2
If htmlInput2.className = "dxgv" Then
If ActiveCell.Offset(RowCount).Value = "" Then
ActiveCell.Offset(RowCount).Value = htmlInput2.innerText
'this puts the status of the shipment in a cell
Else
ActiveCell.OffSet(RowCount, 1).Value = htmlInput2.innerText
'this puts the date of that satus in the next cell
Exit For
End If
End If
Next htmlInput2
ie2.Quit
'This does not close out of the new tab like I'd expect it too and I haven't solved that yet either.*
Set shellWins = Nothing
Set ie2 = Nothing
Code:
Sub WaitHalfSec()
Dim t As Single
t = Timer + 1 / 2
Do Until t < Timer: DoEvents: Loop
End Sub
Sub PilotTracking()
Dim ProURL As String
Dim ie As Object
Dim RowCount As Integer
Dim i As Integer
Dim html_Document As HTMLDocument
Dim htmlColl As MSHTML.IHTMLElementCollection
Dim htmlInput As MSHTML.HTMLInputElement
Dim shellWins As ShellWindows
Dim htmlColl2 As MSHTML.IHTMLElementCollection
Dim htmlInput2 As MSHTML.HTMLInputElement
Set ie = CreateObject("InternetExplorer.application")
RowCount = 0
ProURL = "http://www.pilotdelivers.com/"
Do While Not ActiveCell.Offset(RowCount, -5).Value = ""
With ie
.Visible = False
.navigate ProURL
Do Until Not ie.Busy And ie.readyState = 4: DoEvents: Loop
End With
Set Doc = ie.document 'works don't delete
Doc.getElementById("tbShipNum").innerHTML = ActiveCell.Offset(RowCount, -5).Value 'works don't delete
Doc.getElementById("btnTrack").Click 'works don't delete
Do Until Not ie.Busy And ie.readyState = 4: DoEvents: Loop
i = 0
Do While i < 4
WaitHalfSec
i = i + 1
Loop
Do Until Not ie.Busy And ie.readyState = 4: DoEvents: Loop
Set htmlColl = ie.document.getElementsByTagName("a")
For Each htmlInput In htmlColl
If htmlInput.ID = "clickElement" Then
htmlInput.Click
Exit For
End If
Next htmlInput
ie.Quit
Set shellWins = New ShellWindows
If shellWins.Count > 0 Then
Set ie2 = shellWins.Item(1)
End If
i = 0
Do While i < 6
WaitHalfSec
i = i + 1
Loop
Do Until Not ie2.Busy And ie2.readyState = 4: DoEvents: Loop
'every so often this will throw an error as well but I don't remember what the error was.
Set htmlColl2 = ie2.document.getElementsByTagName("td")
'The above line causes Runtime error 438 - object doesn't support this property or method.
For Each htmlInput2 In htmlColl2
If htmlInput2.className = "dxgv" Then
If ActiveCell.Offset(RowCount).Value = "" Then
ActiveCell.Offset(RowCount).Value = htmlInput2.innerText
Else
ActiveCell.OffSet(RowCount, 1).Value = htmlInput2.innerText
Exit For
End If
End If
Next htmlInput2
ie2.Quit
'This does not close out of the new tab like I'd expect it too and I haven't solved that yet either.*
RowCount = RowCount + 1
Loop
Set shellWins = Nothing
Set ie = Nothing
Set ie2 = Nothing
End Sub
Sub WaitHalfSec()
Dim t As Single
t = Timer + 1 / 2
Do Until t < Timer: DoEvents: Loop
End Sub
Last edited by a moderator:
