Tim:
Your solution works --- thanks.
In my application, the target table has 14 columns and typically 8500 rows
(the row count varies daily).
The application runs slowly due to the cell-by-cell copying, requiring just
over 8 minutes to
complete. Is there a faster alternative, such as using some other form of
"innerTable" referencing
or by somehow using "queryTable"? If so, please provide code examples.
The complete working excel application is listed below.
There may be some extraneous statements remaining in the code from debugging.
Fixed time delays seem to be necessary, or otherwise the application doesnt
always work.
Thanks again
'-----------------------------------------------------------------------------
--------------------------------------------------------------
' Opens a specific webpage which does not have a directly addressable URL,
' captures table data located on the page, and copies it into a spreadsheet.
'-----------------------------------------------------------------------------
--------------------------------------------------------------
Sub Nas_CLT_Data_Fetch()
Dim ie As Object
Dim ieDoc As Object
Dim starttime As String
Dim endtime As String
Dim oDoc As Object
Dim oTable As Object
Windows("PERSONAL.XLS").Activate
starttime = Range("A5").Value
endtime = Range("A6").Value
Workbooks.Open Filename:= _
"C:\Documents and Settings\theRealUser\My Documents\REPORT_GEN.XLS"
Sheets("CLT").Select
Range("A13").Select
Set ie = CreateObject("InternetExplorer.Application")
ie.Visible = True
ie.navigate "
http://theRealUrl/nas/index.html"
Application.Wait (Now() + TimeValue("0:00:02"))
Do While ie.Busy: DoEvents: Loop
Do Until ie.ReadyState = 4: Loop
Application.Wait (Now() + TimeValue("0:00:05"))
ie.document.all.Item("name").Value = "theRealUserName"
ie.document.all.Item("passwd").Value = "theRealPassword"
ie.document.all.Item("submit").Click
Application.Wait (Now() + TimeValue("0:00:02"))
Do While ie.Busy: DoEvents: Loop
Do Until ie.ReadyState = 4: Loop
Application.Wait (Now() + TimeValue("0:00:10"))
ie.document.all.Item("cstep").Click
ie.document.all.Item("tspan").selectedIndex = 8
ie.document.getElementById("customSpan2").Style.visibility = "visible"
ie.document.all.Item("stime").Value = starttime
ie.document.all.Item("etime").Value = endtime
ie.document.all.Item("request").Value = "Summary Table"
ie.document.all.Item("nasForm").submit
Application.Wait (Now() + TimeValue("0:00:02"))
Do While ie.Busy: DoEvents: Loop
Do Until ie.ReadyState = 4: Loop
Application.Wait (Now() + TimeValue("0:00:10"))
ie.Quit
Set ie = Nothing
Set oDoc = GetHTMLDocument("
http://theRealUrl:
8080/nas/servlet/FetchResult")
If Not oDoc Is Nothing Then
Set oTable = oDoc.document.getElementById("nasTab")
CopyTableToRange oTable, Workbooks("REPORT_GEN.XLS").Sheets("CLT").
Range("A13")
End If
oDoc.Quit
Set oDoc = Nothing
End Sub
Sub CopyTableToRange(tTable, rRange As Range)
Dim r, c
Dim iCol As Integer, IRow As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
On Error GoTo haveError
IRow = 0
For Each r In tTable.Rows
iCol = 0
For Each c In r.Cells
rRange.Cells(1).Offset(IRow, iCol).Value = c.innerText
iCol = iCol + 1
Next c
IRow = IRow + 1
Next r
haveError:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Function GetHTMLDocument(sAddress As String) As Object
Dim objShell As Object, objShellWindows As Object, o As Object
Dim retVal As Object, sURL As String
Set retVal = Nothing
Set objShell = CreateObject("Shell.Application")
Set objShellWindows = objShell.Windows
For Each o In objShellWindows
sURL = ""
On Error Resume Next
sURL = o.document.Location
On Error GoTo 0
If sURL <> "" Then
If sURL Like sAddress & "*" Then
Set retVal = o
Exit For
End If
End If
Next o
Set GetHTMLDocument = retVal
End Function
========================================================================
Tim said:
Try this:
*********************************************************
Sub Tester()
Dim o, t
Set o = GetIE("
http://someserver/somepage.html")
If Not o Is Nothing Then
Set t = o.document.getElementsByTagName("table")(0)
CopyTableToRange t, ThisWorkbook.Sheets("Sheet1").Range("A1")
Else
MsgBox "Page not found!"
End If
End Sub
Sub CopyTableToRange(tTable, rRange As Range)
Dim r, c
Dim iCol As Integer, lRow As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
On Error GoTo haveError
lRow = 0
For Each r In tTable.Rows
iCol = 0
For Each c In r.Cells
rRange.Cells(1).Offset(lRow, iCol).Value = c.innerText
iCol = iCol + 1
Next c
lRow = lRow + 1
Next r
haveError:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Function GetIE(sLocation As String) As Object
Dim objShell As Object, objShellWindows As Object, o As Object
Dim sURL As String
Dim retVal As Object
Set retVal = Nothing
Set objShell = CreateObject("Shell.Application")
Set objShellWindows = objShell.Windows
For Each o In objShellWindows
sURL = ""
On Error Resume Next
'check the URL and if it's the one you want then
' assign it to the return value
sURL = o.document.Location
On Error GoTo 0
If sURL Like sLocation & "*" Then
Set retVal = o
Exit For
End If
Next o
Set GetIE = retVal
End Function
'*****************************************************
rows(x) and cells(y) are indexes, not counts.
[quoted text clipped - 31 lines]
--
tmp2100
Message posted via OfficeKB.com
http://www.officekb.com/Uwe/Forums.aspx/excel-programming/200605/1
