G
Guest
I am running the following code. It runs down a list of rows retrieving data
from the web for me. After it cycles through 92 rows, I receive the
following error:
======
Run-time error '-2147417848 (80010108)':
Automation error
The object invoked has disconnected from its clients.
======
Once I get this error, I have to shut completely down and can only recover
from my last saved point. This always happens after the exact same number of
rows, no matter how the data is sorted.
Any help would be highly appreciated. Here is my code:
------------
Sub Dex001()
'This subprocedure looks up phone book information:
Dim strLast As String
Dim strFirst As String
'Dim bSimilarNames As Boolean 'Smart
Dim strCity As String
Dim strState As String
'Dim bSurroundingAreas As Boolean 'Metro
Dim DesiredRow As Long
Dim PositionOfSpace As Long
'Init Vars:
'DesiredRow =
Workbooks(Application.ActiveWorkbook.Name).Sheets("Dex").Range("D6")
DesiredRow = Application.ActiveCell.Row
strLast =
Workbooks(Application.ActiveWorkbook.Name).Sheets("DexData").Range("A" &
DesiredRow)
strFirst =
Workbooks(Application.ActiveWorkbook.Name).Sheets("DexData").Range("B" &
DesiredRow)
'bSimilarNames =
Workbooks(Application.ActiveWorkbook.Name).Sheets("DexData").Range("B" &
DesiredRow)
strCity =
Workbooks(Application.ActiveWorkbook.Name).Sheets("DexData").Range("C" &
DesiredRow)
'Replace spaces with "+" in the City name
PositionOfSpace = InStr(1, strCity, " ")
If PositionOfSpace > 0 Then
strCity = Left(strCity, PositionOfSpace - 1) & "+" & Right(strCity,
Len(strCity) - PositionOfSpace)
End If
strState =
Workbooks(Application.ActiveWorkbook.Name).Sheets("DexData").Range("D" &
DesiredRow)
'bSurroundingAreas =
Workbooks(Application.ActiveWorkbook.Name).Sheets("DexData").Range("B" &
DesiredRow)
If strLast <> "" Or strFirst <> "" Then
'Start by clearing the data area:
Columns("I:J").Select
Selection.Delete Shift:=xlToLeft
'Now use the Web Query to fetch the data:
With
ActiveSheet.QueryTables.Add(Connection:="URL;http://www.dexonline.com/servlet/Ac...esWhite&from=&PREVIOUS_PAGE=rsearch&lastname="
& strLast & "&firstname=" & strFirst & "&smart=1&city=" & strCity & "&state="
& strState & "&Search+The+Listings.x=47&Search+The+Listings.y=13",
Destination:=Sheets("DexData").Range("I1"))
'With
ActiveSheet.QueryTables.Add(Connection:="URL;http://www.dexonline.com/servlet/Ac...esWhite&from=&PREVIOUS_PAGE=rsearch&lastname="
& strLast & "&firstname=" & strFirst & "&smart=1&city=" & strCity & "&state="
& strState & "&metro=1&Search+The+Listings.x=47&Search+The+Listings.y=13",
Destination:=Sheets("DexData").Range("I1"))
.Name =
"ActionServlet?pid=rresults&form=ResWhite&from=&PREVIOUS_PAGE=rsearch&lastname="
& strLast & "&firstname=" & strFirst & "&smart=1&city=" & strCity & "&state="
& strState & "&Search+The+Listings.x=47&Search+The+Listings"
'.Name =
"ActionServlet?pid=rresults&form=ResWhite&from=&PREVIOUS_PAGE=rsearch&lastname="
& strLast & "&firstname=" & strFirst & "&smart=1&city=" & strCity & "&state="
& strState & "&metro=1&Search+The+Listings.x=47&Search+The+Listings"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = False 'was True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "10"
.WebPreFormattedTextToColumns = False
.WebConsecutiveDelimitersAsOne = False
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = True
.Refresh BackgroundQuery:=False
End With
Else
MsgBox "Please select the row you are trying to update before clicking
the button."
End If
Range("A" & DesiredRow).Select
End Sub
Sub CompleteProcess()
Dim DesiredRow As Long
DesiredRow = Application.ActiveCell.Row
'Setup a brief pause:
'Dim newHour, newMinute, newSecond, waitTime
'newHour = Hour(Now())
'newMinute = Minute(Now())
'newSecond = Second(Now()) + 10
'waitTime = TimeSerial(newHour, newMinute, newSecond)
'Application.Wait waitTime
'Now beep 3 times:
'Dim I
'For I = 1 To 200 ' Loop X times.
' Beep ' Sound a tone.
'Next I
'Paste the values where they belong
Sheets("DexData").Select
Range("I2").Select
Selection.Copy
Range("E" & DesiredRow).Select
ActiveSheet.Paste
Range("J1").Select
Application.CutCopyMode = False
Selection.Copy
Range("F" & DesiredRow).Select
ActiveSheet.Paste
Columns("E:F").Select
Columns("E:F").EntireColumn.AutoFit
Columns("I:J").Select
Selection.Delete Shift:=xlToLeft
'Clear the garbage left behind
'Columns("I:J").Select
'Selection.Delete Shift:=xlToLeft
Range("A" & DesiredRow).Select
End Sub
ActionServlet?pid=rresults&form=ResWhite&from=&PREVIOUS_PAGE=rsearch&lastname=webster&firstname=byran&city=holladay&state=UT&metro=1&Search+The+Listings.x=0&Search+The+Listings.y=0
Public Sub Test_IESendkeys()
Dim i As Long
Dim ie As Object
Set ie = CreateObject("InternetExplorer.Application")
With ie
.Visible = True
.navigate "http://www.funny.com"
.resizable = True
End With
Application.Wait (Now + TimeValue("0:00:10"))
'App.Activate "Microsoft Internet Explorer"
For i = 1 To 15
SendKeys "{TAB}"
Next i
SendKeys "test"
'SendKeys "~"
End Sub
Set oIE = New InternetExplorer
oIE.Visible = True
oIE.Navigate Range("sURL")
Do: DoEvents: Loop Until oIE.ReadyState = READYSTATE_COMPLETE
Set oForm = oIE.Document.forms(0)
oForm("name1").Value = "Value1"
oForm("name2").Value = "Value2"
oForm("submitname").Click
Do: DoEvents: Loop While oIE.Busy
Do: DoEvents: Loop Until oIE.ReadyState = READYSTATE_COMPLETE
Set oForm = oIE.Document.forms(0)
oForm("cancelname").Click
from the web for me. After it cycles through 92 rows, I receive the
following error:
======
Run-time error '-2147417848 (80010108)':
Automation error
The object invoked has disconnected from its clients.
======
Once I get this error, I have to shut completely down and can only recover
from my last saved point. This always happens after the exact same number of
rows, no matter how the data is sorted.
Any help would be highly appreciated. Here is my code:
------------
Sub Dex001()
'This subprocedure looks up phone book information:
Dim strLast As String
Dim strFirst As String
'Dim bSimilarNames As Boolean 'Smart
Dim strCity As String
Dim strState As String
'Dim bSurroundingAreas As Boolean 'Metro
Dim DesiredRow As Long
Dim PositionOfSpace As Long
'Init Vars:
'DesiredRow =
Workbooks(Application.ActiveWorkbook.Name).Sheets("Dex").Range("D6")
DesiredRow = Application.ActiveCell.Row
strLast =
Workbooks(Application.ActiveWorkbook.Name).Sheets("DexData").Range("A" &
DesiredRow)
strFirst =
Workbooks(Application.ActiveWorkbook.Name).Sheets("DexData").Range("B" &
DesiredRow)
'bSimilarNames =
Workbooks(Application.ActiveWorkbook.Name).Sheets("DexData").Range("B" &
DesiredRow)
strCity =
Workbooks(Application.ActiveWorkbook.Name).Sheets("DexData").Range("C" &
DesiredRow)
'Replace spaces with "+" in the City name
PositionOfSpace = InStr(1, strCity, " ")
If PositionOfSpace > 0 Then
strCity = Left(strCity, PositionOfSpace - 1) & "+" & Right(strCity,
Len(strCity) - PositionOfSpace)
End If
strState =
Workbooks(Application.ActiveWorkbook.Name).Sheets("DexData").Range("D" &
DesiredRow)
'bSurroundingAreas =
Workbooks(Application.ActiveWorkbook.Name).Sheets("DexData").Range("B" &
DesiredRow)
If strLast <> "" Or strFirst <> "" Then
'Start by clearing the data area:
Columns("I:J").Select
Selection.Delete Shift:=xlToLeft
'Now use the Web Query to fetch the data:
With
ActiveSheet.QueryTables.Add(Connection:="URL;http://www.dexonline.com/servlet/Ac...esWhite&from=&PREVIOUS_PAGE=rsearch&lastname="
& strLast & "&firstname=" & strFirst & "&smart=1&city=" & strCity & "&state="
& strState & "&Search+The+Listings.x=47&Search+The+Listings.y=13",
Destination:=Sheets("DexData").Range("I1"))
'With
ActiveSheet.QueryTables.Add(Connection:="URL;http://www.dexonline.com/servlet/Ac...esWhite&from=&PREVIOUS_PAGE=rsearch&lastname="
& strLast & "&firstname=" & strFirst & "&smart=1&city=" & strCity & "&state="
& strState & "&metro=1&Search+The+Listings.x=47&Search+The+Listings.y=13",
Destination:=Sheets("DexData").Range("I1"))
.Name =
"ActionServlet?pid=rresults&form=ResWhite&from=&PREVIOUS_PAGE=rsearch&lastname="
& strLast & "&firstname=" & strFirst & "&smart=1&city=" & strCity & "&state="
& strState & "&Search+The+Listings.x=47&Search+The+Listings"
'.Name =
"ActionServlet?pid=rresults&form=ResWhite&from=&PREVIOUS_PAGE=rsearch&lastname="
& strLast & "&firstname=" & strFirst & "&smart=1&city=" & strCity & "&state="
& strState & "&metro=1&Search+The+Listings.x=47&Search+The+Listings"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = False 'was True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "10"
.WebPreFormattedTextToColumns = False
.WebConsecutiveDelimitersAsOne = False
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = True
.Refresh BackgroundQuery:=False
End With
Else
MsgBox "Please select the row you are trying to update before clicking
the button."
End If
Range("A" & DesiredRow).Select
End Sub
Sub CompleteProcess()
Dim DesiredRow As Long
DesiredRow = Application.ActiveCell.Row
'Setup a brief pause:
'Dim newHour, newMinute, newSecond, waitTime
'newHour = Hour(Now())
'newMinute = Minute(Now())
'newSecond = Second(Now()) + 10
'waitTime = TimeSerial(newHour, newMinute, newSecond)
'Application.Wait waitTime
'Now beep 3 times:
'Dim I
'For I = 1 To 200 ' Loop X times.
' Beep ' Sound a tone.
'Next I
'Paste the values where they belong
Sheets("DexData").Select
Range("I2").Select
Selection.Copy
Range("E" & DesiredRow).Select
ActiveSheet.Paste
Range("J1").Select
Application.CutCopyMode = False
Selection.Copy
Range("F" & DesiredRow).Select
ActiveSheet.Paste
Columns("E:F").Select
Columns("E:F").EntireColumn.AutoFit
Columns("I:J").Select
Selection.Delete Shift:=xlToLeft
'Clear the garbage left behind
'Columns("I:J").Select
'Selection.Delete Shift:=xlToLeft
Range("A" & DesiredRow).Select
End Sub
ActionServlet?pid=rresults&form=ResWhite&from=&PREVIOUS_PAGE=rsearch&lastname=webster&firstname=byran&city=holladay&state=UT&metro=1&Search+The+Listings.x=0&Search+The+Listings.y=0
Public Sub Test_IESendkeys()
Dim i As Long
Dim ie As Object
Set ie = CreateObject("InternetExplorer.Application")
With ie
.Visible = True
.navigate "http://www.funny.com"
.resizable = True
End With
Application.Wait (Now + TimeValue("0:00:10"))
'App.Activate "Microsoft Internet Explorer"
For i = 1 To 15
SendKeys "{TAB}"
Next i
SendKeys "test"
'SendKeys "~"
End Sub
Set oIE = New InternetExplorer
oIE.Visible = True
oIE.Navigate Range("sURL")
Do: DoEvents: Loop Until oIE.ReadyState = READYSTATE_COMPLETE
Set oForm = oIE.Document.forms(0)
oForm("name1").Value = "Value1"
oForm("name2").Value = "Value2"
oForm("submitname").Click
Do: DoEvents: Loop While oIE.Busy
Do: DoEvents: Loop Until oIE.ReadyState = READYSTATE_COMPLETE
Set oForm = oIE.Document.forms(0)
oForm("cancelname").Click