lkpederson
06-14-2015, 04:20 PM
I have an array (shortened version shown below) that I need to enter on to a web page (URL below) then scrape the standard number (e.g. C31), the title and current date.
I can get the following code to search once but not multiple times. I cannot get the previous entry to clear. I've tried:
Sendkeys "{BKSP 6}" which was pretty hilarious as the backspaces occurred on the debug screen.
Std(i).Value = ""
Std(I).Value = Nothing
The previous value must be cleared before the next can be entered. Suggestions?
Sub Notmuch()
Dim temparr(4) As String
Dim ResMtrx1() As String
temparr(0) = "ASTM C31"
temparr(1) = "ASTM C33"
temparr(2) = "ASTM C309"
temparr(3) = "ASTM C595"
temparr(4) = "ASTM D1752"
Call ASTM(temparr(), ResMtrx1())
End Sub
Function ASTM(temparr() As String, ResMtrx() As String) As String
' different web page.
' had to activate library Microsoft HTML object library (MSHTML.TLB) via
' "Tools" > "References". Then get the IHTML items
Dim Std As Object
Dim el As Object
Dim s As String
Dim Element As IHTMLElement 'IHTMLElement
Dim Elements As IHTMLElementCollection ' IHTMLElementCollection
Dim r() As String, Stdarr(0) As String, Rat() As String
Dim i As Long, j As Long, k As Long, l As Long
l = 0 ' counter for result
ReDim Rat(5)
Set browser = CreateObject("InternetExplorer.Application")
Set browser = New InternetExplorer
browser.Visible = True
browser.navigate "http://www.astm.org/Standard/standards-and-publications.html"
Set ojbb = CreateObject("WScript.shell")
ReDim ResMtrx(UBound(temparr), 2)
On Error GoTo Errhandler
Do While browser.Busy
Loop
For j = LBound(temparr) To UBound(temparr)
Set Std = browser.Document.getElementsByName("query")
Do While browser.Busy
Loop
Start:
If j <> 0 Then
Std(j).Value = " "
' browser.SendKeys "{BKSP 6}", True
End If
Std(j).Value = temparr(j)
For Each el In browser.Document.getElementsByClassName("primary-button nofloat")
el.Click
Next el
Do While browser.Busy
Loop
Set Elements = browser.Document.getElementsByTagName("script")
Do While browser.Busy
Loop
If Elements Is Nothing Then GoTo Start
Do While browser.Busy
Loop
For Each Element In Elements
Do While browser.Busy
Loop
' get the info off the internet and into an array
' try to avoid Error 70
If Element.innerText <> "" Then
Rat(i) = Element.innerText
If i = UBound(Rat) Then
ReDim Preserve Rat(i * 2)
End If
i = i + 1
End If
Next Element
Errhandler:
Select Case Err
Case 70
Do While Err.Number = 70
Loop
GoTo Start
Resume
End Select
For i = LBound(Rat) To UBound(Rat)
r = Split(Rat(i), Chr(34), -1, vbBinaryCompare) 'split on quotation mark, Chr(34)
q = LBound(r) ' want a variable as is a sequential search. Don't need to go back _
through old.
For k = LBound(r) To UBound(r)
If InStr(1, r(k), "Standard Specification for ", vbBinaryCompare) > 0 Then
ResMtrx(l, 0) = Mid(r(k), 27, Len(r(k)) - 26)
ElseIf InStr(1, r(k), "Standard Test Method for ") > 0 Then
ResMtrx(l, 0) = Mid(r(k), 26, Len(r(k)) - 25)
ElseIf InStr(1, r(k), "Standard Practice for ") > 0 Then
ResMtrx(l, 0) = Mid(r(k), 23, Len(r(k)) - 22)
ElseIf r(k) = "gs_designation" Then
ResMtrx(l, 1) = r(k + 2)
ElseIf r(k) = "mc_date" Then
ResMtrx(l, 2) = r(k + 2)
ElseIf ResMtrx(l, 2) <> "" Then 'array row is full, exit, get new std
Exit For
End If
Next k
If ResMtrx(l, 2) <> "" Then
l = l + 1
Exit For
End If
Next i
Next j
ResMtrx1 = ResMtrx()
End Function
I can get the following code to search once but not multiple times. I cannot get the previous entry to clear. I've tried:
Sendkeys "{BKSP 6}" which was pretty hilarious as the backspaces occurred on the debug screen.
Std(i).Value = ""
Std(I).Value = Nothing
The previous value must be cleared before the next can be entered. Suggestions?
Sub Notmuch()
Dim temparr(4) As String
Dim ResMtrx1() As String
temparr(0) = "ASTM C31"
temparr(1) = "ASTM C33"
temparr(2) = "ASTM C309"
temparr(3) = "ASTM C595"
temparr(4) = "ASTM D1752"
Call ASTM(temparr(), ResMtrx1())
End Sub
Function ASTM(temparr() As String, ResMtrx() As String) As String
' different web page.
' had to activate library Microsoft HTML object library (MSHTML.TLB) via
' "Tools" > "References". Then get the IHTML items
Dim Std As Object
Dim el As Object
Dim s As String
Dim Element As IHTMLElement 'IHTMLElement
Dim Elements As IHTMLElementCollection ' IHTMLElementCollection
Dim r() As String, Stdarr(0) As String, Rat() As String
Dim i As Long, j As Long, k As Long, l As Long
l = 0 ' counter for result
ReDim Rat(5)
Set browser = CreateObject("InternetExplorer.Application")
Set browser = New InternetExplorer
browser.Visible = True
browser.navigate "http://www.astm.org/Standard/standards-and-publications.html"
Set ojbb = CreateObject("WScript.shell")
ReDim ResMtrx(UBound(temparr), 2)
On Error GoTo Errhandler
Do While browser.Busy
Loop
For j = LBound(temparr) To UBound(temparr)
Set Std = browser.Document.getElementsByName("query")
Do While browser.Busy
Loop
Start:
If j <> 0 Then
Std(j).Value = " "
' browser.SendKeys "{BKSP 6}", True
End If
Std(j).Value = temparr(j)
For Each el In browser.Document.getElementsByClassName("primary-button nofloat")
el.Click
Next el
Do While browser.Busy
Loop
Set Elements = browser.Document.getElementsByTagName("script")
Do While browser.Busy
Loop
If Elements Is Nothing Then GoTo Start
Do While browser.Busy
Loop
For Each Element In Elements
Do While browser.Busy
Loop
' get the info off the internet and into an array
' try to avoid Error 70
If Element.innerText <> "" Then
Rat(i) = Element.innerText
If i = UBound(Rat) Then
ReDim Preserve Rat(i * 2)
End If
i = i + 1
End If
Next Element
Errhandler:
Select Case Err
Case 70
Do While Err.Number = 70
Loop
GoTo Start
Resume
End Select
For i = LBound(Rat) To UBound(Rat)
r = Split(Rat(i), Chr(34), -1, vbBinaryCompare) 'split on quotation mark, Chr(34)
q = LBound(r) ' want a variable as is a sequential search. Don't need to go back _
through old.
For k = LBound(r) To UBound(r)
If InStr(1, r(k), "Standard Specification for ", vbBinaryCompare) > 0 Then
ResMtrx(l, 0) = Mid(r(k), 27, Len(r(k)) - 26)
ElseIf InStr(1, r(k), "Standard Test Method for ") > 0 Then
ResMtrx(l, 0) = Mid(r(k), 26, Len(r(k)) - 25)
ElseIf InStr(1, r(k), "Standard Practice for ") > 0 Then
ResMtrx(l, 0) = Mid(r(k), 23, Len(r(k)) - 22)
ElseIf r(k) = "gs_designation" Then
ResMtrx(l, 1) = r(k + 2)
ElseIf r(k) = "mc_date" Then
ResMtrx(l, 2) = r(k + 2)
ElseIf ResMtrx(l, 2) <> "" Then 'array row is full, exit, get new std
Exit For
End If
Next k
If ResMtrx(l, 2) <> "" Then
l = l + 1
Exit For
End If
Next i
Next j
ResMtrx1 = ResMtrx()
End Function