Option Explicit
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private WithEvents IE As WebBrowser
Private ThisAction As String
Private GetObj As Object
Private PrevTdValue As String
Sub GetData()
Dim OSRng As Range, DSRng As Range, Doc As HTMLDocument
On Error Resume Next
Application.DisplayAlerts = False
Sheets("Offensive Stats").Delete
Application.DisplayAlerts = True
On Error GoTo 0
With Sheets.Add()
.Cells(1) = "Loading page..."
.Cells(2, 1) = "Please wait..."
.Name = "Offensive Stats"
Set OSRng = .Range("A2:V2")
End With
' Set DSRng = Sheets.Add().Range("A2:V2")
CreateInstance
Set Doc = QueryGetDocument("DocumentComplete", "http://www.mmobaseball.com/stats.aspx")
If Not Doc Is Nothing Then GetOffensiveTableData Doc, OSRng
Do Until Doc.getElementById("lbtnNextOffense") Is Nothing
Application.Goto OSRng(1)
OSRng(1) = "Loading next page..."
Doc.getElementById("lbtnNextOffense").Click
Set Doc = QueryGetDocument("Table_onafterupdate", , Doc)
If Not Doc Is Nothing Then GetOffensiveTableData Doc, OSRng
Loop
With OSRng.Parent
.Range("A1:V1") = Array("Player", "POS", "TEAM", "AB", "R", "H", "2B", "3B", "HR", "AVG", "RBI", "SLG", "OBP", "TB", "BB", "SO", "SB", "CS", "SAC", "HBP", "IBB", "GDP", "TPA", "XBH")
.Range("A1:V1").Font.Bold = True
.Columns("A:V").EntireColumn.AutoFit
Application.Goto .Cells(1), True
End With
Set GetObj = Nothing
IE.Quit
Set IE = Nothing
PrevTdValue = vbNullString
MsgBox "All done"
End Sub
Private Sub GetOffensiveTableData(Doc As HTMLDocument, DestRng As Range)
Dim TR As HTMLTableRow, x As Integer
For Each TR In Doc.getElementById("maintable").Children(0).tBodies(0).Rows
If x > 0 Then
Application.Goto DestRng(1)
DestRng(1) = TR.Cells(0).Children(0).innerText
For x = 1 To 21
DestRng(x + 1) = TR.Cells(x).innerText
Next x
Set DestRng = DestRng.Offset(1)
Else
PrevTdValue = Doc.getElementById("maintable").Children(0).tBodies(0).Rows(1).Cells(0).innerText
End If
x = x + 1
Next
End Sub
Private Sub CreateInstance(Optional Visible As Boolean = False)
Set IE = New InternetExplorer
IE.Visible = Visible
End Sub
Private Function QueryGetDocument(Action As String, Optional URL As String = "Event", Optional Doc As HTMLDocument) As HTMLDocument
Dim TD As Object
ThisAction = Action
Set GetObj = Nothing
TimedOut 30
If URL <> "Event" Then IE.navigate URL
Do
Sleep 100
DoEvents
If Action = "Table_onafterupdate" Then
On Error Resume Next
Set TD = Doc.getElementById("maintable").Children(0).tBodies(0).Rows(1).Cells(0)
If Not TD Is Nothing And Err.Number = 0 Then
If TD.innerText <> "" And TD.innerText <> PrevTdValue And Err.Number = 0 Then
Set QueryGetDocument = Doc
Exit Function
End If
End If
On Error GoTo 0
Err.Clear
End If
Loop Until Not GetObj Is Nothing Or TimedOut
If TimedOut Then
'timed out
Exit Function
End If
Set QueryGetDocument = GetObj
End Function
Private Sub IE_DocumentComplete(ByVal pDisp As Object, URL As Variant)
If ThisAction = "DocumentComplete" Then Set GetObj = IE.document
End Sub
Private Function TimedOut(Optional Seconds As Integer) As Boolean
Static TimeOutTime As Date
If Seconds > 0 Then
TimeOutTime = DateAdd("s", Seconds, Now)
Else
TimedOut = (Now > TimeOutTime)
End If
End Function
